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

[Andreas Fuchs]

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

Modified Files:
	beirc.lisp 
Log Message:
Show QUIT and NICK messages in every channel the user and me are in.

This change comes at a price: I had to basically copy cl-irc's
READ-MESSAGE method, and use a lot of unexported symbols, too. Ugh.

Date: Sun Sep 25 14:31:13 2005
Author: afuchs

Index: beirc/beirc.lisp
diff -u beirc/beirc.lisp:1.29 beirc/beirc.lisp:1.30
--- beirc/beirc.lisp:1.29	Sun Sep 25 00:30:23 2005
+++ beirc/beirc.lisp	Sun Sep 25 14:31:05 2005
@@ -157,9 +157,11 @@
 
 (macrolet ((define-global-message-receiver-lookup (message-type)
                `(defmethod receiver-for-message ((message ,message-type) frame)
-                  ;; FIXME: global messages should go to all
-                  ;; channels/queries the source (user) was on.
-                  (current-receiver frame))))
+                  (remove nil
+                          (mapcar (lambda (channel)
+                                    (find-receiver (irc:name channel) frame))
+                                  (irc:channels (irc:find-user (beirc::current-connection frame)
+                                                               (irc:source message))))))))
  (define-global-message-receiver-lookup irc:irc-quit-message)
  (define-global-message-receiver-lookup irc:irc-nick-message))
 
@@ -438,20 +440,26 @@
         (text (or (irc:trailing-argument message) "")))
     (search my-nick text)))
 
+(defun post-message-to-receiver (frame message 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)
+
 (defun post-message (frame message)
   (let ((receiver (receiver-for-message message frame)))
-    (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)))
+    (cond ((consp receiver)
+           (loop for 1-receiver in receiver
+                 do (post-message-to-receiver frame message 1-receiver)))
+          ((null receiver) nil)
+          (t (post-message-to-receiver frame message receiver)))))
 
 (defun ticker (frame)
   (loop 
@@ -818,10 +826,23 @@
 (defclass beirc-connection (irc:connection)
      ())
 
-(defmethod irc:read-message :around ((connection beirc-connection))
-  (let ((message (call-next-method connection)))
-    (post-message *application-frame* message)
-    message))
+;;; KLUDGE: "why isn't this an :around method," you ask?  CL-IRC's
+;;; read-message registers the message's content before passing the
+;;; message back, which means that QUIT and NICK messages can not be
+;;; meaningfully decoded, with respect to: on which channels was the
+;;; user before we got the message (so that we can display it
+;;; everywhere it is relevant).
+;;; So, this method is basically a copy of IRC:READ-MESSAGE. ugh.
+(defmethod irc:read-message ((connection beirc-connection))
+  (handler-case
+      (when (irc::connectedp connection)
+        (let ((message (irc::read-irc-message connection)))
+          (post-message *application-frame* message)
+          (irc::irc-message-event message)
+          message))
+    (stream-error (c) (signal 'irc::invalidate-me :stream
+                              (irc:server-stream connection)
+                              :condition c))))
 
 (defun irc-event-loop (frame connection)
   (unwind-protect