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

[Andreas Fuchs]

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

Modified Files:
	beirc.lisp 
Log Message:
Fix (mostly) two of the three known problems and implement "unseen messages"
functionality in the receiver list.

* on join (you or anybody else), you are no longer thrown into the
  debugger (the problem was that I missed the : in the IRC spec for
  JOIN messages. the channel is passed as the trailing arg.
* implemented more message types for the receiver finder; beirc can
  now stay on #lisp for more than 5 minutes without barfing!

Date: Wed Sep 14 22:12:42 2005
Author: afuchs

Index: beirc/beirc.lisp
diff -u beirc/beirc.lisp:1.2 beirc/beirc.lisp:1.3
--- beirc/beirc.lisp:1.2	Tue Sep 13 22:48:11 2005
+++ beirc/beirc.lisp	Wed Sep 14 22:12:40 2005
@@ -31,7 +31,8 @@
 (cl:eval-when (:compile-toplevel :load-toplevel :execute)
   (cl:require :split-sequence)
   (cl:require :cl-irc)
-  (cl:require :mcclim))
+  (cl:require :mcclim)
+  (cl:require :mcclim-freetype))
 
 (defpackage :beirc
     (:use :clim :clim-lisp :clim-sys)
@@ -68,6 +69,8 @@
 (defclass receiver ()
      ((name :reader receiver-name :initarg :name)
       (messages :accessor messages :initform nil)
+      (unseen-messages :accessor unseen-messages :initform 0)
+      (messages-directed-to-me :accessor messages-directed-to-me :initform 0)
       (channel :reader channel :initform nil :initarg :channel)
       (query :reader query :initform nil :initarg :query) ;; <- XXX: remove this.
       (pane :reader pane :initform nil)
@@ -105,18 +108,36 @@
   (gethash pane (receiver-panes frame)))
 
 
+;;; FIXME: many of these methods are the same and should be refactored
+;;; into perhaps three types.
 (defmethod receiver-for-message ((message irc:irc-privmsg-message) frame)
   ;; XXX: handle target=ournick
   (let ((target (first (irc:arguments message))))
     (intern-receiver target frame :channel target)))
 
-(defmethod receiver-for-message ((message irc:irc-join-message) frame)
+(defmethod receiver-for-message ((message irc:ctcp-action-message) frame)
+  ;; XXX: handle target=ournick
   (let ((target (first (irc:arguments message))))
     (intern-receiver target frame :channel target)))
 
+(defmethod receiver-for-message ((message irc:irc-notice-message) frame)
+  ;; XXX: handle target=ournick
+  (let ((target (first (irc:arguments message))))
+    (intern-receiver target frame :channel target)))
+
+(defmethod receiver-for-message ((message irc:irc-join-message) frame)
+  (let ((target (irc:trailing-argument message)))
+    (intern-receiver target frame :channel target)))
+
 (defmethod receiver-for-message ((message irc:irc-quit-message) frame)
   (current-receiver frame) ; FIXME: quit messages should go to all channels/queries the user was on.
   )
+(defmethod receiver-for-message ((message irc:irc-nick-message) frame)
+  (current-receiver frame) ; FIXME: quit messages should go to all channels/queries the user was on.
+  )
+(defmethod receiver-for-message ((message irc:irc-part-message) frame)
+  (let ((target (first (irc:arguments message))))
+    (intern-receiver target frame :channel target)))
 
 ;; TODO: more receiver-for-message methods.
 
@@ -160,11 +181,14 @@
 				       &key initial-contents
 				       &allow-other-keys)
   (declare (ignore args))
-  (dolist (k initial-contents)
+  (dolist (k (or initial-contents
+                 (list (make-clim-application-pane))))
     (sheet-adopt-child pane k)))
 
 (defun raise-receiver (receiver &optional (frame *application-frame*))
   (setf (current-receiver frame) receiver)
+  (setf (unseen-messages receiver) 0)
+  (setf (messages-directed-to-me receiver) 0)
   (mapcar (lambda (pane)
             (let ((pane-receiver (receiver-for-pane pane frame)))
               (setf (sheet-enabled-p pane)
@@ -399,10 +423,19 @@
                                         :name "Beirc Ticker")
                  (run-frame-top-level frame))))))))
 
+(defun message-directed-to-me-p (frame message)
+  (let ((my-nick (slot-value frame 'nick))
+        (text (or (irc:trailing-argument message) "")))
+    (search my-nick text)))
+
 (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))))
     (clim-internals::event-queue-prepend
      (climi::frame-event-queue frame)
      (make-instance 'foo-event :sheet frame :receiver receiver))
@@ -431,7 +464,10 @@
     (maphash #'suggest (receivers *application-frame*))))
 
 (define-presentation-method present (o (type receiver) *standard-output* (view textual-view) &key)
-  (format t "~A" (receiver-name o)))
+  (with-drawing-options (t :ink (cond ((> (messages-directed-to-me o) 0) +green+)
+                                      ((> (unseen-messages o) 0) +red+)
+                                      (t +black+)))
+    (format t "~A" (receiver-name o))))
 
 (define-presentation-to-command-translator raise-this-receiver
     (receiver com-raise-receiver beirc