[beirc-cvs] CVS update: beirc/beirc.lisp

[Andreas Fuchs]

Update of /project/beirc/cvsroot/beirc
In directory common-lisp.net:/tmp/cvs-serv19320

Modified Files:
	beirc.lisp 
Log Message:
fix NOTICE handling, including network service notices.

also, revert the TICKER function back to its old self; the
handler-case in there served no purpose.


Date: Sat Sep 24 13:43:37 2005
Author: afuchs

Index: beirc/beirc.lisp
diff -u beirc/beirc.lisp:1.19 beirc/beirc.lisp:1.20
--- beirc/beirc.lisp:1.19	Sat Sep 24 11:14:03 2005
+++ beirc/beirc.lisp	Sat Sep 24 13:43:37 2005
@@ -97,13 +97,17 @@
         (add-pane (tab-pane receiver) (find-pane-named frame 'query))))
   (setf (gethash (tab-pane receiver) (tab-panes-to-receivers frame)) receiver))
 
+(defun find-receiver (name frame)
+  (gethash (irc:normalize-channel-name (slot-value frame 'connection) name)
+           (receivers frame)))
+
 (defun intern-receiver (name frame &rest initargs)
-  (let ((rec (gethash (irc:normalize-channel-name (slot-value frame 'connection) name)
-                      (receivers frame))))
+  (let* ((normalized-name (irc:normalize-channel-name (slot-value frame 'connection) name))
+         (rec (find-receiver name frame)))
     (if rec
         rec
         (let ((*application-frame* frame))
-          (let ((receiver (apply 'make-paneless-receiver name initargs)))
+          (let ((receiver (apply 'make-paneless-receiver normalized-name initargs)))
             (initialize-receiver-with-pane receiver frame
                                            (with-look-and-feel-realization
                                                ((frame-manager *application-frame*) *application-frame*)
@@ -117,20 +121,35 @@
             (setf (gethash name (receivers frame)) receiver)
             receiver)))))
 
+(defparameter *network-service-sources* '("nickserv" "memoserv" "chanserv" "")
+  "Sources whose private messages (PRIVMSG, NOTICE, ...) should
+  be treated as if they came from the connected server itself,
+  unless the user has opened a query window to the source
+  already.")
+
+(defun network-service-p (source frame)
+  (member source *network-service-sources*
+          :test (lambda (source1 source2)
+                  (string= (irc:normalize-nickname (current-connection frame) source1)
+                           (irc:normalize-nickname (current-connection frame) source2)))))
+
 (macrolet ((define-privmsg-receiver-lookup (message-type)
                `(defmethod receiver-for-message ((message ,message-type) frame)
-                  (let* ((mynick (irc:normalize-nickname (slot-value frame 'connection)
-                                                         (slot-value frame 'nick)))
-                         (nominal-target (irc:normalize-channel-name (slot-value frame 'connection)
-                                                                     (first (irc:arguments message))))
-                         (target (if (equal nominal-target mynick)
-                                     (irc:source message)
-                                     nominal-target)))
-                    (intern-receiver target frame :channel target)))))
+                  (if (or
+                       (find-receiver (irc:source message) frame)
+                       (not (network-service-p (irc:source message) frame)))
+                      (let* ((mynick (irc:normalize-nickname (current-connection frame)
+                                                             (slot-value frame 'nick)))
+                             (nominal-target (irc:normalize-channel-name (slot-value frame 'connection)
+                                                                         (first (irc:arguments message))))
+                             (target (if (equal nominal-target mynick)
+                                         (irc:source message)
+                                         nominal-target)))
+                        (intern-receiver target frame :channel target))
+                      (server-receiver frame)))))
   (define-privmsg-receiver-lookup irc:irc-privmsg-message)
   (define-privmsg-receiver-lookup irc:ctcp-action-message)
-  ;; (define-privmsg-receiver-lookup irc:irc-notice-message)   ; XXX: NOTICEs in freenode are a bit tricky.
-  )
+  (define-privmsg-receiver-lookup irc:irc-notice-message))
 
 (macrolet ((define-global-message-receiver-lookup (message-type)
                `(defmethod receiver-for-message ((message ,message-type) frame)
@@ -361,28 +380,24 @@
 
 (defun post-message (frame message)
   (let ((receiver (receiver-for-message message frame)))
-    (setf (messages receiver)
-          (append (messages receiver) (list message)))
-    (unless (eql receiver (current-receiver frame))
-      (incf (unseen-messages receiver))
-      (when (message-directed-to-me-p frame message)
-        (incf (messages-directed-to-me receiver))))
-    (update-drawing-options receiver)
-    (clim-internals::event-queue-prepend
-     (climi::frame-event-queue frame)
-     (make-instance 'foo-event :sheet frame :receiver receiver))
-    nil))
+    (unless (null receiver)
+      (setf (messages receiver)
+            (append (messages receiver) (list message)))
+      (unless (eql receiver (current-receiver frame))
+        (incf (unseen-messages receiver))
+        (when (message-directed-to-me-p frame message)
+          (incf (messages-directed-to-me receiver))))
+      (update-drawing-options receiver)
+      (clim-internals::event-queue-prepend
+       (climi::frame-event-queue frame)
+       (make-instance 'foo-event :sheet frame :receiver receiver))
+      nil)))
 
-;;; XXX: ticker continues to run even if the frame is no longer active
-;;; or on the display.
 (defun ticker (frame)
-  (handler-case
-      (loop 
-        (clim-internals::event-queue-prepend (climi::frame-event-queue frame)
-                                             (make-instance 'bar-event :sheet frame))
-        (sleep 1))
-    (frame-exit ()
-      nil)))
+  (loop 
+    (clim-internals::event-queue-prepend (climi::frame-event-queue frame)
+                                         (make-instance 'bar-event :sheet frame))
+    (sleep 1)))
 
 (define-presentation-type nickname ())
 (define-presentation-type ignored-nickname (nickname))