From dmurray at common-lisp.net  Mon Sep 12 18:13:10 2005
From: dmurray at common-lisp.net (Dave Murray)
Date: Mon, 12 Sep 2005 20:13:10 +0200 (CEST)
Subject: [beirc-cvs] CVS update: Module imported: beirc
Message-ID: <20050912181310.D14508855C@common-lisp.net>

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

Log Message:
Initial import into CVS

Status:

Vendor Tag:	dmurray
Release Tags:	start
		
N beirc/beirc.lisp

No conflicts created by this import

Date: Mon Sep 12 20:13:10 2005
Author: dmurray
New module beirc added


From afuchs at common-lisp.net  Tue Sep 13 20:48:12 2005
From: afuchs at common-lisp.net (Andreas Fuchs)
Date: Tue, 13 Sep 2005 22:48:12 +0200 (CEST)
Subject: [beirc-cvs] CVS update: beirc/beirc.lisp 
Message-ID: <20050913204812.BF541880DE@common-lisp.net>

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

Modified Files:
	beirc.lisp 
Log Message:
The multi-channel ("receiver") hack.

This patch comes with a lot of problems. But it's just way too cool to
just leave it out. (-:

problems:

 * on join (you or anybody else), you are thrown into the debugger,
   with a message about a bounding-rectangle method that's not
   applicable to (NIL). Not investigated yet.

 * every time anybody (including you) sends a PRIVMSG, the interactor
   pane is wiped. This is related to the frame-redisplay-panes call in
   the (handle-event frame foo-event) method.

 * Every IRC message that isn't a JOIN, QUIT or PRIVMSG will land you
   in the terminal debugger. feel free to implement more
   receiver-for-message methods.


Date: Tue Sep 13 22:48:12 2005
Author: afuchs

Index: beirc/beirc.lisp
diff -u beirc/beirc.lisp:1.1.1.1 beirc/beirc.lisp:1.2
--- beirc/beirc.lisp:1.1.1.1	Mon Sep 12 20:13:09 2005
+++ beirc/beirc.lisp	Tue Sep 13 22:48:11 2005
@@ -28,6 +28,11 @@
 ;;;  SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
 ;;; 
 
+(cl:eval-when (:compile-toplevel :load-toplevel :execute)
+  (cl:require :split-sequence)
+  (cl:require :cl-irc)
+  (cl:require :mcclim))
+
 (defpackage :beirc
     (:use :clim :clim-lisp :clim-sys)
     (:export #:beirc))
@@ -60,21 +65,130 @@
 ;; <mumble> is just the rest of the input line.
 ;; <nickname> is a nickname of someone, with completion
 
+(defclass receiver ()
+     ((name :reader receiver-name :initarg :name)
+      (messages :accessor messages :initform nil)
+      (channel :reader channel :initform nil :initarg :channel)
+      (query :reader query :initform nil :initarg :query) ;; <- XXX: remove this.
+      (pane :reader pane :initform nil)
+      (focused-nicks :accessor focused-nicks :initform nil)))
+
+(defmethod initialize-instance :after ((object receiver) &rest initargs)
+  (declare (ignore initargs))
+  (setf (slot-value object 'pane)
+        (with-look-and-feel-realization
+            ((frame-manager *application-frame*) *application-frame*)
+          (print (make-clim-application-pane
+                  :display-function
+                  (lambda (frame pane)
+                    (beirc-app-display frame pane object))
+                  :display-time :command-loop
+                  :width 400 :height 600
+                  :incremental-redisplay t) *debug-io*))))
+
+(defun make-receiver (name &rest initargs)
+  (let ((receiver (apply 'make-instance 'receiver :name name initargs)))
+    (setf (gethash name (receivers *application-frame*))
+          receiver)
+    (setf (gethash (pane receiver) (receiver-panes *application-frame*))
+          receiver)
+    receiver))
+
+(defun intern-receiver (name frame &rest initargs)
+  (let ((rec (gethash name (receivers frame))))
+    (if rec
+        rec
+        (let ((*application-frame* frame))
+          (apply 'make-receiver name initargs)))))
+
+(defun receiver-for-pane (pane &optional (frame *application-frame*))
+  (gethash pane (receiver-panes frame)))
+
+
+(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)
+  (let ((target (first (irc:arguments 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.
+  )
+
+;; TODO: more receiver-for-message methods.
+
+(macrolet ((define-delegate (function-name accessor &optional define-setter-p)
+               `(progn
+                  ,(when define-setter-p
+                     `(defun (setf ,function-name) (new-value &optional (frame *application-frame*))
+                        (when (current-receiver frame)
+                          (setf (,accessor (current-receiver frame)) new-value))))
+                  (defun ,function-name (&optional (frame *application-frame*))
+                    (when (current-receiver frame)
+                      (,accessor (current-receiver frame)))))))
+  (define-delegate current-channel channel)
+  (define-delegate current-query query)
+  (define-delegate current-pane pane)
+  (define-delegate current-messages messages t)
+  (define-delegate current-focused-nicks focused-nicks t))
+
+
+
+(defclass stack-layout-pane (clim:sheet-multiple-child-mixin
+                             clim:basic-pane)
+  ())
+
+(defmethod compose-space ((pane stack-layout-pane) &key width height)
+  (declare (ignore width height))
+  (reduce (lambda (x y)
+            (space-requirement-combine #'max x y))
+          (mapcar #'compose-space (sheet-children pane))
+          :initial-value
+          (make-space-requirement :width 0 :min-width 0 :max-width 0
+                                  :height 0 :min-height 0 :max-height 0)))
+
+(defmethod allocate-space ((pane stack-layout-pane) width height)
+  (dolist (child (sheet-children pane))
+    (move-and-resize-sheet child 0 0 width height)
+    (allocate-space child width height)))
+
+(defmethod initialize-instance :after ((pane stack-layout-pane)
+				       &rest args
+				       &key initial-contents
+				       &allow-other-keys)
+  (declare (ignore args))
+  (dolist (k initial-contents)
+    (sheet-adopt-child pane k)))
+
+(defun raise-receiver (receiver &optional (frame *application-frame*))
+  (setf (current-receiver frame) receiver)
+  (mapcar (lambda (pane)
+            (let ((pane-receiver (receiver-for-pane pane frame)))
+              (setf (sheet-enabled-p pane)
+                    (eql receiver pane-receiver))))
+          (sheet-children (find-pane-named frame 'query))))
+
 (define-application-frame beirc ()
-    ((connection :initform nil)
-     (messages :initform nil)
-     (query :initform nil)
+    ((current-receiver :initform nil :accessor current-receiver)
+     (connection :initform nil)
      (nick :initform nil)
-     (channel :initform nil)
-     (focused-nicks :initform nil)
-     (ignored-nicks :initform nil))
+     (ignored-nicks :initform nil)
+     (receivers :initform (make-hash-table :test 'equal) :reader receivers)
+     (receiver-panes :initform (make-hash-table :test 'eql) :reader receiver-panes))
   (:panes
-   (app :application
-    :display-function 'beirc-app-display
-    :display-time :command-loop
-    :incremental-redisplay t)
    (io
     :interactor)
+   (query (make-pane 'stack-layout-pane))
+   (receiver-bar
+    :application
+    :display-function 'beirc-receivers-display
+    :display-time :command-loop
+    :incremental-redisplay t
+    :height 20
+    :scroll-bars nil)
    (status-bar
     :application
     :display-function 'beirc-status-display
@@ -90,8 +204,10 @@
   (:layouts
    (default
        (vertically ()
-         app
+         query
          (60 io)
+         (20
+          receiver-bar)
          (20                            ;<-- Sigh! Bitrot!
           status-bar )))))
 
@@ -99,6 +215,14 @@
 
 (defvar *beirc-frame*)
 
+(defun beirc-receivers-display (*application-frame* *standard-output*)
+  (with-text-family (t :sans-serif)
+    (maphash (lambda (key value)
+               (declare (ignore key))
+               (present value 'receiver :stream *standard-output*)
+               (format t " "))
+             (receivers *application-frame*))))
+
 (defun beirc-status-display (*application-frame* *standard-output*)
   (with-text-family (t :sans-serif)
     (multiple-value-bind (seconds minutes hours) (decode-universal-time (get-universal-time))
@@ -106,14 +230,14 @@
       (format t "~2,'0D:~2,'0D    ~A on ~A~@[ speaking to ~A~]~100T~D messages"
               hours minutes
               (slot-value *application-frame* 'nick)
-              (slot-value *application-frame* 'channel)
-              (slot-value *application-frame* 'query)
-              (length (slot-value *application-frame* 'messages))))))
+              (current-channel)
+              (current-query) 
+              (length (current-messages))))))
 
 (defun beirc-prompt (*standard-output* *application-frame*)
   (format *standard-output* "Beirc ~A => "
-          (or (slot-value *application-frame* 'query)
-              (slot-value *application-frame* 'channel))))
+          (or (current-query)
+              (current-channel))))
 
 ;; (defun format-message (prefix mumble)
 ;;   (write-line
@@ -131,14 +255,14 @@
     (cond (start
 	   (write-string (subseq url 0 start))
 	   (present (concatenate 'string
-				 "file://localhost/path/to/your/HyperSpec/"
+				 "file://localhost/Users/dmurray/lisp/HyperSpec/"
 				 (subseq url (+ 45 start)))
 		    'url))
 	  (t (present url 'url)))))
 
 (defun format-message* (preamble mumble
 			&key (prefix "        ")
-			     (limit 105))
+			     (limit 100))
   (loop for word in (split-sequence:split-sequence #\Space mumble)
 	with line-prefix = prefix
 	with column = (+ (length line-prefix) (length preamble))
@@ -161,7 +285,7 @@
 (define-presentation-type url ()
   :inherit-from 'string)
 
-(defmethod print-message ((message irc:IRC-PRIVMSG-MESSAGE))
+(defmethod print-message ((message irc:IRC-PRIVMSG-MESSAGE) receiver)
   (with-drawing-options
       (*standard-output*
        :ink (if (string-equal "localhost" (irc:host message))
@@ -171,7 +295,7 @@
 		    :test #'string=)
       (with-text-face
 	  (*standard-output*
-	   (if (member (irc:source message) (slot-value *application-frame* 'focused-nicks)
+	   (if (member (irc:source message) (current-focused-nicks)
 		       :test #'string=)
 	       :bold
 	       :roman))
@@ -189,7 +313,7 @@
 			   (format nil "*~A*" (irc:source message)))))))
 	  (format-message* preamble (irc:trailing-argument message)))))))
 
-(defmethod print-message ((message irc:ctcp-action-message))
+(defmethod print-message ((message irc:ctcp-action-message) receiver)
   (let ((source (cl-irc:source message))
         (matter (trailing-argument* message))
         (dest (car (cl-irc:arguments message))))
@@ -198,19 +322,18 @@
 			     source)
 		     matter)))
 
-(defmethod print-message ((message irc:irc-quit-message))
+(defmethod print-message ((message irc:irc-quit-message) receiver)
   (with-drawing-options (*standard-output* :ink +gray33+ :text-size :small)
     (format-message* (format nil "~10T Quit: ~A;"
                             (irc:source message))
                     (irc:trailing-argument message))))
 
-(defmethod print-message ((message irc:irc-join-message))
+(defmethod print-message ((message irc:irc-join-message) receiver)
   (with-drawing-options (*standard-output* :ink +gray33+ :text-size :small)
     (format *standard-output* "~10T Join: ~A (~A@~A)"
             (irc:source message)
             (irc:user message)
-            (irc:host message)
-            (irc:trailing-argument message))
+            (irc:host message))
     (terpri) ))
 
 ;;; Here comes the trick:
@@ -222,7 +345,8 @@
 ;;; we send it to the frame.
 
 (defclass foo-event (clim:window-manager-event)
-  ((sheet :initarg :sheet :reader event-sheet)))
+  ((sheet :initarg :sheet :reader event-sheet)
+   (receiver :initarg :receiver :reader receiver)))
 
 ;;for updating the time display, triggered from TICKER
 (defclass bar-event (clim:window-manager-event)
@@ -244,11 +368,14 @@
 (defmethod handle-event ((frame beirc) (event foo-event))
   ;; Hack:
   ;; Figure out if we are scrolled to the bottom.
-  (let ((pane (get-frame-pane frame 'app)))
+  (let* ((receiver (receiver event))
+         (pane (pane receiver)))    ; FIXME: pane isn't a stream pane, but a VRACK-PANE. gack.
     (let ((btmp (pane-scrolled-to-bottom-p pane)))
-      (time (redisplay-frame-pane frame pane))
-      (when btmp
-        (scroll-pane-to-bottom pane)))
+      (setf (pane-needs-redisplay pane) t)
+      (time (redisplay-frame-panes frame :force-p t))
+;;       (when btmp                       
+;;         (scroll-pane-to-bottom pane))
+      )
     (medium-force-output (sheet-medium pane)) ;###
     ))
 
@@ -273,12 +400,13 @@
                  (run-frame-top-level frame))))))))
 
 (defun post-message (frame message)
-  (setf (slot-value frame 'messages)
-        (append (slot-value frame 'messages) (list message)))
-  (clim-internals::event-queue-prepend
-   (climi::frame-event-queue frame)
-   (make-instance 'foo-event :sheet frame))
-  nil)
+  (let ((receiver (receiver-for-message message frame)))
+    (setf (messages receiver)
+          (append (messages receiver) (list message)))
+    (clim-internals::event-queue-prepend
+     (climi::frame-event-queue frame)
+     (make-instance 'foo-event :sheet frame :receiver receiver))
+    nil))
 
 (defun ticker (frame)
   (loop
@@ -293,13 +421,30 @@
   res)
 
 (define-presentation-method accept ((type nickname) *standard-input* (view textual-view) &key)
-  (with-slots (connection nick channel) *application-frame*
-    (let ((users (mapcar #'car (hash-alist (irc:users (irc:find-channel connection channel))))))
+  (with-slots (connection nick) *application-frame*
+    (let ((users (mapcar #'car (hash-alist (irc:users (irc:find-channel connection (current-channel)))))))
       (accept `(member , at users)
               :prompt nil))))
 
+(define-presentation-method accept ((type receiver) *standard-input* (view textual-view) &key)
+  (completing-from-suggestions (*standard-input* :partial-completers '(#\Space))
+    (maphash #'suggest (receivers *application-frame*))))
+
+(define-presentation-method present (o (type receiver) *standard-output* (view textual-view) &key)
+  (format t "~A" (receiver-name o)))
+
+(define-presentation-to-command-translator raise-this-receiver
+    (receiver com-raise-receiver beirc
+              :gesture :select
+              :documentation "Raise this receiver")
+    (presentation)
+  (list (presentation-object presentation)))
+
+(define-beirc-command (com-raise-receiver :name t) ((receiver 'receiver :prompt "Receiver"))
+  (raise-receiver receiver))
+
 (define-beirc-command (com-focus :name t) ((who 'nickname :prompt "who"))
-  (pushnew who (slot-value *application-frame* 'focused-nicks) :test #'string=))
+  (pushnew who (current-focused-nicks) :test #'string=))
 
 (define-beirc-command (com-ignore :name t) ((who 'nickname :prompt "who"))
   (pushnew who (slot-value *application-frame* 'ignored-nicks) :test #'string=))
@@ -309,12 +454,12 @@
         (remove who (slot-value *application-frame* 'ignored-nicks)  :test #'string=)))
 
 (define-beirc-command (com-unfocus :name t) ((who 'nickname :prompt "who"))
-  (setf (slot-value *application-frame* 'focused-nicks)
-        (remove who (slot-value *application-frame* 'focused-nicks)  :test #'string=)))
+  (setf (current-focused-nicks)
+        (remove who (current-focused-nicks) :test #'string=)))
 
 (defun target (&optional (*application-frame* *application-frame*))
-  (or (slot-value *application-frame* 'query)
-      (slot-value *application-frame* 'channel)))
+  (or (current-query)
+      (current-channel)))
 
 (define-beirc-command (com-say :name t) ((what 'mumble))
   ;; make a fake IRC-PRIV-MESSAGE object
@@ -347,11 +492,11 @@
   (list (presentation-object presentation)))
 
 (define-beirc-command (com-join :name t) ((channel 'string :prompt "channel"))
-  (when (slot-value *application-frame* 'channel)
-    (irc:part
-     (slot-value *application-frame* 'connection)
-     (slot-value *application-frame* 'channel)))
-  (setf (slot-value *application-frame* 'channel) channel)
+  (setf (current-receiver *application-frame*)
+        (intern-receiver channel *application-frame* :channel channel))
+  (sheet-adopt-child (find-pane-named *application-frame* 'query)
+                     (pane (current-receiver *application-frame*)))
+  (raise-receiver (current-receiver *application-frame*))
   (irc:join (slot-value *application-frame* 'connection) channel))
 
 (define-beirc-command (com-connect :name t)
@@ -381,12 +526,12 @@
     (window-clear stream)))
 
 (defun restart-beirc ()
-  (let ((m (slot-value *beirc-frame* 'messages)))
+  (let ((m (current-messages)))
     (clim-sys:destroy-process *gui-process*)
     (setf *beirc-frame* nil)
     (beirc)
     (clim-sys:process-wait "waiting for beirc" (lambda () *beirc-frame*))
-    (setf (slot-value *beirc-frame* 'messages) m)))
+    (setf (current-messages) m)))
 
 
 ;;;;;;;;;
@@ -436,36 +581,37 @@
          (irc:read-message-loop connection) )
     (irc:remove-all-hooks connection)))
 
-(defun beirc-app-display (*application-frame* *standard-output*)
+(defun beirc-app-display (*application-frame* *standard-output* receiver)
   ;; Fix me: This usage of UPDATING-OUTPUT is sub-optimal and ugly!
+  ;; Fix me: as is all that *standard-output* stuff
+  (print *standard-output* *debug-io*)
+  (print (pane receiver) *debug-io*)
   (let ((w (- (floor (bounding-rectangle-width (sheet-parent *standard-output*))
                      (clim:stream-string-width *standard-output* "X"))
-              2)))
-    (with-slots (messages) *application-frame*
-      (let ((k 100)
-            (n (length messages)))
-        (loop for i below (* k (ceiling n k)) by k do
+              2)) 
+        (messages (and receiver (messages receiver))))
+    (let ((k 100)
+          (n (length messages)))
+      (loop for i below (* k (ceiling n k)) by k do
+        (updating-output (*standard-output*
+                          :unique-id i
+                          :cache-value
+                          (list (min n (+ i k))
+                                (focused-nicks receiver)
+                                (slot-value *application-frame* 'ignored-nicks)
+                                w)
+                          :cache-test #'equal)
+          (loop for j from i below (min n (+ i k)) do
+            (let ((m (elt messages j)))
               (updating-output (*standard-output*
-                                :unique-id i
+                                :unique-id j
                                 :cache-value
-				(list (min n (+ i k))
-				      (slot-value *application-frame* 'focused-nicks)
-				      (slot-value *application-frame* 'ignored-nicks)
-				      w)
-                                :cache-test #'equal
-                                )
-                (loop for j from i below (min n (+ i k)) do
-                      (let ((m (elt messages j)))
-                        (updating-output (*standard-output*
-                                          :unique-id j
-                                          :cache-value
-					  (list m
-						(slot-value *application-frame* 'focused-nicks)
-						(slot-value *application-frame* 'ignored-nicks)
-						w)
-                                          :cache-test #'equal
-                                          )
-                          (print-message m))))))))))
+                                (list m
+                                      (focused-nicks receiver)
+                                      (slot-value *application-frame* 'ignored-nicks)
+                                      w)
+                                :cache-test #'equal)
+                (print-message m receiver)))))))))
 ;;; Hack:
 
 (defmethod allocate-space :after ((pane climi::viewport-pane) w h)



From afuchs at common-lisp.net  Wed Sep 14 20:12:43 2005
From: afuchs at common-lisp.net (Andreas Fuchs)
Date: Wed, 14 Sep 2005 22:12:43 +0200 (CEST)
Subject: [beirc-cvs] CVS update: beirc/beirc.lisp 
Message-ID: <20050914201243.B0F908853E@common-lisp.net>

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



From afuchs at common-lisp.net  Wed Sep 14 20:31:46 2005
From: afuchs at common-lisp.net (Andreas Fuchs)
Date: Wed, 14 Sep 2005 22:31:46 +0200 (CEST)
Subject: [beirc-cvs] CVS update: beirc/beirc.asd beirc/package.lisp
	beirc/beirc.lisp 
Message-ID: <20050914203146.1BD1F8853E@common-lisp.net>

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

Modified Files:
	beirc.lisp 
Added Files:
	beirc.asd package.lisp 
Log Message:
add a system definition for beirc and split out the package definition into
package.lisp

Date: Wed Sep 14 22:31:45 2005
Author: afuchs





Index: beirc/beirc.lisp
diff -u beirc/beirc.lisp:1.3 beirc/beirc.lisp:1.4
--- beirc/beirc.lisp:1.3	Wed Sep 14 22:12:40 2005
+++ beirc/beirc.lisp	Wed Sep 14 22:31:44 2005
@@ -28,16 +28,6 @@
 ;;;  SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
 ;;; 
 
-(cl:eval-when (:compile-toplevel :load-toplevel :execute)
-  (cl:require :split-sequence)
-  (cl:require :cl-irc)
-  (cl:require :mcclim)
-  (cl:require :mcclim-freetype))
-
-(defpackage :beirc
-    (:use :clim :clim-lisp :clim-sys)
-    (:export #:beirc))
-
 (in-package :beirc)
 
 ;;;; Quick guide:



From afuchs at common-lisp.net  Wed Sep 14 21:00:41 2005
From: afuchs at common-lisp.net (Andreas Fuchs)
Date: Wed, 14 Sep 2005 23:00:41 +0200 (CEST)
Subject: [beirc-cvs] CVS update: beirc/beirc.lisp 
Message-ID: <20050914210041.D7B8D8853E@common-lisp.net>

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

Modified Files:
	beirc.lisp 
Log Message:
fix the last known issue: redisplay now leaves a good-looking set of panes.

also, remove a lot of debug PRINT statements.

Date: Wed Sep 14 23:00:40 2005
Author: afuchs

Index: beirc/beirc.lisp
diff -u beirc/beirc.lisp:1.4 beirc/beirc.lisp:1.5
--- beirc/beirc.lisp:1.4	Wed Sep 14 22:31:44 2005
+++ beirc/beirc.lisp	Wed Sep 14 23:00:35 2005
@@ -66,18 +66,31 @@
       (pane :reader pane :initform nil)
       (focused-nicks :accessor focused-nicks :initform nil)))
 
+;;; KLUDGE: make-clim-application-pane doesn't return an application
+;;; pane, but a pane that wraps the application pane. we need the
+;;; application pane for redisplay, though.
+(defun actual-application-pane (pane)
+  "Find the actual clim:application-pane buried the layers and
+  layers of wrapping panes that make-clim-application-pane
+  returns."
+  (if (typep pane 'clim:application-pane)
+      pane
+      (loop for child in (sheet-children pane)
+            for found-pane = (actual-application-pane child)
+            if found-pane do (return found-pane))))
+
 (defmethod initialize-instance :after ((object receiver) &rest initargs)
   (declare (ignore initargs))
   (setf (slot-value object 'pane)
         (with-look-and-feel-realization
             ((frame-manager *application-frame*) *application-frame*)
-          (print (make-clim-application-pane
+           (make-clim-application-pane
                   :display-function
                   (lambda (frame pane)
                     (beirc-app-display frame pane object))
                   :display-time :command-loop
                   :width 400 :height 600
-                  :incremental-redisplay t) *debug-io*))))
+                  :incremental-redisplay t))))
 
 (defun make-receiver (name &rest initargs)
   (let ((receiver (apply 'make-instance 'receiver :name name initargs)))
@@ -383,13 +396,12 @@
   ;; Hack:
   ;; Figure out if we are scrolled to the bottom.
   (let* ((receiver (receiver event))
-         (pane (pane receiver)))    ; FIXME: pane isn't a stream pane, but a VRACK-PANE. gack.
+         (pane (actual-application-pane (pane receiver))))
     (let ((btmp (pane-scrolled-to-bottom-p pane)))
       (setf (pane-needs-redisplay pane) t)
-      (time (redisplay-frame-panes frame :force-p t))
-;;       (when btmp                       
-;;         (scroll-pane-to-bottom pane))
-      )
+      (time (redisplay-frame-pane frame pane))
+       (when btmp                       
+         (scroll-pane-to-bottom pane)))
     (medium-force-output (sheet-medium pane)) ;###
     ))
 
@@ -610,8 +622,6 @@
 (defun beirc-app-display (*application-frame* *standard-output* receiver)
   ;; Fix me: This usage of UPDATING-OUTPUT is sub-optimal and ugly!
   ;; Fix me: as is all that *standard-output* stuff
-  (print *standard-output* *debug-io*)
-  (print (pane receiver) *debug-io*)
   (let ((w (- (floor (bounding-rectangle-width (sheet-parent *standard-output*))
                      (clim:stream-string-width *standard-output* "X"))
               2)) 



From afuchs at common-lisp.net  Wed Sep 14 21:24:01 2005
From: afuchs at common-lisp.net (Andreas Fuchs)
Date: Wed, 14 Sep 2005 23:24:01 +0200 (CEST)
Subject: [beirc-cvs] CVS update: beirc/beirc.lisp 
Message-ID: <20050914212401.C7A098853E@common-lisp.net>

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

Modified Files:
	beirc.lisp 
Log Message:
on linux systems, use the binary x-www-browser to open URLs.

This assumes that every linux system runs debian. Umm. Don't they?

Date: Wed Sep 14 23:24:01 2005
Author: afuchs

Index: beirc/beirc.lisp
diff -u beirc/beirc.lisp:1.5 beirc/beirc.lisp:1.6
--- beirc/beirc.lisp:1.5	Wed Sep 14 23:00:35 2005
+++ beirc/beirc.lisp	Wed Sep 14 23:24:00 2005
@@ -400,6 +400,7 @@
     (let ((btmp (pane-scrolled-to-bottom-p pane)))
       (setf (pane-needs-redisplay pane) t)
       (time (redisplay-frame-pane frame pane))
+      (redisplay-frame-pane frame (find-pane-named frame 'receiver-bar))
        (when btmp                       
          (scroll-pane-to-bottom pane)))
     (medium-force-output (sheet-medium pane)) ;###
@@ -522,7 +523,11 @@
   #+ (and sbcl darwin)
   (sb-ext:run-program "/usr/bin/open" `(,url) :wait nil)
   #+ (and openmcl darwin)
-  (ccl:run-program "/usr/bin/open" `(,url) :wait nil))
+  (ccl:run-program "/usr/bin/open" `(,url) :wait nil)
+  ;; XXX: daring assumption. perhaps this should use x-www-browser on
+  ;; debian/debian systems?
+  #+ (and sbcl linux) 
+  (sb-ext:run-program "/usr/bin/x-www-browser" `(,url) :wait nil))
 
 (define-presentation-to-command-translator url-to-browse-url-translator
     (url com-browse-url beirc)



From afuchs at common-lisp.net  Sat Sep 17 16:51:23 2005
From: afuchs at common-lisp.net (Andreas Fuchs)
Date: Sat, 17 Sep 2005 18:51:23 +0200 (CEST)
Subject: [beirc-cvs] CVS update: beirc/beirc.lisp 
Message-ID: <20050917165123.491C188550@common-lisp.net>

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

Modified Files:
	beirc.lisp 
Log Message:
fix printing of /me messages.

Date: Sat Sep 17 18:51:22 2005
Author: afuchs

Index: beirc/beirc.lisp
diff -u beirc/beirc.lisp:1.6 beirc/beirc.lisp:1.7
--- beirc/beirc.lisp:1.6	Wed Sep 14 23:24:00 2005
+++ beirc/beirc.lisp	Sat Sep 17 18:51:21 2005
@@ -674,7 +674,7 @@
 
 (define-beirc-command (com-me :name t) ((what 'mumble))
   (with-slots (connection nick) *application-frame*
-    (let ((m (make-instance 'irc:irc-privmsg-message
+    (let ((m (make-instance 'irc:ctcp-action-message
                             :received-time (get-universal-time)
                             :connection :local
                             :trailing-argument



From afuchs at common-lisp.net  Sat Sep 17 19:23:16 2005
From: afuchs at common-lisp.net (Andreas Fuchs)
Date: Sat, 17 Sep 2005 21:23:16 +0200 (CEST)
Subject: [beirc-cvs] CVS update: beirc/message-display.lisp beirc/beirc.asd
	beirc/beirc.lisp 
Message-ID: <20050917192316.6CF4388031@common-lisp.net>

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

Modified Files:
	beirc.asd beirc.lisp 
Added Files:
	message-display.lisp 
Log Message:
Factor out displaying of messages to message-display.lisp and add table-formatting.

 * move beirc-app-display and print-message methods into message-display.lisp

 * make print-message methods display messages inside a table to make
   their "interesting part" all start in the same column. (similar to
   XChat's message display or ERC's fill-static behavior)

 * PRESENT nicknames if we can identify them (currently, only by
   irc:source or if it's our own)

 * strip punctuation from URL and nickname presentation (but display
   them anyway)


Date: Sat Sep 17 21:23:14 2005
Author: afuchs



Index: beirc/beirc.asd
diff -u beirc/beirc.asd:1.1 beirc/beirc.asd:1.2
--- beirc/beirc.asd:1.1	Wed Sep 14 22:31:44 2005
+++ beirc/beirc.asd	Sat Sep 17 21:23:14 2005
@@ -8,4 +8,5 @@
 (defsystem :beirc
   :depends-on (:mcclim :cl-irc :split-sequence)
   :components ((:file "package")
-               (:file "beirc" :depends-on ("package"))))
\ No newline at end of file
+               (:file "beirc" :depends-on ("package"))
+               (:file "message-display" :depends-on ("package" "beirc"))))
\ No newline at end of file


Index: beirc/beirc.lisp
diff -u beirc/beirc.lisp:1.7 beirc/beirc.lisp:1.8
--- beirc/beirc.lisp:1.7	Sat Sep 17 18:51:21 2005
+++ beirc/beirc.lisp	Sat Sep 17 21:23:14 2005
@@ -277,91 +277,6 @@
 ;;                             "~:@>")
 ;;            prefix)))
 
-(defun present-url (url)
-  (let ((start (search "http://www.lispworks.com/reference/HyperSpec/" url)))
-    (cond (start
-	   (write-string (subseq url 0 start))
-	   (present (concatenate 'string
-				 "file://localhost/Users/dmurray/lisp/HyperSpec/"
-				 (subseq url (+ 45 start)))
-		    'url))
-	  (t (present url 'url)))))
-
-(defun format-message* (preamble mumble
-			&key (prefix "        ")
-			     (limit 100))
-  (loop for word in (split-sequence:split-sequence #\Space mumble)
-	with line-prefix = prefix
-	with column = (+ (length line-prefix) (length preamble))
-	with column-limit = limit
-	initially (with-drawing-options (*standard-output* :ink +dark-red+)
-		    (write-string preamble))
-	when (> (+ column (length word)) column-limit)
-	  do (terpri)
-	     (write-string line-prefix)
-	     (setf column (length line-prefix))
-	else do (write-char #\Space)
-		(incf column)
-	do 
-     (if (search "http://" word)
-	 (present-url word)
-	 (write-string word))
-     (incf column (length word)))
-  (terpri))
-
-(define-presentation-type url ()
-  :inherit-from 'string)
-
-(defmethod print-message ((message irc:IRC-PRIVMSG-MESSAGE) receiver)
-  (with-drawing-options
-      (*standard-output*
-       :ink (if (string-equal "localhost" (irc:host message))
-		+blue4+
-		+black+))
-    (unless (member (irc:source message) (slot-value *application-frame* 'ignored-nicks)
-		    :test #'string=)
-      (with-text-face
-	  (*standard-output*
-	   (if (member (irc:source message) (current-focused-nicks)
-		       :test #'string=)
-	       :bold
-	       :roman))
-	(format t "~&[~2,'0D:~2,'0D] "
-		(nth-value 2 (decode-universal-time (irc:received-time message)))
-		(nth-value 1 (decode-universal-time (irc:received-time message))))
-	(let  ((preamble
-		(cond ((string-equal "localhost" (irc:host message))
-		       (if (char= (char (first (irc:arguments message)) 0) #\#)
-			   (format nil ">")
-			   (format nil "-> *~A*" (first (irc:arguments message)))))
-		      (t
-		       (if (char= (char (first (irc:arguments message)) 0) #\#)
-			   (format nil "<~A>" (irc:source message))
-			   (format nil "*~A*" (irc:source message)))))))
-	  (format-message* preamble (irc:trailing-argument message)))))))
-
-(defmethod print-message ((message irc:ctcp-action-message) receiver)
-  (let ((source (cl-irc:source message))
-        (matter (trailing-argument* message))
-        (dest (car (cl-irc:arguments message))))
-    (format-message* (format nil "        *~A ~A"
-			     (if (char= (char (first (irc:arguments message)) 0) #\#) "" ">")
-			     source)
-		     matter)))
-
-(defmethod print-message ((message irc:irc-quit-message) receiver)
-  (with-drawing-options (*standard-output* :ink +gray33+ :text-size :small)
-    (format-message* (format nil "~10T Quit: ~A;"
-                            (irc:source message))
-                    (irc:trailing-argument message))))
-
-(defmethod print-message ((message irc:irc-join-message) receiver)
-  (with-drawing-options (*standard-output* :ink +gray33+ :text-size :small)
-    (format *standard-output* "~10T Join: ~A (~A@~A)"
-            (irc:source message)
-            (irc:user message)
-            (irc:host message))
-    (terpri) ))
 
 ;;; Here comes the trick:
 
@@ -466,6 +381,17 @@
   (completing-from-suggestions (*standard-input* :partial-completers '(#\Space))
     (maphash #'suggest (receivers *application-frame*))))
 
+(defun nick-equals-my-nick-p (nickname)
+  (and *application-frame*
+       (string= nickname (slot-value *application-frame* 'nick))))
+
+(define-presentation-method present (o (type nickname) *standard-output* (view textual-view) &key)
+  (if (nick-equals-my-nick-p o)
+      (with-drawing-options (t :ink +green+)
+        (with-text-face (t :bold)
+          (format t "~A" o)))
+      (format t "~A" o)))
+
 (define-presentation-method present (o (type receiver) *standard-output* (view textual-view) &key)
   (with-drawing-options (t :ink (cond ((> (messages-directed-to-me o) 0) +green+)
                                       ((> (unseen-messages o) 0) +red+)
@@ -613,6 +539,10 @@
        (progn
          (irc:add-hook connection 'irc:irc-privmsg-message
                        (lambda (m) (post-message frame m)))
+         (irc:add-hook connection 'irc:irc-nick-message
+                       (lambda (m) (post-message frame m)))
+         (irc:add-hook connection 'irc:irc-part-message
+                       (lambda (m) (post-message frame m)))
          (irc:add-hook connection 'irc:irc-quit-message
                        (lambda (m) (post-message frame m)))
          (irc:add-hook connection 'irc:irc-join-message
@@ -624,35 +554,6 @@
          (irc:read-message-loop connection) )
     (irc:remove-all-hooks connection)))
 
-(defun beirc-app-display (*application-frame* *standard-output* receiver)
-  ;; Fix me: This usage of UPDATING-OUTPUT is sub-optimal and ugly!
-  ;; Fix me: as is all that *standard-output* stuff
-  (let ((w (- (floor (bounding-rectangle-width (sheet-parent *standard-output*))
-                     (clim:stream-string-width *standard-output* "X"))
-              2)) 
-        (messages (and receiver (messages receiver))))
-    (let ((k 100)
-          (n (length messages)))
-      (loop for i below (* k (ceiling n k)) by k do
-        (updating-output (*standard-output*
-                          :unique-id i
-                          :cache-value
-                          (list (min n (+ i k))
-                                (focused-nicks receiver)
-                                (slot-value *application-frame* 'ignored-nicks)
-                                w)
-                          :cache-test #'equal)
-          (loop for j from i below (min n (+ i k)) do
-            (let ((m (elt messages j)))
-              (updating-output (*standard-output*
-                                :unique-id j
-                                :cache-value
-                                (list m
-                                      (focused-nicks receiver)
-                                      (slot-value *application-frame* 'ignored-nicks)
-                                      w)
-                                :cache-test #'equal)
-                (print-message m receiver)))))))))
 ;;; Hack:
 
 (defmethod allocate-space :after ((pane climi::viewport-pane) w h)



From afuchs at common-lisp.net  Sat Sep 17 20:41:43 2005
From: afuchs at common-lisp.net (Andreas Fuchs)
Date: Sat, 17 Sep 2005 22:41:43 +0200 (CEST)
Subject: [beirc-cvs] CVS update: beirc/beirc.lisp 
Message-ID: <20050917204143.A153788031@common-lisp.net>

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

Modified Files:
	beirc.lisp 
Log Message:
add a KLUDGE-y workaround for mcclim bug "Application pane vertical
scrolling does not work with table formatting" (from Tim Moore)


Date: Sat Sep 17 22:41:43 2005
Author: afuchs

Index: beirc/beirc.lisp
diff -u beirc/beirc.lisp:1.8 beirc/beirc.lisp:1.9
--- beirc/beirc.lisp:1.8	Sat Sep 17 21:23:14 2005
+++ beirc/beirc.lisp	Sat Sep 17 22:41:42 2005
@@ -198,7 +198,20 @@
                     (eql receiver pane-receiver))))
           (sheet-children (find-pane-named frame 'query))))
 
-(define-application-frame beirc ()
+;;; KLUDGE: workaround for mcclim bug "Application pane vertical
+;;; scrolling does not work with table formatting"
+
+(defclass redisplay-frame-mixin ()
+   ())
+
+(defmethod redisplay-frame-pane :after
+    ((frame redisplay-frame-mixin) (pane application-pane) &key force-p)
+  (declare (ignore force-p))
+  (change-space-requirements
+   pane :height (bounding-rectangle-height (stream-output-history pane))))
+
+(define-application-frame beirc (redisplay-frame-mixin
+                                 standard-application-frame)
     ((current-receiver :initform nil :accessor current-receiver)
      (connection :initform nil)
      (nick :initform nil)



From afuchs at common-lisp.net  Sat Sep 17 21:28:30 2005
From: afuchs at common-lisp.net (Andreas Fuchs)
Date: Sat, 17 Sep 2005 23:28:30 +0200 (CEST)
Subject: [beirc-cvs] CVS update: beirc/beirc.lisp 
Message-ID: <20050917212830.A304188550@common-lisp.net>

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

Modified Files:
	beirc.lisp 
Log Message:
Refactor the receiver-for-message definitions and fix incoming PRIVMSGs to us.

Date: Sat Sep 17 23:28:30 2005
Author: afuchs

Index: beirc/beirc.lisp
diff -u beirc/beirc.lisp:1.9 beirc/beirc.lisp:1.10
--- beirc/beirc.lisp:1.9	Sat Sep 17 22:41:42 2005
+++ beirc/beirc.lisp	Sat Sep 17 23:28:29 2005
@@ -101,49 +101,52 @@
     receiver))
 
 (defun intern-receiver (name frame &rest initargs)
-  (let ((rec (gethash name (receivers frame))))
+  (let ((rec (gethash (irc:normalize-channel-name (slot-value frame 'connection)
+                                                  name) (receivers frame))))
     (if rec
         rec
         (let ((*application-frame* frame))
-          (apply 'make-receiver name initargs)))))
+          (let ((receiver (apply 'make-receiver name initargs)))
+            (setf (sheet-enabled-p (pane receiver)) nil)
+            (sheet-adopt-child (find-pane-named *application-frame* 'query)
+                               (pane receiver))
+            receiver)))))
 
 (defun receiver-for-pane (pane &optional (frame *application-frame*))
   (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: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)))
+(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)))))
+  (define-privmsg-receiver-lookup irc:irc-privmsg-message)
+  (define-privmsg-receiver-lookup irc:ctcp-action-message)
+  (define-privmsg-receiver-lookup irc:irc-notice-message))
+
+(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))))
+ (define-global-message-receiver-lookup irc:irc-quit-message)
+ (define-global-message-receiver-lookup irc:irc-nick-message))
 
 (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.
 
+
 (macrolet ((define-delegate (function-name accessor &optional define-setter-p)
                `(progn
                   ,(when define-setter-p
@@ -476,8 +479,6 @@
 (define-beirc-command (com-join :name t) ((channel 'string :prompt "channel"))
   (setf (current-receiver *application-frame*)
         (intern-receiver channel *application-frame* :channel channel))
-  (sheet-adopt-child (find-pane-named *application-frame* 'query)
-                     (pane (current-receiver *application-frame*)))
   (raise-receiver (current-receiver *application-frame*))
   (irc:join (slot-value *application-frame* 'connection) channel))
 



From afuchs at common-lisp.net  Sat Sep 17 22:23:00 2005
From: afuchs at common-lisp.net (Andreas Fuchs)
Date: Sun, 18 Sep 2005 00:23:00 +0200 (CEST)
Subject: [beirc-cvs] CVS update: beirc/beirc.lisp beirc/message-display.lisp
Message-ID: <20050917222300.EA34588031@common-lisp.net>

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

Modified Files:
	beirc.lisp message-display.lisp 
Log Message:
add more general nickname highlighting and use current-connection consistently

Date: Sun Sep 18 00:22:58 2005
Author: afuchs

Index: beirc/beirc.lisp
diff -u beirc/beirc.lisp:1.10 beirc/beirc.lisp:1.11
--- beirc/beirc.lisp:1.10	Sat Sep 17 23:28:29 2005
+++ beirc/beirc.lisp	Sun Sep 18 00:22:57 2005
@@ -162,8 +162,6 @@
   (define-delegate current-messages messages t)
   (define-delegate current-focused-nicks focused-nicks t))
 
-
-
 (defclass stack-layout-pane (clim:sheet-multiple-child-mixin
                              clim:basic-pane)
   ())
@@ -216,7 +214,7 @@
 (define-application-frame beirc (redisplay-frame-mixin
                                  standard-application-frame)
     ((current-receiver :initform nil :accessor current-receiver)
-     (connection :initform nil)
+     (connection :initform nil :reader current-connection)
      (nick :initform nil)
      (ignored-nicks :initform nil)
      (receivers :initform (make-hash-table :test 'equal) :reader receivers)
@@ -315,8 +313,11 @@
 (defun pane-scrolled-to-bottom-p (pane)
   (multiple-value-bind (x y) (transform-position (sheet-transformation pane)
                                                  0 0)
+    (declare (ignore x))
     (with-bounding-rectangle* (x1 y1 x2 y2) pane
+      (declare (ignore x1 y1 x2))
       (with-bounding-rectangle* (ax1 ay1 ax2 ay2) (sheet-parent pane)
+        (declare (ignore ax1 ay1 ax2))
         (<= (+ y y2) ay2)))))
 
 (defun scroll-pane-to-bottom (pane)
@@ -455,11 +456,11 @@
                                :USER "localuser"
                                :SOURCE (slot-value *application-frame* 'nick)
                                ))
-  (irc:privmsg (slot-value *application-frame* 'connection) (target) what))
+  (irc:privmsg (current-connection *application-frame*) (target) what))
 
 (define-beirc-command (com-nick :name t) ((new-nick 'string :prompt "new nick"))
   (setf (slot-value *application-frame* 'nick) new-nick) ;This is _not_ the way to do it.
-  (irc:nick (slot-value *application-frame* 'connection) new-nick))
+  (irc:nick (current-connection *application-frame*) new-nick))
 
 (define-beirc-command (com-browse-url :name t) ((url 'url :prompt "url"))
   #+ (and sbcl darwin)
@@ -480,17 +481,17 @@
   (setf (current-receiver *application-frame*)
         (intern-receiver channel *application-frame* :channel channel))
   (raise-receiver (current-receiver *application-frame*))
-  (irc:join (slot-value *application-frame* 'connection) channel))
+  (irc:join (current-connection *application-frame*) channel))
 
 (define-beirc-command (com-connect :name t)
     ((server 'string :prompt "Server") (nick 'string :prompt "Nick name"))
-  (cond ((slot-value *application-frame* 'connection)
+  (cond ((current-connection *application-frame*)
          (format *query-io* "You are already connected.~%"))
         (t
          (setf (slot-value *application-frame* 'connection)
 	       (irc:connect :nickname nick :server server))
          (setf (slot-value *application-frame* 'nick) nick)
-         (let ((connection (slot-value *application-frame* 'connection)))
+         (let ((connection (current-connection *application-frame*)))
            (let ((frame *application-frame*))
              (clim-sys:make-process #'(lambda ()
                                         (irc-event-loop frame connection))
@@ -523,7 +524,7 @@
 ;  (describe message *trace-output*)
 ;  (finish-output *trace-output*)
   ;; ###
-  (irc:pong (slot-value *application-frame* 'connection) "localhost")
+  (irc:pong (current-connection *application-frame*) "localhost")
   nil)  ;### put the server you initially connected to here.
 
 (defmethod trailing-argument* (message)
@@ -614,7 +615,7 @@
                                :HOST "localhost"
                                :USER "localuser"
                                :SOURCE (slot-value *application-frame* 'nick) ))
-  (irc:privmsg (slot-value *application-frame* 'connection) target what))
+  (irc:privmsg (current-connection *application-frame*) target what))
 
 (define-beirc-command (com-msg :name t)
     ((target 'nickname :prompt "who") (what 'mumble :prompt "what"))


Index: beirc/message-display.lisp
diff -u beirc/message-display.lisp:1.1 beirc/message-display.lisp:1.2
--- beirc/message-display.lisp:1.1	Sat Sep 17 21:23:14 2005
+++ beirc/message-display.lisp	Sun Sep 18 00:22:57 2005
@@ -75,7 +75,7 @@
                (cond
                  ((search "http://" word*)
                   (present-url word*))
-                 ((nick-equals-my-nick-p word*)
+                 ((irc:find-user (current-connection *application-frame*) word*)
                   (present word* 'nickname))
                  (t (write-string word*)))
                (write-string stripped-punctuation))



From afuchs at common-lisp.net  Sat Sep 17 22:34:04 2005
From: afuchs at common-lisp.net (Andreas Fuchs)
Date: Sun, 18 Sep 2005 00:34:04 +0200 (CEST)
Subject: [beirc-cvs] CVS update: beirc/beirc.lisp beirc/message-display.lisp
Message-ID: <20050917223404.267BD88031@common-lisp.net>

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

Modified Files:
	beirc.lisp message-display.lisp 
Log Message:
fix highlighting of yor own nickname (which broke in the last checkin).

Date: Sun Sep 18 00:34:02 2005
Author: afuchs

Index: beirc/beirc.lisp
diff -u beirc/beirc.lisp:1.11 beirc/beirc.lisp:1.12
--- beirc/beirc.lisp:1.11	Sun Sep 18 00:22:57 2005
+++ beirc/beirc.lisp	Sun Sep 18 00:34:00 2005
@@ -400,7 +400,10 @@
 
 (defun nick-equals-my-nick-p (nickname)
   (and *application-frame*
-       (string= nickname (slot-value *application-frame* 'nick))))
+       (equal (irc:normalize-nickname (current-connection *application-frame*)
+                                      (slot-value *application-frame* 'nick))
+              (irc:normalize-nickname (current-connection *application-frame*)
+                                      nickname))))
 
 (define-presentation-method present (o (type nickname) *standard-output* (view textual-view) &key)
   (if (nick-equals-my-nick-p o)


Index: beirc/message-display.lisp
diff -u beirc/message-display.lisp:1.2 beirc/message-display.lisp:1.3
--- beirc/message-display.lisp:1.2	Sun Sep 18 00:22:57 2005
+++ beirc/message-display.lisp	Sun Sep 18 00:34:00 2005
@@ -75,7 +75,9 @@
                (cond
                  ((search "http://" word*)
                   (present-url word*))
-                 ((irc:find-user (current-connection *application-frame*) word*)
+                 ((or
+                   (nick-equals-my-nick-p word*)
+                   (irc:find-user (current-connection *application-frame*) word*))
                   (present word* 'nickname))
                  (t (write-string word*)))
                (write-string stripped-punctuation))



From dmurray at common-lisp.net  Fri Sep 23 09:52:42 2005
From: dmurray at common-lisp.net (Dave Murray)
Date: Fri, 23 Sep 2005 11:52:42 +0200 (CEST)
Subject: [beirc-cvs] CVS update: beirc/message-display.lisp beirc/beirc.lisp
Message-ID: <20050923095242.714AB880DE@common-lisp.net>

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

Modified Files:
	message-display.lisp beirc.lisp 
Log Message:
Switched time-stamps to right-hand column. Better wrapping of message column.

Date: Fri Sep 23 11:52:41 2005
Author: dmurray

Index: beirc/message-display.lisp
diff -u beirc/message-display.lisp:1.3 beirc/message-display.lisp:1.4
--- beirc/message-display.lisp:1.3	Sun Sep 18 00:34:00 2005
+++ beirc/message-display.lisp	Fri Sep 23 11:52:40 2005
@@ -1,7 +1,7 @@
 (in-package :beirc)
 
 (defparameter *hyperspec-base-url* "file://localhost/Users/dmurray/lisp/HyperSpec/")
-(defparameter *default-fill-column* 100)
+(defparameter *default-fill-column* 80)
 
 (defvar *max-preamble-length* 0)
 
@@ -16,6 +16,15 @@
 				 *hyperspec-base-url*
 				 (subseq url (+ 45 start)))
 		    'url))
+	  ((> (length url) *default-fill-column*)
+	   (let ((new-url
+		  (concatenate 'string
+			       (subseq url 0 (floor *default-fill-column* 2))
+			       "..."
+			       (subseq url (- (length url)
+					      (- (floor *default-fill-column* 2) 3))))))
+	     (with-output-as-presentation (t url 'url)
+	       (write-string new-url))))
 	  (t (present url 'url)))))
 
 (defun message-from-focused-nick-p (message receiver)
@@ -47,48 +56,49 @@
                                *max-preamble-length*)
                          :cache-test #'equal)
          (formatting-row (,stream*)
-           (formatting-cell (,stream* :align-x :left)
-             (format ,stream* "~&[~2,'0D:~2,'0D] "
-                     (nth-value 2 (decode-universal-time (irc:received-time message)))
-                     (nth-value 1 (decode-universal-time (irc:received-time message)))))
-           (formatting-cell (,stream* :align-x :right)
-             (with-drawing-options (*standard-output* :ink +dark-red+)
+           (formatting-cell (,stream* :align-x :right :min-width '(16 :character))
+             (with-drawing-options (,stream* :ink +dark-red+)
                , at preamble-column-body))
-           (formatting-cell (,stream* :align-x :left)
-             , at message-body-column-body))))))
+           (formatting-cell (,stream* :align-x :left
+				      :min-width '(80 :character))
+             , at message-body-column-body)
+	   (formatting-cell (,stream* :align-x :left)
+             (with-drawing-options (,stream* :ink +gray+)
+	       (format ,stream* "[~2,'0D:~2,'0D]"
+		       (nth-value 2 (decode-universal-time (irc:received-time message)))
+		       (nth-value 1 (decode-universal-time (irc:received-time message)))))))))))
 
 (defun strip-punctuation (word)
   (if (= (length word) 0)
       (values word "")
       (let ((last-char (char word (1- (length word)))))
        (case last-char
-         ((#\: #\, #\. #\;)
+         ((#\: #\, #\. #\; #\) #\] #\} #\> #\? #\! #\" #\')
           (values (subseq word 0 (1- (length word)))
                   (string last-char)))
          (otherwise (values word ""))))))
 
-(defun format-message* (mumble &key (limit *default-fill-column*))
+(defun format-message* (mumble &key (limit *default-fill-column*) (start-length 0))
   (loop for (word . rest) on (split-sequence:split-sequence #\Space mumble)
-          with column = 0
-          with column-limit = limit
-          do (multiple-value-bind (word* stripped-punctuation) (strip-punctuation word)
-               (cond
-                 ((search "http://" word*)
-                  (present-url word*))
-                 ((or
-                   (nick-equals-my-nick-p word*)
-                   (irc:find-user (current-connection *application-frame*) word*))
-                  (present word* 'nickname))
-                 (t (write-string word*)))
-               (write-string stripped-punctuation))
-             ;; TODO: nick highlighting via presentations
-             (incf column (length word))
-          when (> column column-limit)
-            do (setf column 0)
-               (terpri)
-          else unless (null rest)
-                 do  (write-char #\Space)
-                     (incf column))
+	with column = start-length
+	do (incf column (length word))
+	when (> column limit)
+	  do (setf column (length word))
+	     (terpri)
+	do (multiple-value-bind (word* stripped-punctuation) (strip-punctuation word)
+	     (cond
+	       ((search "http://" word*)
+		(present-url word*))
+	       ((or
+		 (nick-equals-my-nick-p word*)
+		 (irc:find-user (current-connection *application-frame*) word*))
+		(present word* 'nickname))
+	       (t (write-string word*)))
+	     (write-string stripped-punctuation))
+	   ;; TODO: more highlighting
+	unless (or (null rest) (>= column limit))
+	  do  (write-char #\Space)
+	      (incf column))
   (terpri))
 
 (defmethod print-message ((message irc:IRC-PRIVMSG-MESSAGE) receiver)
@@ -114,20 +124,21 @@
           ((format t "*"))
           ((present source 'nickname)
            (format t " ")
-           (format-message* matter)))))
+           (format-message* matter :start-length (+ 2 (length source)))))))
 
 (defmethod print-message ((message irc:irc-quit-message) receiver)
   (formatting-message (t message receiver)
-          ((format t "***"))
+          ((format t "   "))
           ((with-drawing-options (*standard-output* :ink +gray33+ :text-size :small)
              (format t "Quit: ")
              (present (irc:source message) 'nickname)
              (format t ": ")
-             (format-message* (irc:trailing-argument message))))))
+             (format-message* (irc:trailing-argument message)
+			      :start-length (+ 8 (length (irc:source message))))))))
 
 (defmethod print-message ((message irc:irc-join-message) receiver)
   (formatting-message (t message receiver)
-          ((format t "***"))
+          ((format t "   "))
           ((with-drawing-options (*standard-output* :ink +gray33+ :text-size :small)
              (format t "Join: ")
              (present (irc:source message) 'nickname)
@@ -135,7 +146,7 @@
 
 (defmethod print-message ((message irc:irc-nick-message) receiver)
   (formatting-message (t message receiver)
-          ((format t "***"))
+          ((format t "   "))
           ((with-drawing-options (*standard-output* :ink +gray33+ :text-size :small)
              (format t "Nick change: ")
              (present (irc:source message) 'nickname)
@@ -144,7 +155,7 @@
 
 (defmethod print-message ((message irc:irc-part-message) receiver)
   (formatting-message (t message receiver)
-          ((format t "***"))
+          ((format t "   "))
           ((with-drawing-options (*standard-output* :ink +gray33+ :text-size :small)
              (format t "Part: ")
              (present (irc:source message) 'nickname)


Index: beirc/beirc.lisp
diff -u beirc/beirc.lisp:1.12 beirc/beirc.lisp:1.13
--- beirc/beirc.lisp:1.12	Sun Sep 18 00:34:00 2005
+++ beirc/beirc.lisp	Fri Sep 23 11:52:40 2005
@@ -407,7 +407,7 @@
 
 (define-presentation-method present (o (type nickname) *standard-output* (view textual-view) &key)
   (if (nick-equals-my-nick-p o)
-      (with-drawing-options (t :ink +green+)
+      (with-drawing-options (t :ink +darkgreen+)
         (with-text-face (t :bold)
           (format t "~A" o)))
       (format t "~A" o)))



From afuchs at common-lisp.net  Fri Sep 23 19:05:17 2005
From: afuchs at common-lisp.net (Andreas Fuchs)
Date: Fri, 23 Sep 2005 21:05:17 +0200 (CEST)
Subject: [beirc-cvs] CVS update: beirc/beirc.asd beirc/beirc.lisp
	beirc/package.lisp 
Message-ID: <20050923190517.7796D880DB@common-lisp.net>

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

Modified Files:
	beirc.asd beirc.lisp package.lisp 
Log Message:
Integrate Max-Gerd Retzlaff's tab-layout extension.

Also, add a few p-to-command-translators for nicknames (focus, query, ignore)


Date: Fri Sep 23 21:05:16 2005
Author: afuchs

Index: beirc/beirc.asd
diff -u beirc/beirc.asd:1.2 beirc/beirc.asd:1.3
--- beirc/beirc.asd:1.2	Sat Sep 17 21:23:14 2005
+++ beirc/beirc.asd	Fri Sep 23 21:05:15 2005
@@ -6,7 +6,7 @@
 (cl:in-package :beirc.system)
 
 (defsystem :beirc
-  :depends-on (:mcclim :cl-irc :split-sequence)
+  :depends-on (:mcclim :cl-irc :split-sequence :tab-layout)
   :components ((:file "package")
                (:file "beirc" :depends-on ("package"))
                (:file "message-display" :depends-on ("package" "beirc"))))


Index: beirc/beirc.lisp
diff -u beirc/beirc.lisp:1.13 beirc/beirc.lisp:1.14
--- beirc/beirc.lisp:1.13	Fri Sep 23 11:52:40 2005
+++ beirc/beirc.lisp	Fri Sep 23 21:05:15 2005
@@ -57,14 +57,15 @@
 ;; <nickname> is a nickname of someone, with completion
 
 (defclass receiver ()
-     ((name :reader receiver-name :initarg :name)
-      (messages :accessor messages :initform nil)
+     ((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)
-      (focused-nicks :accessor focused-nicks :initform nil)))
+      (focused-nicks :accessor focused-nicks :initform nil)
+      (title :reader title :initarg :title)
+      (pane :reader pane)
+      (tab-pane :accessor tab-pane)))
 
 ;;; KLUDGE: make-clim-application-pane doesn't return an application
 ;;; pane, but a pane that wraps the application pane. we need the
@@ -88,33 +89,27 @@
                   :display-function
                   (lambda (frame pane)
                     (beirc-app-display frame pane object))
-                  :display-time :command-loop
+                  :display-time nil
                   :width 400 :height 600
-                  :incremental-redisplay t))))
+                  :incremental-redisplay t)))
+  (setf (slot-value object 'tab-pane)
+        (make-tab-pane-from-list (title object) (pane object) 'receiver)))
 
 (defun make-receiver (name &rest initargs)
-  (let ((receiver (apply 'make-instance 'receiver :name name initargs)))
-    (setf (gethash name (receivers *application-frame*))
-          receiver)
-    (setf (gethash (pane receiver) (receiver-panes *application-frame*))
-          receiver)
+  (let ((receiver (apply 'make-instance 'receiver :title name initargs)))
     receiver))
 
 (defun intern-receiver (name frame &rest initargs)
-  (let ((rec (gethash (irc:normalize-channel-name (slot-value frame 'connection)
-                                                  name) (receivers frame))))
+  (let ((rec (gethash name (receivers frame))))
     (if rec
         rec
         (let ((*application-frame* frame))
           (let ((receiver (apply 'make-receiver name initargs)))
-            (setf (sheet-enabled-p (pane receiver)) nil)
-            (sheet-adopt-child (find-pane-named *application-frame* 'query)
-                               (pane receiver))
+            (add-pane (tab-pane receiver) (find-pane-named frame 'query))
+            (setf (gethash name (receivers frame)) receiver)
+            (setf (gethash (tab-pane receiver) (tab-panes-to-receivers frame)) receiver)
             receiver)))))
 
-(defun receiver-for-pane (pane &optional (frame *application-frame*))
-  (gethash pane (receiver-panes frame)))
-
 (macrolet ((define-privmsg-receiver-lookup (message-type)
                `(defmethod receiver-for-message ((message ,message-type) frame)
                   (let* ((mynick (irc:normalize-nickname (slot-value frame 'connection)
@@ -146,7 +141,6 @@
     (intern-receiver target frame :channel target)))
 ;; TODO: more receiver-for-message methods.
 
-
 (macrolet ((define-delegate (function-name accessor &optional define-setter-p)
                `(progn
                   ,(when define-setter-p
@@ -158,46 +152,29 @@
                       (,accessor (current-receiver frame)))))))
   (define-delegate current-channel channel)
   (define-delegate current-query query)
-  (define-delegate current-pane pane)
   (define-delegate current-messages messages t)
   (define-delegate current-focused-nicks focused-nicks t))
 
-(defclass stack-layout-pane (clim:sheet-multiple-child-mixin
-                             clim:basic-pane)
-  ())
-
-(defmethod compose-space ((pane stack-layout-pane) &key width height)
-  (declare (ignore width height))
-  (reduce (lambda (x y)
-            (space-requirement-combine #'max x y))
-          (mapcar #'compose-space (sheet-children pane))
-          :initial-value
-          (make-space-requirement :width 0 :min-width 0 :max-width 0
-                                  :height 0 :min-height 0 :max-height 0)))
-
-(defmethod allocate-space ((pane stack-layout-pane) width height)
-  (dolist (child (sheet-children pane))
-    (move-and-resize-sheet child 0 0 width height)
-    (allocate-space child width height)))
-
-(defmethod initialize-instance :after ((pane stack-layout-pane)
-				       &rest args
-				       &key initial-contents
-				       &allow-other-keys)
-  (declare (ignore args))
-  (dolist (k (or initial-contents
-                 (list (make-clim-application-pane))))
-    (sheet-adopt-child pane k)))
+(defun update-drawing-options (receiver)
+  (set-drawing-options-for-pane-in-tab-layout (pane receiver)
+                                              `(:ink ,(cond ((> (messages-directed-to-me receiver) 0) +green+)
+                                                            ((> (unseen-messages receiver) 0) +red+)
+                                                            (t +black+)))))
+
+(defmethod switch-to-pane :after ((pane sheet) (parent (eql 'tab-layout-pane)))
+  (let ((receiver (receiver-from-tab-pane
+                   (find-in-tab-panes-list pane
+                                           (find-pane-named *application-frame* 'query)))))
+    (unless (null receiver)
+      (setf (unseen-messages receiver) 0)
+      (setf (messages-directed-to-me receiver) 0)
+      (update-drawing-options receiver))))
+
 
-(defun raise-receiver (receiver &optional (frame *application-frame*))
-  (setf (current-receiver frame) receiver)
+(defun raise-receiver (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)
-                    (eql receiver pane-receiver))))
-          (sheet-children (find-pane-named frame 'query))))
+  (switch-to-pane (pane receiver) 'tab-layout-pane))
 
 ;;; KLUDGE: workaround for mcclim bug "Application pane vertical
 ;;; scrolling does not work with table formatting"
@@ -213,23 +190,14 @@
 
 (define-application-frame beirc (redisplay-frame-mixin
                                  standard-application-frame)
-    ((current-receiver :initform nil :accessor current-receiver)
-     (connection :initform nil :reader current-connection)
+    ((connection :initform nil :reader current-connection)
      (nick :initform nil)
      (ignored-nicks :initform nil)
-     (receivers :initform (make-hash-table :test 'equal) :reader receivers)
-     (receiver-panes :initform (make-hash-table :test 'eql) :reader receiver-panes))
+     (receivers :initform (make-hash-table :test #'equal) :accessor receivers)
+     (tab-panes-to-receivers :initform (make-hash-table :test #'equal) :accessor tab-panes-to-receivers))
   (:panes
    (io
     :interactor)
-   (query (make-pane 'stack-layout-pane))
-   (receiver-bar
-    :application
-    :display-function 'beirc-receivers-display
-    :display-time :command-loop
-    :incremental-redisplay t
-    :height 20
-    :scroll-bars nil)
    (status-bar
     :application
     :display-function 'beirc-status-display
@@ -239,31 +207,36 @@
     :height 20
     :scroll-bars nil
     :background +black+
-    :foreground +white+) )
+    :foreground +white+)
+   (server
+    :application
+    ;; TODO: server message display.
+    ))
   (:geometry :width 800 :height 600)
   (:top-level (clim:default-frame-top-level :prompt 'beirc-prompt))
   (:layouts
    (default
        (vertically ()
-         query
+         (with-tab-layout ('receiver :name 'query)
+           ("Server" server))
          (60 io)
-         (20
-          receiver-bar)
          (20                            ;<-- Sigh! Bitrot!
           status-bar )))))
 
+(defun receiver-from-tab-pane (tab-pane)
+  (gethash tab-pane
+           (tab-panes-to-receivers *application-frame*)))
+
+(defmethod current-receiver ((frame beirc))
+  (let ((receiver (receiver-from-tab-pane (enabled-pane (find-pane-named frame 'query)))))
+    (if (typep receiver 'receiver)
+        receiver
+        nil)))
+
 (defvar *gui-process* nil)
 
 (defvar *beirc-frame*)
 
-(defun beirc-receivers-display (*application-frame* *standard-output*)
-  (with-text-family (t :sans-serif)
-    (maphash (lambda (key value)
-               (declare (ignore key))
-               (present value 'receiver :stream *standard-output*)
-               (format t " "))
-             (receivers *application-frame*))))
-
 (defun beirc-status-display (*application-frame* *standard-output*)
   (with-text-family (t :sans-serif)
     (multiple-value-bind (seconds minutes hours) (decode-universal-time (get-universal-time))
@@ -331,10 +304,8 @@
          (pane (actual-application-pane (pane receiver))))
     (let ((btmp (pane-scrolled-to-bottom-p pane)))
       (setf (pane-needs-redisplay pane) t)
-      (time (redisplay-frame-pane frame pane))
-      (redisplay-frame-pane frame (find-pane-named frame 'receiver-bar))
-       (when btmp                       
-         (scroll-pane-to-bottom pane)))
+      (time (redisplay-frame-panes frame))
+      (when btmp (scroll-pane-to-bottom pane)))
     (medium-force-output (sheet-medium pane)) ;###
     ))
 
@@ -368,9 +339,11 @@
     (setf (messages receiver)
           (append (messages receiver) (list message)))
     (unless (eql receiver (current-receiver frame))
+      (print "hallo" *debug-io*)
       (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))
@@ -383,6 +356,7 @@
       (sleep 1)))
 
 (define-presentation-type nickname ())
+(define-presentation-type ignored-nickname (nickname))
 
 (defun hash-alist (hashtable &aux res)
   (maphash (lambda (k v) (push (cons k v) res)) hashtable)
@@ -391,8 +365,11 @@
 (define-presentation-method accept ((type nickname) *standard-input* (view textual-view) &key)
   (with-slots (connection nick) *application-frame*
     (let ((users (mapcar #'car (hash-alist (irc:users (irc:find-channel connection (current-channel)))))))
-      (accept `(member , at users)
-              :prompt nil))))
+      (accept `(member , at users) :prompt nil))))
+
+(define-presentation-method accept ((type ignored-nickname) *standard-input* (view textual-view) &key)
+  (with-slots (ignored-nicks) *application-frame*
+    (accept `(member , at ignored-nicks) :prompt nil)))
 
 (define-presentation-method accept ((type receiver) *standard-input* (view textual-view) &key)
   (completing-from-suggestions (*standard-input* :partial-completers '(#\Space))
@@ -412,12 +389,6 @@
           (format t "~A" o)))
       (format t "~A" o)))
 
-(define-presentation-method present (o (type receiver) *standard-output* (view textual-view) &key)
-  (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
               :gesture :select
@@ -425,7 +396,10 @@
     (presentation)
   (list (presentation-object presentation)))
 
-(define-beirc-command (com-raise-receiver :name t) ((receiver 'receiver :prompt "Receiver"))
+(define-beirc-command (com-query :name t) ((nick 'nickname :prompt "who"))
+  (raise-receiver (intern-receiver nick *application-frame* :query nick)))
+
+(define-beirc-command (com-raise :name t) ((receiver 'receiver :prompt "receiver"))
   (raise-receiver receiver))
 
 (define-beirc-command (com-focus :name t) ((who 'nickname :prompt "who"))
@@ -434,7 +408,7 @@
 (define-beirc-command (com-ignore :name t) ((who 'nickname :prompt "who"))
   (pushnew who (slot-value *application-frame* 'ignored-nicks) :test #'string=))
 
-(define-beirc-command (com-unignore :name t) ((who 'nickname :prompt "who"))
+(define-beirc-command (com-unignore :name t) ((who 'ignored-nickname :prompt "who"))
   (setf (slot-value *application-frame* 'ignored-nicks)
         (remove who (slot-value *application-frame* 'ignored-nicks)  :test #'string=)))
 
@@ -442,6 +416,9 @@
   (setf (current-focused-nicks)
         (remove who (current-focused-nicks) :test #'string=)))
 
+(define-beirc-command (com-quit :name t) ((reason 'string :prompt "reason"))
+  (irc:quit (current-connection *application-frame*) reason))
+
 (defun target (&optional (*application-frame* *application-frame*))
   (or (current-query)
       (current-channel)))
@@ -475,15 +452,37 @@
   #+ (and sbcl linux) 
   (sb-ext:run-program "/usr/bin/x-www-browser" `(,url) :wait nil))
 
+(define-presentation-to-command-translator nickname-to-ignore-translator
+    (nickname com-ignore beirc
+              :gesture :menu
+              :menu t
+              :documentation "Ignore this user")
+    (object)
+  (list object))
+
+(define-presentation-to-command-translator nickname-to-focus-translator
+    (nickname com-focus beirc
+              :gesture :menu
+              :menu t
+              :documentation "Focus this user")
+    (object)
+  (list object))
+
+(define-presentation-to-command-translator nickname-to-query-translator
+    (nickname com-query beirc
+              :gesture :menu
+              :menu t
+              :documentation "Query this user")
+    (object)
+  (list object))
+
 (define-presentation-to-command-translator url-to-browse-url-translator
     (url com-browse-url beirc)
    (presentation)
   (list (presentation-object presentation)))
 
 (define-beirc-command (com-join :name t) ((channel 'string :prompt "channel"))
-  (setf (current-receiver *application-frame*)
-        (intern-receiver channel *application-frame* :channel channel))
-  (raise-receiver (current-receiver *application-frame*))
+  (raise-receiver (intern-receiver channel *application-frame* :channel channel))
   (irc:join (current-connection *application-frame*) channel))
 
 (define-beirc-command (com-connect :name t)
@@ -493,6 +492,8 @@
         (t
          (setf (slot-value *application-frame* 'connection)
 	       (irc:connect :nickname nick :server server))
+         (setf (irc:client-stream (current-connection *application-frame*))
+               (make-broadcast-stream))
          (setf (slot-value *application-frame* 'nick) nick)
          (let ((connection (current-connection *application-frame*)))
            (let ((frame *application-frame*))


Index: beirc/package.lisp
diff -u beirc/package.lisp:1.1 beirc/package.lisp:1.2
--- beirc/package.lisp:1.1	Wed Sep 14 22:31:44 2005
+++ beirc/package.lisp	Fri Sep 23 21:05:15 2005
@@ -1,3 +1,3 @@
 (cl:defpackage :beirc
-    (:use :clim :clim-lisp :clim-sys)
+    (:use :clim :clim-lisp :clim-sys :tab-layout)
     (:export #:beirc))



From afuchs at common-lisp.net  Fri Sep 23 21:31:41 2005
From: afuchs at common-lisp.net (Andreas Fuchs)
Date: Fri, 23 Sep 2005 23:31:41 +0200 (CEST)
Subject: [beirc-cvs] CVS update: beirc/beirc.lisp beirc/message-display.lisp
Message-ID: <20050923213141.C88D1880DB@common-lisp.net>

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

Modified Files:
	beirc.lisp message-display.lisp 
Log Message:
baby steps towards a server buffer.

 * don't register hook functions into cl-irc anymore, just catch all
   of them and tries to print them in a mostly sensible manner in the
   *Server* buffer.

 * doesn't actually display the messages, as redisplay is broken, for
   only the Server buffer.

 * requires cl-irc cvs patched with
   http://common-lisp.net/pipermail/cl-irc-devel/2005-September/000061.html

anybody who can fix the redisplay issue is welcome to do so (-:


Date: Fri Sep 23 23:31:39 2005
Author: afuchs

Index: beirc/beirc.lisp
diff -u beirc/beirc.lisp:1.14 beirc/beirc.lisp:1.15
--- beirc/beirc.lisp:1.14	Fri Sep 23 21:05:15 2005
+++ beirc/beirc.lisp	Fri Sep 23 23:31:27 2005
@@ -80,34 +80,57 @@
             for found-pane = (actual-application-pane child)
             if found-pane do (return found-pane))))
 
-(defmethod initialize-instance :after ((object receiver) &rest initargs)
-  (declare (ignore initargs))
-  (setf (slot-value object 'pane)
-        (with-look-and-feel-realization
-            ((frame-manager *application-frame*) *application-frame*)
-           (make-clim-application-pane
-                  :display-function
-                  (lambda (frame pane)
-                    (beirc-app-display frame pane object))
-                  :display-time nil
-                  :width 400 :height 600
-                  :incremental-redisplay t)))
-  (setf (slot-value object 'tab-pane)
-        (make-tab-pane-from-list (title object) (pane object) 'receiver)))
-
-(defun make-receiver (name &rest initargs)
-  (let ((receiver (apply 'make-instance 'receiver :title name initargs)))
-    receiver))
+;;; another KLUDGE: define-application-frame-defined panes (as
+;;; find-pane-named returns them) /don't/ come wrapped - they are
+;;; stored as the application pane itself. Of course, tab-layout
+;;; /expects/ them wrapped, so we recurse through the parents to find
+;;; the granddaughter of a tab-layout-pane.
+(defun direct-tab-pane-child-from (pane)
+  "Given a pane, find the parent pane that is the direct child of
+a tab-layout-pane's radio-layout-pane."
+  (labels ((has-parent-p (pane) (and (typep pane 'clim:sheet-parent-mixin)
+                                     (not (null (sheet-parent pane)))))
+           (grandparent (pane)
+             (if (and (has-parent-p pane) (has-parent-p (sheet-parent pane)))
+                 (sheet-parent (sheet-parent pane)))))
+    (cond
+      ((typep (grandparent pane) 'tab-layout-pane) pane)
+      ((has-parent-p pane) (direct-tab-pane-child-from (sheet-parent pane)))
+      (t nil))))
+
+(defun make-paneless-receiver (name &rest initargs)
+  (apply 'make-instance 'receiver :title name initargs))
+
+(defun initialize-receiver-with-pane (receiver frame pane &key (add-pane-p t))
+  (setf (slot-value receiver 'pane) pane)
+  (if (not add-pane-p)
+      (setf (slot-value receiver 'tab-pane)
+            (find-in-tab-panes-list (direct-tab-pane-child-from pane)
+                                    'tab-layout-pane))
+      (progn
+        (setf (slot-value receiver 'tab-pane)
+              (make-tab-pane-from-list (title receiver) (pane receiver) 'receiver))
+        (add-pane (tab-pane receiver) (find-pane-named frame 'query))))
+  (setf (gethash (tab-pane receiver) (tab-panes-to-receivers frame)) receiver))
 
 (defun intern-receiver (name frame &rest initargs)
-  (let ((rec (gethash name (receivers frame))))
+  (let ((rec (gethash (irc:normalize-channel-name (slot-value frame 'connection) name)
+                      (receivers frame))))
     (if rec
         rec
         (let ((*application-frame* frame))
-          (let ((receiver (apply 'make-receiver name initargs)))
-            (add-pane (tab-pane receiver) (find-pane-named frame 'query))
+          (let ((receiver (apply 'make-paneless-receiver name initargs)))
+            (initialize-receiver-with-pane receiver frame
+                                           (with-look-and-feel-realization
+                                               ((frame-manager *application-frame*) *application-frame*)
+                                             (make-clim-application-pane
+                                              :display-function
+                                              (lambda (frame pane)
+                                                (beirc-app-display frame pane receiver))
+                                              :display-time nil
+                                              :width 400 :height 600
+                                              :incremental-redisplay t)))
             (setf (gethash name (receivers frame)) receiver)
-            (setf (gethash (tab-pane receiver) (tab-panes-to-receivers frame)) receiver)
             receiver)))))
 
 (macrolet ((define-privmsg-receiver-lookup (message-type)
@@ -122,7 +145,8 @@
                     (intern-receiver target frame :channel target)))))
   (define-privmsg-receiver-lookup irc:irc-privmsg-message)
   (define-privmsg-receiver-lookup irc:ctcp-action-message)
-  (define-privmsg-receiver-lookup irc:irc-notice-message))
+  ;; (define-privmsg-receiver-lookup irc:irc-notice-message)   ; XXX: NOTICEs in freenode are a bit tricky.
+  )
 
 (macrolet ((define-global-message-receiver-lookup (message-type)
                `(defmethod receiver-for-message ((message ,message-type) frame)
@@ -139,6 +163,10 @@
 (defmethod receiver-for-message ((message irc:irc-part-message) frame)
   (let ((target (first (irc:arguments message))))
     (intern-receiver target frame :channel target)))
+
+(defmethod receiver-for-message ((message irc:irc-message) frame)
+  (server-receiver frame))
+
 ;; TODO: more receiver-for-message methods.
 
 (macrolet ((define-delegate (function-name accessor &optional define-setter-p)
@@ -156,7 +184,7 @@
   (define-delegate current-focused-nicks focused-nicks t))
 
 (defun update-drawing-options (receiver)
-  (set-drawing-options-for-pane-in-tab-layout (pane receiver)
+  (set-drawing-options-for-pane-in-tab-layout (direct-tab-pane-child-from (pane receiver))
                                               `(:ink ,(cond ((> (messages-directed-to-me receiver) 0) +green+)
                                                             ((> (unseen-messages receiver) 0) +red+)
                                                             (t +black+)))))
@@ -174,7 +202,7 @@
 (defun raise-receiver (receiver)
   (setf (unseen-messages receiver) 0)
   (setf (messages-directed-to-me receiver) 0)
-  (switch-to-pane (pane receiver) 'tab-layout-pane))
+  (switch-to-pane (direct-tab-pane-child-from (pane receiver)) 'tab-layout-pane))
 
 ;;; KLUDGE: workaround for mcclim bug "Application pane vertical
 ;;; scrolling does not work with table formatting"
@@ -194,6 +222,7 @@
      (nick :initform nil)
      (ignored-nicks :initform nil)
      (receivers :initform (make-hash-table :test #'equal) :accessor receivers)
+     (server-receiver :initform (make-paneless-receiver "*Server*") :reader server-receiver)
      (tab-panes-to-receivers :initform (make-hash-table :test #'equal) :accessor tab-panes-to-receivers))
   (:panes
    (io
@@ -210,22 +239,25 @@
     :foreground +white+)
    (server
     :application
-    ;; TODO: server message display.
-    ))
+    :display (lambda (frame pane)
+               (beirc-app-display frame pane (server-receiver *application-frame*)))
+    :display-time :command-loop
+    :width 400
+    :height 600
+    :incremental-redisplay t))
   (:geometry :width 800 :height 600)
   (:top-level (clim:default-frame-top-level :prompt 'beirc-prompt))
   (:layouts
    (default
        (vertically ()
          (with-tab-layout ('receiver :name 'query)
-           ("Server" server))
+           ("*Server*" server))
          (60 io)
          (20                            ;<-- Sigh! Bitrot!
-          status-bar )))))
+          status-bar)))))
 
 (defun receiver-from-tab-pane (tab-pane)
-  (gethash tab-pane
-           (tab-panes-to-receivers *application-frame*)))
+  (gethash tab-pane (tab-panes-to-receivers *application-frame*)))
 
 (defmethod current-receiver ((frame beirc))
   (let ((receiver (receiver-from-tab-pane (enabled-pane (find-pane-named frame 'query)))))
@@ -339,7 +371,6 @@
     (setf (messages receiver)
           (append (messages receiver) (list message)))
     (unless (eql receiver (current-receiver frame))
-      (print "hallo" *debug-io*)
       (incf (unseen-messages receiver))
       (when (message-directed-to-me-p frame message)
         (incf (messages-directed-to-me receiver))))
@@ -364,8 +395,9 @@
 
 (define-presentation-method accept ((type nickname) *standard-input* (view textual-view) &key)
   (with-slots (connection nick) *application-frame*
-    (let ((users (mapcar #'car (hash-alist (irc:users (irc:find-channel connection (current-channel)))))))
-      (accept `(member , at users) :prompt nil))))
+    (let ((users (unless (null (current-channel))
+                   (mapcar #'car (hash-alist (irc:users (irc:find-channel connection (current-channel))))))))
+      (accept `(or (member , at users) string) :prompt nil))))
 
 (define-presentation-method accept ((type ignored-nickname) *standard-input* (view textual-view) &key)
   (with-slots (ignored-nicks) *application-frame*
@@ -491,12 +523,15 @@
          (format *query-io* "You are already connected.~%"))
         (t
          (setf (slot-value *application-frame* 'connection)
-	       (irc:connect :nickname nick :server server))
+	       (irc:connect :nickname nick :server server :connection-type 'beirc-connection))
          (setf (irc:client-stream (current-connection *application-frame*))
                (make-broadcast-stream))
          (setf (slot-value *application-frame* 'nick) nick)
          (let ((connection (current-connection *application-frame*)))
            (let ((frame *application-frame*))
+             (initialize-receiver-with-pane (server-receiver frame) frame
+                                            (find-pane-named frame 'server)
+                                            :add-pane-p nil)
              (clim-sys:make-process #'(lambda ()
                                         (irc-event-loop frame connection))
                                     :name "IRC Message Muffling Loop") )))))
@@ -553,24 +588,18 @@
 ;  (finish-output *trace-output*)
   nil)
 
+(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))
+
 (defun irc-event-loop (frame connection)
   (unwind-protect
-       (progn
-         (irc:add-hook connection 'irc:irc-privmsg-message
-                       (lambda (m) (post-message frame m)))
-         (irc:add-hook connection 'irc:irc-nick-message
-                       (lambda (m) (post-message frame m)))
-         (irc:add-hook connection 'irc:irc-part-message
-                       (lambda (m) (post-message frame m)))
-         (irc:add-hook connection 'irc:irc-quit-message
-                       (lambda (m) (post-message frame m)))
-         (irc:add-hook connection 'irc:irc-join-message
-                       (lambda (m) (post-message frame m)))
-         (irc:add-hook connection 'irc:irc-ping-message
-                       (lambda (m) (process-message frame m)))
-         (irc:add-hook connection 'cl-irc:ctcp-action-message
-                       (lambda (m) (post-message frame m)))
-         (irc:read-message-loop connection) )
+       (let ((*application-frame* frame))
+         (irc:read-message-loop connection))
     (irc:remove-all-hooks connection)))
 
 ;;; Hack:


Index: beirc/message-display.lisp
diff -u beirc/message-display.lisp:1.4 beirc/message-display.lisp:1.5
--- beirc/message-display.lisp:1.4	Fri Sep 23 11:52:40 2005
+++ beirc/message-display.lisp	Fri Sep 23 23:31:27 2005
@@ -101,7 +101,7 @@
 	      (incf column))
   (terpri))
 
-(defmethod print-message ((message irc:IRC-PRIVMSG-MESSAGE) receiver)
+(defun print-privmsg-like-message (message receiver start-string end-string)
   (with-drawing-options
       (*standard-output*
        :ink (if (string-equal "localhost" (irc:host message))
@@ -112,10 +112,16 @@
 	  (*standard-output*
 	   (if (message-from-focused-nick-p message receiver) :bold :roman))
         (formatting-message (t message receiver)
-          ((format t "<")
-           (present (irc:source message) 'nickname)
-           (format t ">"))
-          ((format-message* (irc:trailing-argument message))))))))
+                ((write-string start-string *standard-output*)
+                 (present (irc:source message) 'nickname)
+                 (write-string end-string *standard-output*))
+                ((format-message* (irc:trailing-argument message))))))))
+
+(defmethod print-message ((message irc:IRC-PRIVMSG-MESSAGE) receiver)
+  (print-privmsg-like-message message receiver "<" ">"))
+
+(defmethod print-message ((message irc:IRC-NOTICE-MESSAGE) receiver)
+  (print-privmsg-like-message message receiver "-" "-"))
 
 (defmethod print-message ((message irc:ctcp-action-message) receiver)
   (let ((source (cl-irc:source message))
@@ -161,6 +167,11 @@
              (present (irc:source message) 'nickname)
              (format t " left ~A: ~A" (first (irc:arguments message)) (irc:trailing-argument message))))))
 
+(defmethod print-message (message receiver)
+  (formatting-message (t message receiver)
+          ((format t "!!! ~A" (irc:source message)))
+          ((with-drawing-options (*standard-output* :ink +red+ :text-size :small)
+             (format t "args: ~A :~A" (irc:arguments message) (irc:trailing-argument message))))))
 
 (defgeneric preamble-length (message)
   (:method ((message irc:irc-privmsg-message))



From afuchs at common-lisp.net  Fri Sep 23 22:06:00 2005
From: afuchs at common-lisp.net (Andreas Fuchs)
Date: Sat, 24 Sep 2005 00:06:00 +0200 (CEST)
Subject: [beirc-cvs] CVS update: beirc/beirc.lisp 
Message-ID: <20050923220600.6AFF0880DB@common-lisp.net>

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

Modified Files:
	beirc.lisp 
Log Message:
Make server buffer display messages & delete previous KLUDGE.

* Also, try and dtrt on /quit.

Date: Sat Sep 24 00:06:00 2005
Author: afuchs

Index: beirc/beirc.lisp
diff -u beirc/beirc.lisp:1.15 beirc/beirc.lisp:1.16
--- beirc/beirc.lisp:1.15	Fri Sep 23 23:31:27 2005
+++ beirc/beirc.lisp	Sat Sep 24 00:05:54 2005
@@ -80,24 +80,6 @@
             for found-pane = (actual-application-pane child)
             if found-pane do (return found-pane))))
 
-;;; another KLUDGE: define-application-frame-defined panes (as
-;;; find-pane-named returns them) /don't/ come wrapped - they are
-;;; stored as the application pane itself. Of course, tab-layout
-;;; /expects/ them wrapped, so we recurse through the parents to find
-;;; the granddaughter of a tab-layout-pane.
-(defun direct-tab-pane-child-from (pane)
-  "Given a pane, find the parent pane that is the direct child of
-a tab-layout-pane's radio-layout-pane."
-  (labels ((has-parent-p (pane) (and (typep pane 'clim:sheet-parent-mixin)
-                                     (not (null (sheet-parent pane)))))
-           (grandparent (pane)
-             (if (and (has-parent-p pane) (has-parent-p (sheet-parent pane)))
-                 (sheet-parent (sheet-parent pane)))))
-    (cond
-      ((typep (grandparent pane) 'tab-layout-pane) pane)
-      ((has-parent-p pane) (direct-tab-pane-child-from (sheet-parent pane)))
-      (t nil))))
-
 (defun make-paneless-receiver (name &rest initargs)
   (apply 'make-instance 'receiver :title name initargs))
 
@@ -105,7 +87,7 @@
   (setf (slot-value receiver 'pane) pane)
   (if (not add-pane-p)
       (setf (slot-value receiver 'tab-pane)
-            (find-in-tab-panes-list (direct-tab-pane-child-from pane)
+            (find-in-tab-panes-list pane
                                     'tab-layout-pane))
       (progn
         (setf (slot-value receiver 'tab-pane)
@@ -184,7 +166,7 @@
   (define-delegate current-focused-nicks focused-nicks t))
 
 (defun update-drawing-options (receiver)
-  (set-drawing-options-for-pane-in-tab-layout (direct-tab-pane-child-from (pane receiver))
+  (set-drawing-options-for-pane-in-tab-layout (pane receiver)
                                               `(:ink ,(cond ((> (messages-directed-to-me receiver) 0) +green+)
                                                             ((> (unseen-messages receiver) 0) +red+)
                                                             (t +black+)))))
@@ -202,7 +184,7 @@
 (defun raise-receiver (receiver)
   (setf (unseen-messages receiver) 0)
   (setf (messages-directed-to-me receiver) 0)
-  (switch-to-pane (direct-tab-pane-child-from (pane receiver)) 'tab-layout-pane))
+  (switch-to-pane (pane receiver) 'tab-layout-pane))
 
 ;;; KLUDGE: workaround for mcclim bug "Application pane vertical
 ;;; scrolling does not work with table formatting"
@@ -238,13 +220,13 @@
     :background +black+
     :foreground +white+)
    (server
-    :application
-    :display (lambda (frame pane)
-               (beirc-app-display frame pane (server-receiver *application-frame*)))
-    :display-time :command-loop
-    :width 400
-    :height 600
-    :incremental-redisplay t))
+    (make-clim-application-pane
+     :display-function
+     (lambda (frame pane)
+       (beirc-app-display frame pane (server-receiver *application-frame*)))
+     :display-time nil
+     :width 400 :height 600
+     :incremental-redisplay t)))
   (:geometry :width 800 :height 600)
   (:top-level (clim:default-frame-top-level :prompt 'beirc-prompt))
   (:layouts
@@ -448,7 +430,7 @@
   (setf (current-focused-nicks)
         (remove who (current-focused-nicks) :test #'string=)))
 
-(define-beirc-command (com-quit :name t) ((reason 'string :prompt "reason"))
+(define-beirc-command (com-quit :name t) ((reason 'mumble :prompt "reason"))
   (irc:quit (current-connection *application-frame*) reason))
 
 (defun target (&optional (*application-frame* *application-frame*))



From afuchs at common-lisp.net  Fri Sep 23 23:04:23 2005
From: afuchs at common-lisp.net (Andreas Fuchs)
Date: Sat, 24 Sep 2005 01:04:23 +0200 (CEST)
Subject: [beirc-cvs] CVS update: beirc/beirc.lisp beirc/message-display.lisp
Message-ID: <20050923230423.9A36C880DB@common-lisp.net>

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

Modified Files:
	beirc.lisp message-display.lisp 
Log Message:
add NAMES and TOPIC reply output; fix /raise <click>; add pointer-documentation

also, remove the defunct raise-this-receiver p-t-c-translator


Date: Sat Sep 24 01:04:22 2005
Author: afuchs

Index: beirc/beirc.lisp
diff -u beirc/beirc.lisp:1.16 beirc/beirc.lisp:1.17
--- beirc/beirc.lisp:1.16	Sat Sep 24 00:05:54 2005
+++ beirc/beirc.lisp	Sat Sep 24 01:04:21 2005
@@ -67,6 +67,8 @@
       (pane :reader pane)
       (tab-pane :accessor tab-pane)))
 
+(define-presentation-type receiver-pane ())
+
 ;;; KLUDGE: make-clim-application-pane doesn't return an application
 ;;; pane, but a pane that wraps the application pane. we need the
 ;;; application pane for redisplay, though.
@@ -91,7 +93,7 @@
                                     'tab-layout-pane))
       (progn
         (setf (slot-value receiver 'tab-pane)
-              (make-tab-pane-from-list (title receiver) (pane receiver) 'receiver))
+              (make-tab-pane-from-list (title receiver) (pane receiver) 'receiver-pane))
         (add-pane (tab-pane receiver) (find-pane-named frame 'query))))
   (setf (gethash (tab-pane receiver) (tab-panes-to-receivers frame)) receiver))
 
@@ -138,6 +140,15 @@
  (define-global-message-receiver-lookup irc:irc-quit-message)
  (define-global-message-receiver-lookup irc:irc-nick-message))
 
+(defmethod receiver-for-message ((message irc:irc-topic-message) frame)
+  (intern-receiver (first (irc:arguments message)) frame :channel (first (irc:arguments message))))
+
+(defmethod receiver-for-message ((message irc:irc-rpl_topic-message) frame)
+  (intern-receiver (second (irc:arguments message)) frame :channel (second (irc:arguments message))))
+
+(defmethod receiver-for-message ((message irc:irc-rpl_namreply-message) frame)
+  (intern-receiver (third (irc:arguments message)) frame :channel (third (irc:arguments message))))
+
 (defmethod receiver-for-message ((message irc:irc-join-message) frame)
   (let ((target (irc:trailing-argument message)))
     (intern-receiver target frame :channel target)))
@@ -232,8 +243,8 @@
   (:layouts
    (default
        (vertically ()
-         (with-tab-layout ('receiver :name 'query)
-           ("*Server*" server))
+         (with-tab-layout ('receiver-pane :name 'query)
+           ("*Server*" server 'receiver-pane))
          (60 io)
          (20                            ;<-- Sigh! Bitrot!
           status-bar)))))
@@ -389,6 +400,13 @@
   (completing-from-suggestions (*standard-input* :partial-completers '(#\Space))
     (maphash #'suggest (receivers *application-frame*))))
 
+(define-presentation-translator receiver-pane-to-receiver-translator
+    (receiver-pane receiver beirc)
+    (object)
+  (receiver-from-tab-pane
+         (find-in-tab-panes-list object
+                                 (find-pane-named *application-frame* 'query))))
+
 (defun nick-equals-my-nick-p (nickname)
   (and *application-frame*
        (equal (irc:normalize-nickname (current-connection *application-frame*)
@@ -403,13 +421,6 @@
           (format t "~A" o)))
       (format t "~A" o)))
 
-(define-presentation-to-command-translator raise-this-receiver
-    (receiver com-raise-receiver beirc
-              :gesture :select
-              :documentation "Raise this receiver")
-    (presentation)
-  (list (presentation-object presentation)))
-
 (define-beirc-command (com-query :name t) ((nick 'nickname :prompt "who"))
   (raise-receiver (intern-receiver nick *application-frame* :query nick)))
 
@@ -470,7 +481,8 @@
     (nickname com-ignore beirc
               :gesture :menu
               :menu t
-              :documentation "Ignore this user")
+              :documentation "Ignore this user"
+              :pointer-documentation "Ignore this user")
     (object)
   (list object))
 
@@ -478,7 +490,8 @@
     (nickname com-focus beirc
               :gesture :menu
               :menu t
-              :documentation "Focus this user")
+              :documentation "Focus this user"
+              :pointer-documentation "Focus this user")
     (object)
   (list object))
 
@@ -486,7 +499,8 @@
     (nickname com-query beirc
               :gesture :menu
               :menu t
-              :documentation "Query this user")
+              :documentation "Query this user"
+              :pointer-documentation "Query this user")
     (object)
   (list object))
 
@@ -514,6 +528,7 @@
              (initialize-receiver-with-pane (server-receiver frame) frame
                                             (find-pane-named frame 'server)
                                             :add-pane-p nil)
+             (setf (gethash "*Server*" (receivers frame)) (server-receiver frame))
              (clim-sys:make-process #'(lambda ()
                                         (irc-event-loop frame connection))
                                     :name "IRC Message Muffling Loop") )))))


Index: beirc/message-display.lisp
diff -u beirc/message-display.lisp:1.5 beirc/message-display.lisp:1.6
--- beirc/message-display.lisp:1.5	Fri Sep 23 23:31:27 2005
+++ beirc/message-display.lisp	Sat Sep 24 01:04:21 2005
@@ -78,6 +78,16 @@
                   (string last-char)))
          (otherwise (values word ""))))))
 
+(defun strip-op-signs (word)
+  (if (= (length word) 0)
+      (values word "")
+      (let ((first-char (char word 0)))
+       (case first-char
+         ((#\@ #\+)
+          (values (subseq word 1)
+                  (string first-char)))
+         (otherwise (values word ""))))))
+
 (defun format-message* (mumble &key (limit *default-fill-column*) (start-length 0))
   (loop for (word . rest) on (split-sequence:split-sequence #\Space mumble)
 	with column = start-length
@@ -85,16 +95,18 @@
 	when (> column limit)
 	  do (setf column (length word))
 	     (terpri)
-	do (multiple-value-bind (word* stripped-punctuation) (strip-punctuation word)
-	     (cond
-	       ((search "http://" word*)
-		(present-url word*))
-	       ((or
-		 (nick-equals-my-nick-p word*)
-		 (irc:find-user (current-connection *application-frame*) word*))
-		(present word* 'nickname))
-	       (t (write-string word*)))
-	     (write-string stripped-punctuation))
+	do (multiple-value-bind (%word stripped-opsigns) (strip-op-signs word)
+             (multiple-value-bind (word% stripped-punctuation) (strip-punctuation %word)
+               (write-string stripped-opsigns)
+               (cond
+                 ((search "http://" word%)
+                  (present-url word%))
+                 ((or
+                   (nick-equals-my-nick-p word%)
+                   (irc:find-user (current-connection *application-frame*) word%))
+                  (present word% 'nickname))
+                 (t (write-string word%)))
+               (write-string stripped-punctuation)))
 	   ;; TODO: more highlighting
 	unless (or (null rest) (>= column limit))
 	  do  (write-char #\Space)
@@ -158,6 +170,31 @@
              (present (irc:source message) 'nickname)
              (format t " (~A@~A) is now known as " (irc:user message) (irc:host message))
              (present (irc:trailing-argument message) 'nickname)))))
+
+(defun print-topic (receiver message sender channel topic)
+  (formatting-message (t message receiver)
+          ((format t "    "))
+          ((with-drawing-options (*standard-output* :ink +gray33+ :text-size :small)
+             (if (null sender)
+                 (format-message* (format nil "Topic for ~A: ~A" channel topic))
+                 (progn
+                   (present sender 'nickname)
+                   (format-message* (format nil " set the topic for ~A to ~A" channel topic))))))))
+
+(defmethod print-message ((message irc:irc-topic-message) receiver)
+  (print-topic receiver message (irc:source message)
+               (first (irc:arguments message)) (irc:trailing-argument message)))
+
+(defmethod print-message ((message irc:irc-rpl_topic-message) receiver)
+  (print-topic receiver message nil
+               (second (irc:arguments message)) (irc:trailing-argument message)))
+
+(defmethod print-message ((message irc:irc-rpl_namreply-message) receiver)
+  (formatting-message (t message receiver)
+          ((format t "   "))
+          ((with-drawing-options (*standard-output* :ink +gray33+ :text-size :small)
+             (format-message* (format nil "~A Names: ~A" (third (irc:arguments message))
+                                      (irc:trailing-argument message)))))))
 
 (defmethod print-message ((message irc:irc-part-message) receiver)
   (formatting-message (t message receiver)



From afuchs at common-lisp.net  Fri Sep 23 23:22:51 2005
From: afuchs at common-lisp.net (Andreas Fuchs)
Date: Sat, 24 Sep 2005 01:22:51 +0200 (CEST)
Subject: [beirc-cvs] CVS update: beirc/beirc.lisp 
Message-ID: <20050923232251.5EE6F880DB@common-lisp.net>

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

Modified Files:
	beirc.lisp 
Log Message:
Fix a few uses to find-in-tab-panes-list to use the recommended API

Date: Sat Sep 24 01:22:50 2005
Author: afuchs

Index: beirc/beirc.lisp
diff -u beirc/beirc.lisp:1.17 beirc/beirc.lisp:1.18
--- beirc/beirc.lisp:1.17	Sat Sep 24 01:04:21 2005
+++ beirc/beirc.lisp	Sat Sep 24 01:22:50 2005
@@ -184,8 +184,7 @@
 
 (defmethod switch-to-pane :after ((pane sheet) (parent (eql 'tab-layout-pane)))
   (let ((receiver (receiver-from-tab-pane
-                   (find-in-tab-panes-list pane
-                                           (find-pane-named *application-frame* 'query)))))
+                   (find-in-tab-panes-list pane 'tab-layout-pane))))
     (unless (null receiver)
       (setf (unseen-messages receiver) 0)
       (setf (messages-directed-to-me receiver) 0)
@@ -404,8 +403,7 @@
     (receiver-pane receiver beirc)
     (object)
   (receiver-from-tab-pane
-         (find-in-tab-panes-list object
-                                 (find-pane-named *application-frame* 'query))))
+         (find-in-tab-panes-list object 'tab-layout-pane)))
 
 (defun nick-equals-my-nick-p (nickname)
   (and *application-frame*



From afuchs at common-lisp.net  Sat Sep 24 09:14:05 2005
From: afuchs at common-lisp.net (Andreas Fuchs)
Date: Sat, 24 Sep 2005 11:14:05 +0200 (CEST)
Subject: [beirc-cvs] CVS update: beirc/beirc.lisp beirc/message-display.lisp
Message-ID: <20050924091405.33FB088542@common-lisp.net>

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

Modified Files:
	beirc.lisp message-display.lisp 
Log Message:
Fix /quit, /disconnect commands and quitting the irc worker thread.

 * /quit, /disconnect and later /connect commands now work, hopefully in
   all combinations.

 * This change also introduces a level of thread hygiene. When beirc's
   application frame exits, every thread (except the clim/clx listener
   thread) should be killed as well.


Date: Sat Sep 24 11:14:04 2005
Author: afuchs

Index: beirc/beirc.lisp
diff -u beirc/beirc.lisp:1.18 beirc/beirc.lisp:1.19
--- beirc/beirc.lisp:1.18	Sat Sep 24 01:22:50 2005
+++ beirc/beirc.lisp	Sat Sep 24 11:14:03 2005
@@ -190,7 +190,6 @@
       (setf (messages-directed-to-me receiver) 0)
       (update-drawing-options receiver))))
 
-
 (defun raise-receiver (receiver)
   (setf (unseen-messages receiver) 0)
   (setf (messages-directed-to-me receiver) 0)
@@ -211,6 +210,7 @@
 (define-application-frame beirc (redisplay-frame-mixin
                                  standard-application-frame)
     ((connection :initform nil :reader current-connection)
+     (connection-process :initform nil :accessor connection-process)
      (nick :initform nil)
      (ignored-nicks :initform nil)
      (receivers :initform (make-hash-table :test #'equal) :accessor receivers)
@@ -347,11 +347,12 @@
           (clim-sys:make-process
            (lambda ()
              (progv syms vals
-               (let ((frame (make-application-frame 'beirc)))
+               (let* ((frame (make-application-frame 'beirc))
+                      (ticker-process (clim-sys:make-process (lambda () (ticker frame))
+                                                             :name "Beirc Ticker")))
                  (setf *beirc-frame* frame)
-                 (clim-sys:make-process (lambda () (ticker frame))
-                                        :name "Beirc Ticker")
-                 (run-frame-top-level frame))))))))
+                 (run-frame-top-level frame)
+                 (clim-sys:destroy-process ticker-process))))))))
 
 (defun message-directed-to-me-p (frame message)
   (let ((my-nick (slot-value frame 'nick))
@@ -372,11 +373,16 @@
      (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)
-  (loop
-      (clim-internals::event-queue-prepend (climi::frame-event-queue frame)
-                                           (make-instance 'bar-event :sheet frame))
-      (sleep 1)))
+  (handler-case
+      (loop 
+        (clim-internals::event-queue-prepend (climi::frame-event-queue frame)
+                                             (make-instance 'bar-event :sheet frame))
+        (sleep 1))
+    (frame-exit ()
+      nil)))
 
 (define-presentation-type nickname ())
 (define-presentation-type ignored-nickname (nickname))
@@ -406,7 +412,8 @@
          (find-in-tab-panes-list object 'tab-layout-pane)))
 
 (defun nick-equals-my-nick-p (nickname)
-  (and *application-frame*
+  (and (not (null *application-frame*))
+       (not (null (slot-value *application-frame* 'connection)))
        (equal (irc:normalize-nickname (current-connection *application-frame*)
                                       (slot-value *application-frame* 'nick))
               (irc:normalize-nickname (current-connection *application-frame*)
@@ -440,7 +447,13 @@
         (remove who (current-focused-nicks) :test #'string=)))
 
 (define-beirc-command (com-quit :name t) ((reason 'mumble :prompt "reason"))
-  (irc:quit (current-connection *application-frame*) reason))
+  (when (current-connection *application-frame*)
+    (quit *application-frame* reason))
+  (frame-exit *application-frame*))
+
+(define-beirc-command (com-disconnect :name t) ((reason 'mumble :prompt "reason"))
+  (when (current-connection *application-frame*)
+    (quit *application-frame* reason)))
 
 (defun target (&optional (*application-frame* *application-frame*))
   (or (current-query)
@@ -527,9 +540,45 @@
                                             (find-pane-named frame 'server)
                                             :add-pane-p nil)
              (setf (gethash "*Server*" (receivers frame)) (server-receiver frame))
-             (clim-sys:make-process #'(lambda ()
-                                        (irc-event-loop frame connection))
-                                    :name "IRC Message Muffling Loop") )))))
+             (setf (connection-process *application-frame*)
+                   (clim-sys:make-process #'(lambda ()
+                                              (unwind-protect
+                                                  (irc-event-loop frame connection)
+                                                (disconnect frame)))
+                                          :name "IRC Message Muffling Loop")) )))))
+
+(defun disconnect (frame)
+  (let ((old-nickname (slot-value frame 'nick)))
+    (raise-receiver (server-receiver frame))
+    (post-message frame
+                  (make-instance 'irc:irc-quit-message
+                     :received-time (get-universal-time)
+                     :connection :local
+                     :trailing-argument
+                     (format nil "You disconnected from IRC")
+                     :arguments nil
+                     :command "QUIT"
+                     :host "localhost" ;###
+                     :user "localuser" ;###
+                     :source old-nickname))
+    (when (and (connection-process frame)
+               (not (eql (clim-sys:current-process)
+                         (connection-process frame))))
+      (destroy-process (connection-process frame)))
+    (setf (slot-value frame 'connection) nil
+          (connection-process frame) nil
+          (slot-value frame 'nick) nil)))
+
+(defun quit (frame reason)
+  (raise-receiver (server-receiver frame))
+  (irc:quit (current-connection frame) reason)
+  (when (and (connection-process frame)
+             (not (eql (clim-sys:current-process)
+                       (connection-process frame))))
+    (destroy-process (connection-process frame)))
+  (setf (slot-value frame 'connection) nil
+        (connection-process frame) nil
+        (slot-value frame 'nick) nil))
 
 (defmethod clim:read-frame-command ((frame beirc) &key (stream *standard-input*))
   (multiple-value-prog1 
@@ -544,12 +593,10 @@
     (window-clear stream)))
 
 (defun restart-beirc ()
-  (let ((m (current-messages)))
-    (clim-sys:destroy-process *gui-process*)
-    (setf *beirc-frame* nil)
-    (beirc)
-    (clim-sys:process-wait "waiting for beirc" (lambda () *beirc-frame*))
-    (setf (current-messages) m)))
+  (clim-sys:destroy-process *gui-process*)
+  (setf *beirc-frame* nil)
+  (beirc)
+  (clim-sys:process-wait "waiting for beirc" (lambda () *beirc-frame*)))
 
 
 ;;;;;;;;;


Index: beirc/message-display.lisp
diff -u beirc/message-display.lisp:1.6 beirc/message-display.lisp:1.7
--- beirc/message-display.lisp:1.6	Sat Sep 24 01:04:21 2005
+++ beirc/message-display.lisp	Sat Sep 24 11:14:03 2005
@@ -103,7 +103,8 @@
                   (present-url word%))
                  ((or
                    (nick-equals-my-nick-p word%)
-                   (irc:find-user (current-connection *application-frame*) word%))
+                   (and (current-connection *application-frame*)
+                        (irc:find-user (current-connection *application-frame*) word%)))
                   (present word% 'nickname))
                  (t (write-string word%)))
                (write-string stripped-punctuation)))



From afuchs at common-lisp.net  Sat Sep 24 11:43:38 2005
From: afuchs at common-lisp.net (Andreas Fuchs)
Date: Sat, 24 Sep 2005 13:43:38 +0200 (CEST)
Subject: [beirc-cvs] CVS update: beirc/beirc.lisp 
Message-ID: <20050924114338.4507B880DE@common-lisp.net>

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))



From afuchs at common-lisp.net  Sat Sep 24 14:36:35 2005
From: afuchs at common-lisp.net (Andreas Fuchs)
Date: Sat, 24 Sep 2005 16:36:35 +0200 (CEST)
Subject: [beirc-cvs] CVS update: beirc/beirc.lisp beirc/message-display.lisp
Message-ID: <20050924143635.1DAB7880DE@common-lisp.net>

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

Modified Files:
	beirc.lisp message-display.lisp 
Log Message:
Handle printing of the server's MOTD. Add an /Eval command to debug
cl-irc commands.


Date: Sat Sep 24 16:36:32 2005
Author: afuchs

Index: beirc/beirc.lisp
diff -u beirc/beirc.lisp:1.20 beirc/beirc.lisp:1.21
--- beirc/beirc.lisp:1.20	Sat Sep 24 13:43:37 2005
+++ beirc/beirc.lisp	Sat Sep 24 16:36:31 2005
@@ -461,6 +461,12 @@
   (setf (current-focused-nicks)
         (remove who (current-focused-nicks) :test #'string=)))
 
+(define-beirc-command (com-eval :name t) ((command 'string :prompt "command")
+                                          (args '(sequence string) :prompt "arguments"))
+  (multiple-value-bind (symbol status) (find-symbol command :irc)
+    (when (eql status :external)
+      (apply symbol (current-connection *application-frame*) (coerce args 'list)))))
+
 (define-beirc-command (com-quit :name t) ((reason 'mumble :prompt "reason"))
   (when (current-connection *application-frame*)
     (quit *application-frame* reason))


Index: beirc/message-display.lisp
diff -u beirc/message-display.lisp:1.7 beirc/message-display.lisp:1.8
--- beirc/message-display.lisp:1.7	Sat Sep 24 11:14:03 2005
+++ beirc/message-display.lisp	Sat Sep 24 16:36:31 2005
@@ -205,6 +205,12 @@
              (present (irc:source message) 'nickname)
              (format t " left ~A: ~A" (first (irc:arguments message)) (irc:trailing-argument message))))))
 
+(defmethod print-message ((message irc:irc-rpl_motd-message) receiver)
+  (formatting-message (t message receiver)
+          ((format t "~A" (irc:source message)))
+          ((with-drawing-options (*standard-output* :ink +gray33+ :text-size :small)
+             (format t "MOTD: ~A" (irc:trailing-argument message))))))
+
 (defmethod print-message (message receiver)
   (formatting-message (t message receiver)
           ((format t "!!! ~A" (irc:source message)))



From afuchs at common-lisp.net  Sat Sep 24 15:04:09 2005
From: afuchs at common-lisp.net (Andreas Fuchs)
Date: Sat, 24 Sep 2005 17:04:09 +0200 (CEST)
Subject: [beirc-cvs] CVS update: beirc/beirc.lisp beirc/message-display.lisp
Message-ID: <20050924150409.5A8C3880DE@common-lisp.net>

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

Modified Files:
	beirc.lisp message-display.lisp 
Log Message:
further printing / command features:

 * don't print "end of <anything>" replies from the server.
 * add a /topic, /names, /op, /deop command.
 * add a method to print irc-mode-messages. 

Date: Sat Sep 24 17:04:07 2005
Author: afuchs

Index: beirc/beirc.lisp
diff -u beirc/beirc.lisp:1.21 beirc/beirc.lisp:1.22
--- beirc/beirc.lisp:1.21	Sat Sep 24 16:36:31 2005
+++ beirc/beirc.lisp	Sat Sep 24 17:04:06 2005
@@ -176,6 +176,34 @@
   (let ((target (first (irc:arguments message))))
     (intern-receiver target frame :channel target)))
 
+(defmethod receiver-for-message ((message irc:irc-mode-message) frame)
+  (destructuring-bind (channel modes args) (irc:arguments message)
+    (declare (ignore modes args))
+    (intern-receiver channel frame :channel channel)))
+
+(macrolet ((define-ignore-message-types (&rest mtypes)
+             `(progn
+                ,@(loop for mtype in mtypes
+                        collect `(defmethod receiver-for-message ((message ,mtype) frame)
+                                   nil)))))
+  (define-ignore-message-types cl-irc:irc-rpl_endofwhowas-message
+    cl-irc:irc-rpl_endoflinks-message
+    cl-irc:irc-rpl_endoptions-message
+    cl-irc:irc-rpl_endofwhois-message
+    cl-irc:irc-rpl_endsitelist-message
+    cl-irc:irc-rpl_endofinvitelist-message
+    cl-irc:irc-rpl_endofservices-message
+    cl-irc:irc-rpl_endmode-message
+    cl-irc:irc-rpl_endofmap-message
+    cl-irc:irc-rpl_endofnames-message
+    cl-irc:irc-rpl_endofusers-message
+    cl-irc:irc-rpl_endofbanlist-message
+    cl-irc:irc-rpl_endofmotd-message
+    cl-irc:irc-rpl_endofinfo-message
+    cl-irc:irc-rpl_endofstats-message
+    cl-irc:irc-rpl_endofwho-message
+    cl-irc:irc-rpl_endofexceptlist-message))
+
 (defmethod receiver-for-message ((message irc:irc-message) frame)
   (server-receiver frame))
 
@@ -463,9 +491,21 @@
 
 (define-beirc-command (com-eval :name t) ((command 'string :prompt "command")
                                           (args '(sequence string) :prompt "arguments"))
-  (multiple-value-bind (symbol status) (find-symbol command :irc)
+  (multiple-value-bind (symbol status) (find-symbol (string-upcase command) :irc)
     (when (eql status :external)
       (apply symbol (current-connection *application-frame*) (coerce args 'list)))))
+
+(define-beirc-command (com-topic :name t) ((topic 'mumble :prompt "topic"))
+  (irc:topic- (current-connection *application-frame*) (target) topic))
+
+(define-beirc-command (com-op :name t) ((who 'nickname :prompt "who"))
+  (irc:op (current-connection *application-frame*) (target) who))
+
+(define-beirc-command (com-deop :name t) ((who 'nickname :prompt "who"))
+  (irc:deop (current-connection *application-frame*) (target) who))
+
+(define-beirc-command (com-names :name t) ()
+  (irc:names (current-connection *application-frame*) (target)))
 
 (define-beirc-command (com-quit :name t) ((reason 'mumble :prompt "reason"))
   (when (current-connection *application-frame*)


Index: beirc/message-display.lisp
diff -u beirc/message-display.lisp:1.8 beirc/message-display.lisp:1.9
--- beirc/message-display.lisp:1.8	Sat Sep 24 16:36:31 2005
+++ beirc/message-display.lisp	Sat Sep 24 17:04:06 2005
@@ -205,6 +205,15 @@
              (present (irc:source message) 'nickname)
              (format t " left ~A: ~A" (first (irc:arguments message)) (irc:trailing-argument message))))))
 
+(defmethod print-message ((message irc:irc-mode-message) receiver)
+  (destructuring-bind (target modes args) (irc:arguments message)
+    (declare (ignore target))
+    (formatting-message (t message receiver)
+            ((format t "   "))
+            ((with-drawing-options (*standard-output* :ink +gray33+ :text-size :small)
+               (present (irc:source message) 'nickname)
+               (format-message* (format nil " set mode ~A ~A" modes args)))))))
+
 (defmethod print-message ((message irc:irc-rpl_motd-message) receiver)
   (formatting-message (t message receiver)
           ((format t "~A" (irc:source message)))



From afuchs at common-lisp.net  Sat Sep 24 17:28:39 2005
From: afuchs at common-lisp.net (Andreas Fuchs)
Date: Sat, 24 Sep 2005 19:28:39 +0200 (CEST)
Subject: [beirc-cvs] CVS update: beirc/beirc.lisp beirc/message-display.lisp
Message-ID: <20050924172839.614CB880DE@common-lisp.net>

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

Modified Files:
	beirc.lisp message-display.lisp 
Log Message:

 * refactor message faking
 * fix display of irc-MODE-messages that deal with user modes
 * rework /topic to display the topic if no string is passed
 * add presentation type CHANNEL and an accept method so that /join
   doesn't do stupid things anymore on empty input.
 * add minimal receiver closing functionality.


Date: Sat Sep 24 19:28:38 2005
Author: afuchs

Index: beirc/beirc.lisp
diff -u beirc/beirc.lisp:1.22 beirc/beirc.lisp:1.23
--- beirc/beirc.lisp:1.22	Sat Sep 24 17:04:06 2005
+++ beirc/beirc.lisp	Sat Sep 24 19:28:38 2005
@@ -121,6 +121,10 @@
             (setf (gethash name (receivers frame)) receiver)
             receiver)))))
 
+(defun remove-receiver (receiver frame)
+  (remove-pane (tab-pane receiver) (find-pane-named frame 'query))
+  (remhash (title receiver) (receivers frame)))
+
 (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,
@@ -177,9 +181,11 @@
     (intern-receiver target frame :channel target)))
 
 (defmethod receiver-for-message ((message irc:irc-mode-message) frame)
-  (destructuring-bind (channel modes args) (irc:arguments message)
-    (declare (ignore modes args))
-    (intern-receiver channel frame :channel channel)))
+  (case (length (irc:arguments message))
+    (1 (server-receiver frame))
+    (3 (destructuring-bind (channel modes args) (irc:arguments message)
+         (declare (ignore modes args))
+         (intern-receiver channel frame :channel channel)))))
 
 (macrolet ((define-ignore-message-types (&rest mtypes)
              `(progn
@@ -244,7 +250,6 @@
 
 ;;; KLUDGE: workaround for mcclim bug "Application pane vertical
 ;;; scrolling does not work with table formatting"
-
 (defclass redisplay-frame-mixin ()
    ())
 
@@ -469,12 +474,31 @@
           (format t "~A" o)))
       (format t "~A" o)))
 
+(define-presentation-type channel () :inherit-from 'string)
+
+(define-presentation-method presentation-typep (object (type channel))
+  (channelp object))
+
+(defun channelp (channel)
+  (and (stringp channel)
+       (> (length channel) 2)
+       (not (null (member (char channel 0) '(#\# #\+ #\! #\&))))))
+
+(define-presentation-method accept ((type channel) *standard-input* (view textual-view) &key)
+  (let ((channel (accept 'string :view view :prompt nil)))
+    (if (not (presentation-typep channel 'channel))
+        (input-not-of-required-type channel 'channel)
+        channel)))
+
 (define-beirc-command (com-query :name t) ((nick 'nickname :prompt "who"))
   (raise-receiver (intern-receiver nick *application-frame* :query nick)))
 
 (define-beirc-command (com-raise :name t) ((receiver 'receiver :prompt "receiver"))
   (raise-receiver receiver))
 
+(define-beirc-command (com-close :name t) ((receiver 'receiver :prompt "receiver"))
+  (remove-receiver receiver *application-frame*))
+
 (define-beirc-command (com-focus :name t) ((who 'nickname :prompt "who"))
   (pushnew who (current-focused-nicks) :test #'string=))
 
@@ -495,8 +519,30 @@
     (when (eql status :external)
       (apply symbol (current-connection *application-frame*) (coerce args 'list)))))
 
-(define-beirc-command (com-topic :name t) ((topic 'mumble :prompt "topic"))
-  (irc:topic- (current-connection *application-frame*) (target) topic))
+(defun make-fake-irc-message (message-type &key command arguments
+                              (source (slot-value *application-frame* 'nick))
+                              trailing-argument)
+  (make-instance message-type
+     :received-time (get-universal-time)
+     :connection :local
+     :trailing-argument trailing-argument
+     :arguments arguments
+     :command command
+     :HOST "localhost"
+     :USER "localuser"
+     :SOURCE source))
+
+(define-beirc-command (com-topic :name t) (&key (topic 'mumble :prompt "New topic"))
+  (if (and (not (string= topic "")))
+        (irc:topic- (current-connection *application-frame*) (target) topic)
+        (post-message *application-frame*
+                      (make-fake-irc-message 'irc:irc-rpl_topic-message
+                         :command "332"
+                         :arguments `("=" ,(target))
+                         :trailing-argument (irc:topic
+                                             (irc:find-channel
+                                              (current-connection *application-frame*)
+                                              (target)))))))
 
 (define-beirc-command (com-op :name t) ((who 'nickname :prompt "who"))
   (irc:op (current-connection *application-frame*) (target) who))
@@ -523,16 +569,10 @@
 (define-beirc-command (com-say :name t) ((what 'mumble))
   ;; make a fake IRC-PRIV-MESSAGE object
   (post-message *application-frame*
-                (make-instance 'irc:irc-privmsg-message
-                               :received-time (get-universal-time)
-                               :connection :local
-                               :trailing-argument what
-                               :arguments (list (target))
-                               :command "PRIVMSG"
-                               :HOST "localhost"
-                               :USER "localuser"
-                               :SOURCE (slot-value *application-frame* 'nick)
-                               ))
+                (make-fake-irc-message 'irc:irc-privmsg-message
+                                       :trailing-argument what
+                                       :arguments (list (target))
+                                       :command "PRIVMSG"))
   (irc:privmsg (current-connection *application-frame*) (target) what))
 
 (define-beirc-command (com-nick :name t) ((new-nick 'string :prompt "new nick"))
@@ -581,7 +621,7 @@
    (presentation)
   (list (presentation-object presentation)))
 
-(define-beirc-command (com-join :name t) ((channel 'string :prompt "channel"))
+(define-beirc-command (com-join :name t) ((channel 'channel :prompt "channel"))
   (raise-receiver (intern-receiver channel *application-frame* :channel channel))
   (irc:join (current-connection *application-frame*) channel))
 
@@ -609,26 +649,18 @@
                                           :name "IRC Message Muffling Loop")) )))))
 
 (defun disconnect (frame)
-  (let ((old-nickname (slot-value frame 'nick)))
-    (raise-receiver (server-receiver frame))
-    (post-message frame
-                  (make-instance 'irc:irc-quit-message
-                     :received-time (get-universal-time)
-                     :connection :local
-                     :trailing-argument
-                     (format nil "You disconnected from IRC")
-                     :arguments nil
-                     :command "QUIT"
-                     :host "localhost" ;###
-                     :user "localuser" ;###
-                     :source old-nickname))
-    (when (and (connection-process frame)
-               (not (eql (clim-sys:current-process)
-                         (connection-process frame))))
-      (destroy-process (connection-process frame)))
-    (setf (slot-value frame 'connection) nil
-          (connection-process frame) nil
-          (slot-value frame 'nick) nil)))
+  (raise-receiver (server-receiver frame))
+  (post-message frame
+                (make-fake-irc-message 'irc:irc-quit-message
+                                       :trailing-argument "You disconnected from IRC"
+                                       :command "QUIT"))
+  (when (and (connection-process frame)
+             (not (eql (clim-sys:current-process)
+                       (connection-process frame))))
+    (destroy-process (connection-process frame)))
+  (setf (slot-value frame 'connection) nil
+        (connection-process frame) nil
+        (slot-value frame 'nick) nil))
 
 (defun quit (frame reason)
   (raise-receiver (server-receiver frame))
@@ -725,32 +757,22 @@
                  (write-char (read-char) bag)))))))
 
 (define-beirc-command (com-me :name t) ((what 'mumble))
-  (with-slots (connection nick) *application-frame*
-    (let ((m (make-instance 'irc:ctcp-action-message
-                            :received-time (get-universal-time)
-                            :connection :local
-                            :trailing-argument
-			    (format nil "~AACTION ~A~A" (code-char 1) what (code-char 1))
-                            :arguments (list (target))
-                            :command "PRIVMSG"
-                            :host "localhost" ;###
-                            :user "localuser" ;###
-                            :source nick))) ;###
+  (with-slots (connection) *application-frame*
+    (let ((m (make-fake-irc-message 'irc:ctcp-action-message
+                                    :trailing-argument
+                                    (format nil "~AACTION ~A~A" (code-char 1) what (code-char 1))
+                                    :arguments (list (target))
+                                    :command "PRIVMSG"))) ;###
       (post-message *application-frame* m)
       (irc:privmsg connection (target)
                    (format nil "~AACTION ~A~A" (code-char 1) what (code-char 1))))))
 
 (defun send-private-message (target what)
   (post-message *application-frame*
-                (make-instance 'irc:irc-privmsg-message
-                               :received-time (get-universal-time)
-                               :connection :local
-                               :trailing-argument what
-                               :arguments (list target)
-                               :command "PRIVMSG"
-                               :HOST "localhost"
-                               :USER "localuser"
-                               :SOURCE (slot-value *application-frame* 'nick) ))
+                (make-fake-irc-message 'irc:irc-privmsg-message
+                                       :trailing-argument what
+                                       :arguments (list target)
+                                       :command "PRIVMSG"))
   (irc:privmsg (current-connection *application-frame*) target what))
 
 (define-beirc-command (com-msg :name t)


Index: beirc/message-display.lisp
diff -u beirc/message-display.lisp:1.9 beirc/message-display.lisp:1.10
--- beirc/message-display.lisp:1.9	Sat Sep 24 17:04:06 2005
+++ beirc/message-display.lisp	Sat Sep 24 19:28:38 2005
@@ -206,13 +206,20 @@
              (format t " left ~A: ~A" (first (irc:arguments message)) (irc:trailing-argument message))))))
 
 (defmethod print-message ((message irc:irc-mode-message) receiver)
-  (destructuring-bind (target modes args) (irc:arguments message)
-    (declare (ignore target))
-    (formatting-message (t message receiver)
-            ((format t "   "))
-            ((with-drawing-options (*standard-output* :ink +gray33+ :text-size :small)
-               (present (irc:source message) 'nickname)
-               (format-message* (format nil " set mode ~A ~A" modes args)))))))
+  (case (length (irc:arguments message))
+    (1 (formatting-message (t message receiver)
+              ((format t "   "))
+              ((with-drawing-options (*standard-output* :ink +gray33+ :text-size :small)
+                 (format-message* (format nil "~A set mode ~A ~A" (irc:source message)
+                                          (irc:trailing-argument message)
+                                          (first (irc:arguments message))))))))
+    (3 (destructuring-bind (target modes args) (irc:arguments message)
+         (declare (ignore target))
+         (formatting-message (t message receiver)
+                ((format t "   "))
+                ((with-drawing-options (*standard-output* :ink +gray33+ :text-size :small)
+                   (present (irc:source message) 'nickname)
+                   (format-message* (format nil " set mode ~A ~A" modes args)))))))))
 
 (defmethod print-message ((message irc:irc-rpl_motd-message) receiver)
   (formatting-message (t message receiver)



From afuchs at common-lisp.net  Sat Sep 24 17:39:36 2005
From: afuchs at common-lisp.net (Andreas Fuchs)
Date: Sat, 24 Sep 2005 19:39:36 +0200 (CEST)
Subject: [beirc-cvs] CVS update: beirc/beirc.lisp 
Message-ID: <20050924173936.EEA1C880DE@common-lisp.net>

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

Modified Files:
	beirc.lisp 
Log Message:
add /part and better /close functionality.

 * /part exits the current channel and leaves the receiver intact.
 * /close closes the receiver and parts the channel (if the closed
   receiver is a channel). The part message from a closed channel goes
   to the server buffer.


Date: Sat Sep 24 19:39:36 2005
Author: afuchs

Index: beirc/beirc.lisp
diff -u beirc/beirc.lisp:1.23 beirc/beirc.lisp:1.24
--- beirc/beirc.lisp:1.23	Sat Sep 24 19:28:38 2005
+++ beirc/beirc.lisp	Sat Sep 24 19:39:36 2005
@@ -178,7 +178,11 @@
 
 (defmethod receiver-for-message ((message irc:irc-part-message) frame)
   (let ((target (first (irc:arguments message))))
-    (intern-receiver target frame :channel target)))
+    (if (and
+         (null (find-receiver target frame))
+         (string= (irc:source message) (slot-value frame 'nick)))
+        (server-receiver frame) ; don't re-open previously closed channels.
+        (intern-receiver target frame :channel target))))
 
 (defmethod receiver-for-message ((message irc:irc-mode-message) frame)
   (case (length (irc:arguments message))
@@ -497,7 +501,15 @@
   (raise-receiver receiver))
 
 (define-beirc-command (com-close :name t) ((receiver 'receiver :prompt "receiver"))
+  (let* ((connection (current-connection *application-frame*))
+         (channel (irc:find-channel connection (title receiver))))
+    (when channel
+      (irc:part connection channel)))
   (remove-receiver receiver *application-frame*))
+
+(define-beirc-command (com-part :name t) ()
+  (irc:part (current-connection *application-frame*)
+            (title (current-receiver *application-frame*))))
 
 (define-beirc-command (com-focus :name t) ((who 'nickname :prompt "who"))
   (pushnew who (current-focused-nicks) :test #'string=))



From afuchs at common-lisp.net  Sat Sep 24 18:13:45 2005
From: afuchs at common-lisp.net (Andreas Fuchs)
Date: Sat, 24 Sep 2005 20:13:45 +0200 (CEST)
Subject: [beirc-cvs] CVS update: beirc/beirc.lisp beirc/message-display.lisp
Message-ID: <20050924181345.7F19A880DE@common-lisp.net>

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

Modified Files:
	beirc.lisp message-display.lisp 
Log Message:
don't highlight the user's nickname in the first column.

Date: Sat Sep 24 20:13:44 2005
Author: afuchs

Index: beirc/beirc.lisp
diff -u beirc/beirc.lisp:1.24 beirc/beirc.lisp:1.25
--- beirc/beirc.lisp:1.24	Sat Sep 24 19:39:36 2005
+++ beirc/beirc.lisp	Sat Sep 24 20:13:44 2005
@@ -437,7 +437,8 @@
     (sleep 1)))
 
 (define-presentation-type nickname ())
-(define-presentation-type ignored-nickname (nickname))
+(define-presentation-type unhighlighted-nickname () :inherit-from 'nickname)
+(define-presentation-type ignored-nickname () :inherit-from 'nickname)
 
 (defun hash-alist (hashtable &aux res)
   (maphash (lambda (k v) (push (cons k v) res)) hashtable)
@@ -471,12 +472,15 @@
               (irc:normalize-nickname (current-connection *application-frame*)
                                       nickname))))
 
+(define-presentation-method present (o (type unhighlighted-nickname) *standard-output* (view textual-view) &key)
+  (write-string o))
+
 (define-presentation-method present (o (type nickname) *standard-output* (view textual-view) &key)
   (if (nick-equals-my-nick-p o)
       (with-drawing-options (t :ink +darkgreen+)
         (with-text-face (t :bold)
-          (format t "~A" o)))
-      (format t "~A" o)))
+          (write-string o)))
+      (write-string o)))
 
 (define-presentation-type channel () :inherit-from 'string)
 


Index: beirc/message-display.lisp
diff -u beirc/message-display.lisp:1.10 beirc/message-display.lisp:1.11
--- beirc/message-display.lisp:1.10	Sat Sep 24 19:28:38 2005
+++ beirc/message-display.lisp	Sat Sep 24 20:13:44 2005
@@ -126,7 +126,7 @@
 	   (if (message-from-focused-nick-p message receiver) :bold :roman))
         (formatting-message (t message receiver)
                 ((write-string start-string *standard-output*)
-                 (present (irc:source message) 'nickname)
+                 (present (irc:source message) 'unhighlighted-nickname)
                  (write-string end-string *standard-output*))
                 ((format-message* (irc:trailing-argument message))))))))
 



From afuchs at common-lisp.net  Sat Sep 24 18:14:28 2005
From: afuchs at common-lisp.net (Andreas Fuchs)
Date: Sat, 24 Sep 2005 20:14:28 +0200 (CEST)
Subject: [beirc-cvs] CVS update: beirc/beirc.lisp 
Message-ID: <20050924181428.07867880DE@common-lisp.net>

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

Modified Files:
	beirc.lisp 
Log Message:
don't display PING messages.

The *Server* buffer should only light up if something important happens, now. 

Date: Sat Sep 24 20:14:28 2005
Author: afuchs

Index: beirc/beirc.lisp
diff -u beirc/beirc.lisp:1.25 beirc/beirc.lisp:1.26
--- beirc/beirc.lisp:1.25	Sat Sep 24 20:13:44 2005
+++ beirc/beirc.lisp	Sat Sep 24 20:14:28 2005
@@ -212,7 +212,8 @@
     cl-irc:irc-rpl_endofinfo-message
     cl-irc:irc-rpl_endofstats-message
     cl-irc:irc-rpl_endofwho-message
-    cl-irc:irc-rpl_endofexceptlist-message))
+    cl-irc:irc-rpl_endofexceptlist-message
+    cl-irc:irc-ping-message))
 
 (defmethod receiver-for-message ((message irc:irc-message) frame)
   (server-receiver frame))



From afuchs at common-lisp.net  Sat Sep 24 19:03:16 2005
From: afuchs at common-lisp.net (Andreas Fuchs)
Date: Sat, 24 Sep 2005 21:03:16 +0200 (CEST)
Subject: [beirc-cvs] CVS update: beirc/beirc.lisp beirc/message-display.lisp
Message-ID: <20050924190316.84B44880DE@common-lisp.net>

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

Modified Files:
	beirc.lisp message-display.lisp 
Log Message:
implement kicking & banning; reorder and group print-message methods

Date: Sat Sep 24 21:03:15 2005
Author: afuchs

Index: beirc/beirc.lisp
diff -u beirc/beirc.lisp:1.26 beirc/beirc.lisp:1.27
--- beirc/beirc.lisp:1.26	Sat Sep 24 20:14:28 2005
+++ beirc/beirc.lisp	Sat Sep 24 21:03:14 2005
@@ -163,18 +163,29 @@
  (define-global-message-receiver-lookup irc:irc-quit-message)
  (define-global-message-receiver-lookup irc:irc-nick-message))
 
-(defmethod receiver-for-message ((message irc:irc-topic-message) frame)
-  (intern-receiver (first (irc:arguments message)) frame :channel (first (irc:arguments message))))
+(macrolet ((define-nth-arg-message-receiver-lookup (&rest clauses)
+               "Defines receiver-for-message methods that return
+               the receiver associated with the nth arg of the
+               irc message or the trailing arg if NTH in the
+               clauses is nil.
 
-(defmethod receiver-for-message ((message irc:irc-rpl_topic-message) frame)
-  (intern-receiver (second (irc:arguments message)) frame :channel (second (irc:arguments message))))
-
-(defmethod receiver-for-message ((message irc:irc-rpl_namreply-message) frame)
-  (intern-receiver (third (irc:arguments message)) frame :channel (third (irc:arguments message))))
-
-(defmethod receiver-for-message ((message irc:irc-join-message) frame)
-  (let ((target (irc:trailing-argument message)))
-    (intern-receiver target frame :channel target)))
+               Each clause must have this format:
+               (nth message-type ...)"
+               `(progn
+                  ,@(loop for (nth . messages) in clauses
+                          do (print messages)
+                          nconc (loop for message-type in messages
+                                      collect
+                                      `(defmethod receiver-for-message ((message ,message-type) frame)
+                                         (let ((target ,(if (numberp nth)
+                                                            `(nth ,nth (irc:arguments message))
+                                                            `(irc:trailing-argument message))))
+                                           (intern-receiver target frame :channel target))))))))
+  (define-nth-arg-message-receiver-lookup
+      (0 irc:irc-topic-message irc:irc-kick-message)
+      (1 irc:irc-rpl_topic-message)
+      (2 irc:irc-rpl_namreply-message)
+      (nil irc:irc-join-message)))
 
 (defmethod receiver-for-message ((message irc:irc-part-message) frame)
   (let ((target (first (irc:arguments message))))
@@ -440,6 +451,8 @@
 (define-presentation-type nickname ())
 (define-presentation-type unhighlighted-nickname () :inherit-from 'nickname)
 (define-presentation-type ignored-nickname () :inherit-from 'nickname)
+(define-presentation-type channel () :inherit-from 'string)
+(define-presentation-type hostmask () :inherit-from 'string)
 
 (defun hash-alist (hashtable &aux res)
   (maphash (lambda (k v) (push (cons k v) res)) hashtable)
@@ -465,6 +478,11 @@
   (receiver-from-tab-pane
          (find-in-tab-panes-list object 'tab-layout-pane)))
 
+(define-presentation-translator nickname-to-hostmask-translator
+    (nickname hostmask beirc)
+    (object)
+  (format nil "*!*@~A" (irc:hostname (irc:find-user (current-connection *application-frame*) object))))
+
 (defun nick-equals-my-nick-p (nickname)
   (and (not (null *application-frame*))
        (not (null (slot-value *application-frame* 'connection)))
@@ -483,8 +501,6 @@
           (write-string o)))
       (write-string o)))
 
-(define-presentation-type channel () :inherit-from 'string)
-
 (define-presentation-method presentation-typep (object (type channel))
   (channelp object))
 
@@ -567,6 +583,15 @@
 (define-beirc-command (com-deop :name t) ((who 'nickname :prompt "who"))
   (irc:deop (current-connection *application-frame*) (target) who))
 
+(define-beirc-command (com-ban-nick :name t) ((who 'nickname :prompt "who"))
+  (irc:ban (current-connection *application-frame*) (target) (format nil "~A!*@*" who)))
+
+(define-beirc-command (com-ban-hostmask :name t) ((who 'hostmask :prompt "hostmask"))
+  (irc:ban (current-connection *application-frame*) (target) who))
+
+(define-beirc-command (com-kick :name t) ((who 'nickname :prompt "who"))
+  (irc:kick (current-connection *application-frame*) (target) who))
+
 (define-beirc-command (com-names :name t) ()
   (irc:names (current-connection *application-frame*) (target)))
 
@@ -662,8 +687,8 @@
                    (clim-sys:make-process #'(lambda ()
                                               (unwind-protect
                                                   (irc-event-loop frame connection)
-                                                (disconnect frame)))
-                                          :name "IRC Message Muffling Loop")) )))))
+                                                (quit frame "IRC event loop terminated.")))
+                                          :name "IRC Message Muffling Loop")))))))
 
 (defun disconnect (frame)
   (raise-receiver (server-receiver frame))


Index: beirc/message-display.lisp
diff -u beirc/message-display.lisp:1.11 beirc/message-display.lisp:1.12
--- beirc/message-display.lisp:1.11	Sat Sep 24 20:13:44 2005
+++ beirc/message-display.lisp	Sat Sep 24 21:03:15 2005
@@ -114,6 +114,8 @@
 	      (incf column))
   (terpri))
 
+;;; privmsg-like messages
+
 (defun print-privmsg-like-message (message receiver start-string end-string)
   (with-drawing-options
       (*standard-output*
@@ -145,6 +147,22 @@
            (format t " ")
            (format-message* matter :start-length (+ 2 (length source)))))))
 
+;;; server messages
+
+(defmethod print-message ((message irc:irc-rpl_motd-message) receiver)
+  (formatting-message (t message receiver)
+          ((format t "~A" (irc:source message)))
+          ((with-drawing-options (*standard-output* :ink +gray33+ :text-size :small)
+             (format t "MOTD: ~A" (irc:trailing-argument message))))))
+
+(defmethod print-message (message receiver)
+  (formatting-message (t message receiver)
+          ((format t "!!! ~A" (irc:source message)))
+          ((with-drawing-options (*standard-output* :ink +red+ :text-size :small)
+             (format t "args: ~A :~A" (irc:arguments message) (irc:trailing-argument message))))))
+
+;;; user-related messages
+
 (defmethod print-message ((message irc:irc-quit-message) receiver)
   (formatting-message (t message receiver)
           ((format t "   "))
@@ -155,22 +173,16 @@
              (format-message* (irc:trailing-argument message)
 			      :start-length (+ 8 (length (irc:source message))))))))
 
-(defmethod print-message ((message irc:irc-join-message) receiver)
-  (formatting-message (t message receiver)
-          ((format t "   "))
-          ((with-drawing-options (*standard-output* :ink +gray33+ :text-size :small)
-             (format t "Join: ")
-             (present (irc:source message) 'nickname)
-             (format t " (~A@~A)" (irc:user message) (irc:host message))))))
-
 (defmethod print-message ((message irc:irc-nick-message) receiver)
   (formatting-message (t message receiver)
-          ((format t "   "))
-          ((with-drawing-options (*standard-output* :ink +gray33+ :text-size :small)
-             (format t "Nick change: ")
-             (present (irc:source message) 'nickname)
-             (format t " (~A@~A) is now known as " (irc:user message) (irc:host message))
-             (present (irc:trailing-argument message) 'nickname)))))
+                      ((format t "   "))
+                      ((with-drawing-options (*standard-output* :ink +gray33+ :text-size :small)
+                         (format t "Nick change: ")
+                         (present (irc:source message) 'nickname)
+                         (format t " (~A@~A) is now known as " (irc:user message) (irc:host message))
+                         (present (irc:trailing-argument message) 'nickname)))))
+
+;;; channel management messages
 
 (defun print-topic (receiver message sender channel topic)
   (formatting-message (t message receiver)
@@ -205,6 +217,25 @@
              (present (irc:source message) 'nickname)
              (format t " left ~A: ~A" (first (irc:arguments message)) (irc:trailing-argument message))))))
 
+(defmethod print-message ((message irc:irc-join-message) receiver)
+  (formatting-message (t message receiver)
+          ((format t "   "))
+          ((with-drawing-options (*standard-output* :ink +gray33+ :text-size :small)
+             (format t "Join: ")
+             (present (irc:source message) 'nickname)
+             (format t " (~A@~A)" (irc:user message) (irc:host message))))))
+
+(defmethod print-message ((message irc:irc-kick-message) receiver)
+  (formatting-message (t message receiver)
+          ((format t "   "))
+          ((with-drawing-options (*standard-output* :ink +gray33+ :text-size :small)
+             (present (irc:source message) 'nickname)
+             (write-string " kicked ")
+             (present (second (irc:arguments message)) 'nickname)
+             (format-message* (format nil ": ~A" (irc:trailing-argument message))
+                              :start-length (+ 9 (length (second (irc:arguments message)))
+                                               (length (irc:source message))))))))
+
 (defmethod print-message ((message irc:irc-mode-message) receiver)
   (case (length (irc:arguments message))
     (1 (formatting-message (t message receiver)
@@ -221,17 +252,7 @@
                    (present (irc:source message) 'nickname)
                    (format-message* (format nil " set mode ~A ~A" modes args)))))))))
 
-(defmethod print-message ((message irc:irc-rpl_motd-message) receiver)
-  (formatting-message (t message receiver)
-          ((format t "~A" (irc:source message)))
-          ((with-drawing-options (*standard-output* :ink +gray33+ :text-size :small)
-             (format t "MOTD: ~A" (irc:trailing-argument message))))))
-
-(defmethod print-message (message receiver)
-  (formatting-message (t message receiver)
-          ((format t "!!! ~A" (irc:source message)))
-          ((with-drawing-options (*standard-output* :ink +red+ :text-size :small)
-             (format t "args: ~A :~A" (irc:arguments message) (irc:trailing-argument message))))))
+;;; the display function (& utilities)
 
 (defgeneric preamble-length (message)
   (:method ((message irc:irc-privmsg-message))
@@ -247,30 +268,4 @@
                                       maximize (preamble-length message))))
     (formatting-table (t)
       (loop for message in messages
-            do (print-message message receiver)))))
-
-
-#|
- (let ((k 100)
-       (n (length messages)))
-   (loop for i below (* k (ceiling n k)) by k do
-     (updating-output (*standard-output*
-                       :unique-id i
-                       :cache-value
-                       (list (min n (+ i k))
-                             (focused-nicks receiver)
-                             (slot-value *application-frame* 'ignored-nicks)
-                             w)
-                       :cache-test #'equal)
-       (loop for j from i below (min n (+ i k)) do
-         (let ((m (elt messages j)))
-           (updating-output (*standard-output*
-                             :unique-id j
-                             :cache-value
-                             (list m
-                                   (focused-nicks receiver)
-                                   (slot-value *application-frame* 'ignored-nicks)
-                                   w)
-                             :cache-test #'equal)
-             (print-message m receiver)))))))
-|#
\ No newline at end of file
+            do (print-message message receiver)))))
\ No newline at end of file



From afuchs at common-lisp.net  Sat Sep 24 19:13:55 2005
From: afuchs at common-lisp.net (Andreas Fuchs)
Date: Sat, 24 Sep 2005 21:13:55 +0200 (CEST)
Subject: [beirc-cvs] CVS update: beirc/beirc.lisp 
Message-ID: <20050924191355.6F11D880DE@common-lisp.net>

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

Modified Files:
	beirc.lisp 
Log Message:
add kick and ban presentation translators for nicknames.

Date: Sat Sep 24 21:13:54 2005
Author: afuchs

Index: beirc/beirc.lisp
diff -u beirc/beirc.lisp:1.27 beirc/beirc.lisp:1.28
--- beirc/beirc.lisp:1.27	Sat Sep 24 21:03:14 2005
+++ beirc/beirc.lisp	Sat Sep 24 21:13:54 2005
@@ -658,6 +658,33 @@
     (object)
   (list object))
 
+(define-presentation-to-command-translator nickname-to-kick-translator
+    (nickname com-kick beirc
+              :gesture :menu
+              :menu t
+              :documentation "Kick this user"
+              :pointer-documentation "Kick this user")
+    (object)
+  (list object))
+
+(define-presentation-to-command-translator nickname-to-ban-nick-translator
+    (nickname com-ban-nick beirc
+              :gesture :menu
+              :menu t
+              :documentation "Ban this user's nickname"
+              :pointer-documentation "Ban this user's nickname")
+    (object)
+  (list object))
+
+(define-presentation-to-command-translator nickname-to-ban-hostmask-translator
+    (nickname com-ban-hostmask beirc
+              :gesture :menu
+              :menu t
+              :documentation "Ban this user's hostmask"
+              :pointer-documentation "Ban this user's hostmask")
+    (object)
+  (list object))
+
 (define-presentation-to-command-translator url-to-browse-url-translator
     (url com-browse-url beirc)
    (presentation)



From afuchs at common-lisp.net  Sat Sep 24 22:30:27 2005
From: afuchs at common-lisp.net (Andreas Fuchs)
Date: Sun, 25 Sep 2005 00:30:27 +0200 (CEST)
Subject: [beirc-cvs] CVS update: beirc/beirc.lisp beirc/message-display.lisp
Message-ID: <20050924223027.6DA42880DE@common-lisp.net>

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

Modified Files:
	beirc.lisp message-display.lisp 
Log Message:
add a customizable variable for timestamp orientation, and fix
redisplay on focus/ignore/etc. command

 * new variable *timestamp-column-orientation* (this is for you, mgr)
 * new command /Switch Timestamp Orientation
 * /S-T-O, /{,un}ignore, /{,un}focus now redraw the panes they affect.
 * comment out the nickname to hostmask ptype translator. for some
   reason it was always activated.


Date: Sun Sep 25 00:30:25 2005
Author: afuchs

Index: beirc/beirc.lisp
diff -u beirc/beirc.lisp:1.28 beirc/beirc.lisp:1.29
--- beirc/beirc.lisp:1.28	Sat Sep 24 21:13:54 2005
+++ beirc/beirc.lisp	Sun Sep 25 00:30:23 2005
@@ -389,6 +389,17 @@
   (scroll-extent pane 0 (max 0 (- (bounding-rectangle-height pane)
                                   (bounding-rectangle-height (sheet-parent pane))))))
 
+(defun redraw-receiver (receiver)
+  (let ((pane (actual-application-pane (pane receiver))))
+    (setf (pane-needs-redisplay pane) t)
+    (redisplay-frame-pane *application-frame* pane)))
+
+(defun redraw-all-receivers ()
+  (maphash (lambda (name receiver)
+             (declare (ignore name))
+             (redraw-receiver receiver))
+           (receivers *application-frame*)))
+
 (defmethod handle-event ((frame beirc) (event foo-event))
   ;; Hack:
   ;; Figure out if we are scrolled to the bottom.
@@ -478,6 +489,8 @@
   (receiver-from-tab-pane
          (find-in-tab-panes-list object 'tab-layout-pane)))
 
+;;; XXX: for some reason, this translator is activated when accepting NICKNAME.
+#+(or)
 (define-presentation-translator nickname-to-hostmask-translator
     (nickname hostmask beirc)
     (object)
@@ -533,18 +546,22 @@
             (title (current-receiver *application-frame*))))
 
 (define-beirc-command (com-focus :name t) ((who 'nickname :prompt "who"))
-  (pushnew who (current-focused-nicks) :test #'string=))
+  (pushnew who (current-focused-nicks) :test #'string=)
+  (redraw-receiver (current-receiver *application-frame*)))
 
 (define-beirc-command (com-ignore :name t) ((who 'nickname :prompt "who"))
-  (pushnew who (slot-value *application-frame* 'ignored-nicks) :test #'string=))
+  (pushnew who (slot-value *application-frame* 'ignored-nicks) :test #'string=)
+  (redraw-all-receivers))
 
 (define-beirc-command (com-unignore :name t) ((who 'ignored-nickname :prompt "who"))
   (setf (slot-value *application-frame* 'ignored-nicks)
-        (remove who (slot-value *application-frame* 'ignored-nicks)  :test #'string=)))
+        (remove who (slot-value *application-frame* 'ignored-nicks)  :test #'string=))
+  (redraw-all-receivers))
 
 (define-beirc-command (com-unfocus :name t) ((who 'nickname :prompt "who"))
   (setf (current-focused-nicks)
-        (remove who (current-focused-nicks) :test #'string=)))
+        (remove who (current-focused-nicks) :test #'string=))
+  (redraw-receiver (current-receiver *application-frame*)))
 
 (define-beirc-command (com-eval :name t) ((command 'string :prompt "command")
                                           (args '(sequence string) :prompt "arguments"))
@@ -604,6 +621,12 @@
   (when (current-connection *application-frame*)
     (quit *application-frame* reason)))
 
+(define-beirc-command (com-switch-timestamp-orientation :name t) ()
+  (setf *timestamp-column-orientation* (if (eql *timestamp-column-orientation* :left)
+                                           :right
+                                           :left))
+  (redraw-all-receivers))
+
 (defun target (&optional (*application-frame* *application-frame*))
   (or (current-query)
       (current-channel)))
@@ -714,7 +737,7 @@
                    (clim-sys:make-process #'(lambda ()
                                               (unwind-protect
                                                   (irc-event-loop frame connection)
-                                                (quit frame "IRC event loop terminated.")))
+                                                (disconnect frame)))
                                           :name "IRC Message Muffling Loop")))))))
 
 (defun disconnect (frame)


Index: beirc/message-display.lisp
diff -u beirc/message-display.lisp:1.12 beirc/message-display.lisp:1.13
--- beirc/message-display.lisp:1.12	Sat Sep 24 21:03:15 2005
+++ beirc/message-display.lisp	Sun Sep 25 00:30:24 2005
@@ -2,6 +2,7 @@
 
 (defparameter *hyperspec-base-url* "file://localhost/Users/dmurray/lisp/HyperSpec/")
 (defparameter *default-fill-column* 80)
+(defparameter *timestamp-column-orientation* :right)
 
 (defvar *max-preamble-length* 0)
 
@@ -34,39 +35,47 @@
   (member (irc:source message) (slot-value *application-frame* 'ignored-nicks)
           :test #'string=))
 
+(defun invoke-formatting-message (stream message receiver preamble-writer message-body-writer)
+  (let* ((stream* (if (eql stream t) *standard-output* stream))
+         (width (- (floor (bounding-rectangle-width (sheet-parent stream*))
+                          (clim:stream-string-width stream* "X"))
+                   2)))
+    (labels ((output-timestamp-column (position)
+               (when (eql position *timestamp-column-orientation*)
+                 (formatting-cell (stream* :align-x :left)
+                   (with-drawing-options (stream* :ink +gray+)
+                     (format stream* "[~2,'0D:~2,'0D]"
+                             (nth-value 2 (decode-universal-time (irc:received-time message)))
+                             (nth-value 1 (decode-universal-time (irc:received-time message)))))))))
+      (updating-output (stream* 
+                        :cache-value
+                        (list message
+                              (focused-nicks receiver)
+                              (slot-value *application-frame* 'ignored-nicks)
+                              width
+                              *max-preamble-length*
+                              *timestamp-column-orientation*)
+                        :cache-test #'equal)
+        (formatting-row (stream*)
+          (output-timestamp-column :left)
+          (formatting-cell (stream* :align-x :right :min-width '(16 :character))
+            (with-drawing-options (stream* :ink +dark-red+)
+              (funcall preamble-writer)))
+          (formatting-cell (stream* :align-x :left
+                                    :min-width '(80 :character))
+            (funcall message-body-writer))
+          (output-timestamp-column :right))))))
+
 (defmacro formatting-message ((stream message receiver)
                               (&body preamble-column-body)
                               (&body message-body-column-body))
   ;; Fix me: This usage of UPDATING-OUTPUT is sub-optimal and ugly!
   ;; (asf 2005-09-17: is it still?)
-  (let ((width (gensym))
-        (%stream% (gensym))
-        (stream* (gensym)))
-    `(let* ((,%stream% ,stream)
-            (,stream* (if (eql ,%stream% t) *standard-output* ,%stream%))
-            (,width (- (floor (bounding-rectangle-width (sheet-parent ,stream*))
-                              (clim:stream-string-width ,stream* "X"))
-                       2)))
-       (updating-output (,stream* 
-                         :cache-value
-                         (list ,message
-                               (focused-nicks ,receiver)
-                               (slot-value *application-frame* 'ignored-nicks)
-                               ,width
-                               *max-preamble-length*)
-                         :cache-test #'equal)
-         (formatting-row (,stream*)
-           (formatting-cell (,stream* :align-x :right :min-width '(16 :character))
-             (with-drawing-options (,stream* :ink +dark-red+)
-               , at preamble-column-body))
-           (formatting-cell (,stream* :align-x :left
-				      :min-width '(80 :character))
-             , at message-body-column-body)
-	   (formatting-cell (,stream* :align-x :left)
-             (with-drawing-options (,stream* :ink +gray+)
-	       (format ,stream* "[~2,'0D:~2,'0D]"
-		       (nth-value 2 (decode-universal-time (irc:received-time message)))
-		       (nth-value 1 (decode-universal-time (irc:received-time message)))))))))))
+  `(invoke-formatting-message ,stream ,message ,receiver
+                              (lambda ()
+                                , at preamble-column-body)
+                              (lambda ()
+                                , at message-body-column-body)))
 
 (defun strip-punctuation (word)
   (if (= (length word) 0)



From afuchs at common-lisp.net  Sun Sep 25 12:31:14 2005
From: afuchs at common-lisp.net (Andreas Fuchs)
Date: Sun, 25 Sep 2005 14:31:14 +0200 (CEST)
Subject: [beirc-cvs] CVS update: beirc/beirc.lisp 
Message-ID: <20050925123114.728848853E@common-lisp.net>

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



From afuchs at common-lisp.net  Sun Sep 25 12:43:54 2005
From: afuchs at common-lisp.net (Andreas Fuchs)
Date: Sun, 25 Sep 2005 14:43:54 +0200 (CEST)
Subject: [beirc-cvs] CVS update: beirc/application.lisp
	beirc/presentations.lisp beirc/receivers.lisp
	beirc/variables.lisp beirc/beirc.asd
	beirc/message-display.lisp beirc/beirc.lisp 
Message-ID: <20050925124354.C598B8853E@common-lisp.net>

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

Modified Files:
	beirc.asd message-display.lisp 
Added Files:
	application.lisp presentations.lisp receivers.lisp 
	variables.lisp 
Removed Files:
	beirc.lisp 
Log Message:
Split beirc.lisp further (and remove it):

 * application-frame, irc functions and clim commands are in application.lisp
 * receiver functions are in receivers.lisp
 * presentation types and presentation methods are in presentations.lisp.
 * user-customizable variables are in variables.lisp.

Date: Sun Sep 25 14:43:53 2005
Author: afuchs









Index: beirc/beirc.asd
diff -u beirc/beirc.asd:1.3 beirc/beirc.asd:1.4
--- beirc/beirc.asd:1.3	Fri Sep 23 21:05:15 2005
+++ beirc/beirc.asd	Sun Sep 25 14:43:52 2005
@@ -8,5 +8,8 @@
 (defsystem :beirc
   :depends-on (:mcclim :cl-irc :split-sequence :tab-layout)
   :components ((:file "package")
-               (:file "beirc" :depends-on ("package"))
-               (:file "message-display" :depends-on ("package" "beirc"))))
\ No newline at end of file
+               (:file "variables" :depends-on ("package"))
+               (:file "receivers" :depends-on ("package" "variables"))
+               (:file "presentations" :depends-on ("package" "variables"))
+               (:file "message-display" :depends-on ("package" "variables" "presentations"))
+               (:file "application" :depends-on ("package" "variables" "presentations" "receivers"))))
\ No newline at end of file


Index: beirc/message-display.lisp
diff -u beirc/message-display.lisp:1.13 beirc/message-display.lisp:1.14
--- beirc/message-display.lisp:1.13	Sun Sep 25 00:30:24 2005
+++ beirc/message-display.lisp	Sun Sep 25 14:43:52 2005
@@ -1,9 +1,5 @@
 (in-package :beirc)
 
-(defparameter *hyperspec-base-url* "file://localhost/Users/dmurray/lisp/HyperSpec/")
-(defparameter *default-fill-column* 80)
-(defparameter *timestamp-column-orientation* :right)
-
 (defvar *max-preamble-length* 0)
 
 (define-presentation-type url ()





From afuchs at common-lisp.net  Sun Sep 25 12:55:11 2005
From: afuchs at common-lisp.net (Andreas Fuchs)
Date: Sun, 25 Sep 2005 14:55:11 +0200 (CEST)
Subject: [beirc-cvs] CVS update: beirc/message-display.lisp
	beirc/package.lisp beirc/variables.lisp 
Message-ID: <20050925125511.AA0F18853E@common-lisp.net>

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

Modified Files:
	message-display.lisp package.lisp variables.lisp 
Log Message:
Load a beirc customization file when the system is loaded. (possibly
not the perfect way to do it.)

Also, add the *default-fill-column* to the updating-output form, so
that changing the fill column redraws all columns.

Date: Sun Sep 25 14:55:10 2005
Author: afuchs

Index: beirc/message-display.lisp
diff -u beirc/message-display.lisp:1.14 beirc/message-display.lisp:1.15
--- beirc/message-display.lisp:1.14	Sun Sep 25 14:43:52 2005
+++ beirc/message-display.lisp	Sun Sep 25 14:55:10 2005
@@ -50,7 +50,8 @@
                               (slot-value *application-frame* 'ignored-nicks)
                               width
                               *max-preamble-length*
-                              *timestamp-column-orientation*)
+                              *timestamp-column-orientation*
+                              *default-fill-column*)
                         :cache-test #'equal)
         (formatting-row (stream*)
           (output-timestamp-column :left)
@@ -58,7 +59,7 @@
             (with-drawing-options (stream* :ink +dark-red+)
               (funcall preamble-writer)))
           (formatting-cell (stream* :align-x :left
-                                    :min-width '(80 :character))
+                                    :min-width `(,*default-fill-column* :character))
             (funcall message-body-writer))
           (output-timestamp-column :right))))))
 


Index: beirc/package.lisp
diff -u beirc/package.lisp:1.2 beirc/package.lisp:1.3
--- beirc/package.lisp:1.2	Fri Sep 23 21:05:15 2005
+++ beirc/package.lisp	Sun Sep 25 14:55:10 2005
@@ -1,3 +1,4 @@
 (cl:defpackage :beirc
     (:use :clim :clim-lisp :clim-sys :tab-layout)
-    (:export #:beirc))
+    (:export #:beirc
+             #:*hyperspec-base-url* #:*default-fill-column* #:*timestamp-column-orientation*))


Index: beirc/variables.lisp
diff -u beirc/variables.lisp:1.1 beirc/variables.lisp:1.2
--- beirc/variables.lisp:1.1	Sun Sep 25 14:43:52 2005
+++ beirc/variables.lisp	Sun Sep 25 14:55:10 2005
@@ -3,3 +3,9 @@
 (defparameter *hyperspec-base-url* "file://localhost/Users/dmurray/lisp/HyperSpec/")
 (defparameter *default-fill-column* 80)
 (defparameter *timestamp-column-orientation* :right)
+
+(defvar *beirc-user-init-file* (merge-pathnames (make-pathname :name ".beirc.lisp")
+                                                (user-homedir-pathname)))
+
+(when (probe-file *beirc-user-init-file*)
+  (load *beirc-user-init-file*))
\ No newline at end of file



From afuchs at common-lisp.net  Sun Sep 25 15:09:02 2005
From: afuchs at common-lisp.net (Andreas Fuchs)
Date: Sun, 25 Sep 2005 17:09:02 +0200 (CEST)
Subject: [beirc-cvs] CVS update: beirc/application.lisp 
Message-ID: <20050925150902.C624E88545@common-lisp.net>

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

Modified Files:
	application.lisp 
Log Message:
add an :around method to read-frame-command.

This innocent-sounding summary line enables clicking on presentations
without having to enter / first. WOO YAY!

Date: Sun Sep 25 17:09:01 2005
Author: afuchs

Index: beirc/application.lisp
diff -u beirc/application.lisp:1.1 beirc/application.lisp:1.2
--- beirc/application.lisp:1.1	Sun Sep 25 14:43:52 2005
+++ beirc/application.lisp	Sun Sep 25 17:09:01 2005
@@ -507,6 +507,14 @@
                  (list 'com-say (read-line stream))))))
     (window-clear stream)))
 
+(defmethod read-frame-command :around ((frame beirc)
+				       &key (stream *standard-input*))
+  (with-input-context ('command) (object)
+      (call-next-method)
+    (command
+     (window-clear stream)
+     object)))
+
 (defun restart-beirc ()
   (clim-sys:destroy-process *gui-process*)
   (setf *beirc-frame* nil)



From afuchs at common-lisp.net  Sun Sep 25 15:48:33 2005
From: afuchs at common-lisp.net (Andreas Fuchs)
Date: Sun, 25 Sep 2005 17:48:33 +0200 (CEST)
Subject: [beirc-cvs] CVS update: beirc/application.lisp beirc/beirc.asd
	beirc/presentations.lisp 
Message-ID: <20050925154833.A7EF988556@common-lisp.net>

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

Modified Files:
	application.lisp beirc.asd presentations.lisp 
Log Message:
quit if the application frame is exited with an active connection.

also, rearrange presentations.lisp a bit and add a missing asdf
dependency.


Date: Sun Sep 25 17:48:32 2005
Author: afuchs

Index: beirc/application.lisp
diff -u beirc/application.lisp:1.2 beirc/application.lisp:1.3
--- beirc/application.lisp:1.2	Sun Sep 25 17:09:01 2005
+++ beirc/application.lisp	Sun Sep 25 17:48:32 2005
@@ -224,6 +224,8 @@
                                                              :name "Beirc Ticker")))
                  (setf *beirc-frame* frame)
                  (run-frame-top-level frame)
+                 (unless (null (current-connection frame))
+                   (irc:quit (current-connection frame) "Client Quit"))
                  (clim-sys:destroy-process ticker-process))))))))
 
 (defun message-directed-to-me-p (frame message)
@@ -443,6 +445,19 @@
    (presentation)
   (list (presentation-object presentation)))
 
+(define-presentation-translator receiver-pane-to-receiver-translator
+    (receiver-pane receiver beirc)
+    (object)
+  (receiver-from-tab-pane
+         (find-in-tab-panes-list object 'tab-layout-pane)))
+
+#+(or) ; XXX: for some reason, this translator is activated when accepting NICKNAME.
+(define-presentation-translator nickname-to-hostmask-translator
+    (nickname hostmask beirc)
+    (object)
+  (format nil "*!*@~A" (irc:hostname (irc:find-user (current-connection *application-frame*) object))))
+
+
 (define-beirc-command (com-join :name t) ((channel 'channel :prompt "channel"))
   (raise-receiver (intern-receiver channel *application-frame* :channel channel))
   (irc:join (current-connection *application-frame*) channel))
@@ -587,17 +602,6 @@
     (redisplay-frame-pane (pane-frame pane) pane)))
 
 ;;;;;;
-
-(define-presentation-type mumble ())
-
-(define-presentation-method accept ((type mumble) *standard-input* (view textual-view) &key)
-  (with-output-to-string (bag)
-    (loop
-        (let ((c (peek-char nil)))
-          (cond ((char= c #\newline)
-                 (return))
-                (t
-                 (write-char (read-char) bag)))))))
 
 (define-beirc-command (com-me :name t) ((what 'mumble))
   (with-slots (connection) *application-frame*


Index: beirc/beirc.asd
diff -u beirc/beirc.asd:1.4 beirc/beirc.asd:1.5
--- beirc/beirc.asd:1.4	Sun Sep 25 14:43:52 2005
+++ beirc/beirc.asd	Sun Sep 25 17:48:32 2005
@@ -10,6 +10,6 @@
   :components ((:file "package")
                (:file "variables" :depends-on ("package"))
                (:file "receivers" :depends-on ("package" "variables"))
-               (:file "presentations" :depends-on ("package" "variables"))
+               (:file "presentations" :depends-on ("package" "variables" "receivers"))
                (:file "message-display" :depends-on ("package" "variables" "presentations"))
                (:file "application" :depends-on ("package" "variables" "presentations" "receivers"))))


Index: beirc/presentations.lisp
diff -u beirc/presentations.lisp:1.1 beirc/presentations.lisp:1.2
--- beirc/presentations.lisp:1.1	Sun Sep 25 14:43:52 2005
+++ beirc/presentations.lisp	Sun Sep 25 17:48:32 2005
@@ -1,5 +1,7 @@
 (in-package :beirc)
 
+(define-presentation-type mumble ())
+
 (define-presentation-type nickname ())
 (define-presentation-type unhighlighted-nickname () :inherit-from 'nickname)
 (define-presentation-type ignored-nickname () :inherit-from 'nickname)
@@ -10,6 +12,19 @@
   (maphash (lambda (k v) (push (cons k v) res)) hashtable)
   res)
 
+;;; mumble
+
+(define-presentation-method accept ((type mumble) *standard-input* (view textual-view) &key)
+  (with-output-to-string (bag)
+    (loop
+        (let ((c (peek-char nil)))
+          (cond ((char= c #\newline)
+                 (return))
+                (t
+                 (write-char (read-char) bag)))))))
+
+;;; nicknames
+
 (define-presentation-method accept ((type nickname) *standard-input* (view textual-view) &key)
   (with-slots (connection nick) *application-frame*
     (let ((users (unless (null (current-channel))
@@ -20,23 +35,6 @@
   (with-slots (ignored-nicks) *application-frame*
     (accept `(member , at ignored-nicks) :prompt nil)))
 
-(define-presentation-method accept ((type receiver) *standard-input* (view textual-view) &key)
-  (completing-from-suggestions (*standard-input* :partial-completers '(#\Space))
-    (maphash #'suggest (receivers *application-frame*))))
-
-(define-presentation-translator receiver-pane-to-receiver-translator
-    (receiver-pane receiver beirc)
-    (object)
-  (receiver-from-tab-pane
-         (find-in-tab-panes-list object 'tab-layout-pane)))
-
-;;; XXX: for some reason, this translator is activated when accepting NICKNAME.
-#+(or)
-(define-presentation-translator nickname-to-hostmask-translator
-    (nickname hostmask beirc)
-    (object)
-  (format nil "*!*@~A" (irc:hostname (irc:find-user (current-connection *application-frame*) object))))
-
 (defun nick-equals-my-nick-p (nickname)
   (and (not (null *application-frame*))
        (not (null (slot-value *application-frame* 'connection)))
@@ -54,6 +52,14 @@
         (with-text-face (t :bold)
           (write-string o)))
       (write-string o)))
+
+;;; receivers
+
+(define-presentation-method accept ((type receiver) *standard-input* (view textual-view) &key)
+  (completing-from-suggestions (*standard-input* :partial-completers '(#\Space))
+    (maphash #'suggest (receivers *application-frame*))))
+
+;;; channels
 
 (define-presentation-method presentation-typep (object (type channel))
   (channelp object))



From afuchs at common-lisp.net  Sun Sep 25 16:08:03 2005
From: afuchs at common-lisp.net (Andreas Fuchs)
Date: Sun, 25 Sep 2005 18:08:03 +0200 (CEST)
Subject: [beirc-cvs] CVS update: beirc/application.lisp 
Message-ID: <20050925160803.5F77588545@common-lisp.net>

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

Modified Files:
	application.lisp 
Log Message:
remove the ugly DISCONNECT function. it did the wrong thing, anyway.

Date: Sun Sep 25 18:07:58 2005
Author: afuchs

Index: beirc/application.lisp
diff -u beirc/application.lisp:1.3 beirc/application.lisp:1.4
--- beirc/application.lisp:1.3	Sun Sep 25 17:48:32 2005
+++ beirc/application.lisp	Sun Sep 25 18:07:58 2005
@@ -480,25 +480,8 @@
              (setf (gethash "*Server*" (receivers frame)) (server-receiver frame))
              (setf (connection-process *application-frame*)
                    (clim-sys:make-process #'(lambda ()
-                                              (unwind-protect
-                                                  (irc-event-loop frame connection)
-                                                (disconnect frame)))
+                                              (irc-event-loop frame connection))
                                           :name "IRC Message Muffling Loop")))))))
-
-(defun disconnect (frame)
-  (raise-receiver (server-receiver frame))
-  (post-message frame
-                (make-fake-irc-message 'irc:irc-quit-message
-                                       :trailing-argument "You disconnected from IRC"
-                                       :command "QUIT"))
-  (when (and (connection-process frame)
-             (not (eql (clim-sys:current-process)
-                       (connection-process frame))))
-    (destroy-process (connection-process frame)))
-  (setf (slot-value frame 'connection) nil
-        (connection-process frame) nil
-        (slot-value frame 'nick) nil))
-
 (defun quit (frame reason)
   (raise-receiver (server-receiver frame))
   (irc:quit (current-connection frame) reason)



From afuchs at common-lisp.net  Sun Sep 25 16:30:42 2005
From: afuchs at common-lisp.net (Andreas Fuchs)
Date: Sun, 25 Sep 2005 18:30:42 +0200 (CEST)
Subject: [beirc-cvs] CVS update: beirc/application.lisp 
Message-ID: <20050925163042.A134C88545@common-lisp.net>

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

Modified Files:
	application.lisp 
Log Message:
rename QUIT->DISCONNECT and use it from a restart in the irc listener process.

also, use :prompt nil on /Me.

Date: Sun Sep 25 18:30:40 2005
Author: afuchs

Index: beirc/application.lisp
diff -u beirc/application.lisp:1.4 beirc/application.lisp:1.5
--- beirc/application.lisp:1.4	Sun Sep 25 18:07:58 2005
+++ beirc/application.lisp	Sun Sep 25 18:30:40 2005
@@ -346,12 +346,12 @@
 
 (define-beirc-command (com-quit :name t) ((reason 'mumble :prompt "reason"))
   (when (current-connection *application-frame*)
-    (quit *application-frame* reason))
+    (disconnect *application-frame* reason))
   (frame-exit *application-frame*))
 
 (define-beirc-command (com-disconnect :name t) ((reason 'mumble :prompt "reason"))
   (when (current-connection *application-frame*)
-    (quit *application-frame* reason)))
+    (disconnect *application-frame* reason)))
 
 (define-beirc-command (com-switch-timestamp-orientation :name t) ()
   (setf *timestamp-column-orientation* (if (eql *timestamp-column-orientation* :left)
@@ -480,9 +480,13 @@
              (setf (gethash "*Server*" (receivers frame)) (server-receiver frame))
              (setf (connection-process *application-frame*)
                    (clim-sys:make-process #'(lambda ()
-                                              (irc-event-loop frame connection))
+                                              (restart-case
+                                                  (irc-event-loop frame connection)
+                                                (disconnect ()
+                                                  :report "Disconnect from IRC"
+                                                  (disconnect frame "Client Disconnect"))))
                                           :name "IRC Message Muffling Loop")))))))
-(defun quit (frame reason)
+(defun disconnect (frame reason)
   (raise-receiver (server-receiver frame))
   (irc:quit (current-connection frame) reason)
   (when (and (connection-process frame)
@@ -586,7 +590,7 @@
 
 ;;;;;;
 
-(define-beirc-command (com-me :name t) ((what 'mumble))
+(define-beirc-command (com-me :name t) ((what 'mumble :prompt nil))
   (with-slots (connection) *application-frame*
     (let ((m (make-fake-irc-message 'irc:ctcp-action-message
                                     :trailing-argument



From afuchs at common-lisp.net  Sun Sep 25 17:51:36 2005
From: afuchs at common-lisp.net (Andreas Fuchs)
Date: Sun, 25 Sep 2005 19:51:36 +0200 (CEST)
Subject: [beirc-cvs] CVS update: beirc/application.lisp beirc/receivers.lisp
Message-ID: <20050925175136.7D6EC88556@common-lisp.net>

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

Modified Files:
	application.lisp receivers.lisp 
Log Message:
commit mgr's pointer documentation pane patch. Thanks!

Date: Sun Sep 25 19:51:35 2005
Author: afuchs

Index: beirc/application.lisp
diff -u beirc/application.lisp:1.5 beirc/application.lisp:1.6
--- beirc/application.lisp:1.5	Sun Sep 25 18:30:40 2005
+++ beirc/application.lisp	Sun Sep 25 19:51:34 2005
@@ -80,6 +80,7 @@
   (:panes
    (io
     :interactor)
+   (pointer-doc :pointer-documentation)
    (status-bar
     :application
     :display-function 'beirc-status-display
@@ -106,6 +107,7 @@
          (with-tab-layout ('receiver-pane :name 'query)
            ("*Server*" server 'receiver-pane))
          (60 io)
+         (20 pointer-doc)
          (20                            ;<-- Sigh! Bitrot!
           status-bar)))))
 
@@ -446,7 +448,11 @@
   (list (presentation-object presentation)))
 
 (define-presentation-translator receiver-pane-to-receiver-translator
-    (receiver-pane receiver beirc)
+    (receiver-pane receiver beirc
+       :documentation ((object stream)
+                       (format stream "Reiceiver: ~A"
+                               (title (receiver-from-tab-pane
+                                       (find-in-tab-panes-list object 'tab-layout-pane))))))
     (object)
   (receiver-from-tab-pane
          (find-in-tab-panes-list object 'tab-layout-pane)))


Index: beirc/receivers.lisp
diff -u beirc/receivers.lisp:1.1 beirc/receivers.lisp:1.2
--- beirc/receivers.lisp:1.1	Sun Sep 25 14:43:52 2005
+++ beirc/receivers.lisp	Sun Sep 25 19:51:34 2005
@@ -11,6 +11,16 @@
       (pane :reader pane)
       (tab-pane :accessor tab-pane)))
 
+(defun slot-value-or-something (object &key (slot 'name) (something "without name"))
+  (if (slot-boundp object slot)
+      (slot-value object slot)
+      something))
+
+(defmethod print-object ((receiver receiver) stream)
+  (print-unreadable-object (receiver stream :type t)
+    (write-string (slot-value-or-something receiver :slot 'title :something "without title")
+                  stream)))
+
 (define-presentation-type receiver-pane ())
 
 ;;; KLUDGE: make-clim-application-pane doesn't return an application



From afuchs at common-lisp.net  Sun Sep 25 17:55:27 2005
From: afuchs at common-lisp.net (Andreas Fuchs)
Date: Sun, 25 Sep 2005 19:55:27 +0200 (CEST)
Subject: [beirc-cvs] CVS update: beirc/application.lisp
	beirc/message-display.lisp 
Message-ID: <20050925175527.9E9C788556@common-lisp.net>

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

Modified Files:
	application.lisp message-display.lisp 
Log Message:
fix topic display and presentation of URLs within <> brackets

Date: Sun Sep 25 19:55:26 2005
Author: afuchs

Index: beirc/application.lisp
diff -u beirc/application.lisp:1.6 beirc/application.lisp:1.7
--- beirc/application.lisp:1.6	Sun Sep 25 19:51:34 2005
+++ beirc/application.lisp	Sun Sep 25 19:55:26 2005
@@ -317,7 +317,8 @@
      :SOURCE source))
 
 (define-beirc-command (com-topic :name t) (&key (topic 'mumble :prompt "New topic"))
-  (if (and (not (string= topic "")))
+  (if (and (not (null topic))
+           (not (equal topic "")))
         (irc:topic- (current-connection *application-frame*) (target) topic)
         (post-message *application-frame*
                       (make-fake-irc-message 'irc:irc-rpl_topic-message


Index: beirc/message-display.lisp
diff -u beirc/message-display.lisp:1.15 beirc/message-display.lisp:1.16
--- beirc/message-display.lisp:1.15	Sun Sep 25 14:55:10 2005
+++ beirc/message-display.lisp	Sun Sep 25 19:55:26 2005
@@ -84,12 +84,12 @@
                   (string last-char)))
          (otherwise (values word ""))))))
 
-(defun strip-op-signs (word)
+(defun strip-preceding-punctuation (word)
   (if (= (length word) 0)
       (values word "")
       (let ((first-char (char word 0)))
        (case first-char
-         ((#\@ #\+)
+         ((#\@ #\+ #\<)
           (values (subseq word 1)
                   (string first-char)))
          (otherwise (values word ""))))))
@@ -101,9 +101,9 @@
 	when (> column limit)
 	  do (setf column (length word))
 	     (terpri)
-	do (multiple-value-bind (%word stripped-opsigns) (strip-op-signs word)
+	do (multiple-value-bind (%word stripped-preceding-punctuation) (strip-preceding-punctuation word)
              (multiple-value-bind (word% stripped-punctuation) (strip-punctuation %word)
-               (write-string stripped-opsigns)
+               (write-string stripped-preceding-punctuation)
                (cond
                  ((search "http://" word%)
                   (present-url word%))



From afuchs at common-lisp.net  Sun Sep 25 17:58:14 2005
From: afuchs at common-lisp.net (Andreas Fuchs)
Date: Sun, 25 Sep 2005 19:58:14 +0200 (CEST)
Subject: [beirc-cvs] CVS update: beirc/application.lisp 
Message-ID: <20050925175814.CBEB688556@common-lisp.net>

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

Modified Files:
	application.lisp 
Log Message:
don't do anything on /say <nothing>.

Date: Sun Sep 25 19:58:14 2005
Author: afuchs

Index: beirc/application.lisp
diff -u beirc/application.lisp:1.7 beirc/application.lisp:1.8
--- beirc/application.lisp:1.7	Sun Sep 25 19:55:26 2005
+++ beirc/application.lisp	Sun Sep 25 19:58:14 2005
@@ -367,13 +367,13 @@
       (current-channel)))
 
 (define-beirc-command (com-say :name t) ((what 'mumble))
-  ;; make a fake IRC-PRIV-MESSAGE object
-  (post-message *application-frame*
-                (make-fake-irc-message 'irc:irc-privmsg-message
-                                       :trailing-argument what
-                                       :arguments (list (target))
-                                       :command "PRIVMSG"))
-  (irc:privmsg (current-connection *application-frame*) (target) what))
+  (unless (string= what "")
+    (post-message *application-frame*
+                  (make-fake-irc-message 'irc:irc-privmsg-message
+                                         :trailing-argument what
+                                         :arguments (list (target))
+                                         :command "PRIVMSG"))
+    (irc:privmsg (current-connection *application-frame*) (target) what)))
 
 (define-beirc-command (com-nick :name t) ((new-nick 'string :prompt "new nick"))
   (setf (slot-value *application-frame* 'nick) new-nick) ;This is _not_ the way to do it.



From afuchs at common-lisp.net  Sun Sep 25 18:19:29 2005
From: afuchs at common-lisp.net (Andreas Fuchs)
Date: Sun, 25 Sep 2005 20:19:29 +0200 (CEST)
Subject: [beirc-cvs] CVS update: beirc/message-display.lisp
	beirc/receivers.lisp 
Message-ID: <20050925181929.9C33C88556@common-lisp.net>

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

Modified Files:
	message-display.lisp receivers.lisp 
Log Message:

 * handle "you need channel operator status" message right.
 * fix intern-receiver: should always use the normalized-name

Date: Sun Sep 25 20:19:28 2005
Author: afuchs

Index: beirc/message-display.lisp
diff -u beirc/message-display.lisp:1.16 beirc/message-display.lisp:1.17
--- beirc/message-display.lisp:1.16	Sun Sep 25 19:55:26 2005
+++ beirc/message-display.lisp	Sun Sep 25 20:19:28 2005
@@ -190,6 +190,12 @@
 
 ;;; channel management messages
 
+(defmethod print-message ((message irc:irc-err_chanoprivsneeded-message) receiver)
+  (formatting-message (t message receiver)
+          ((format t "    "))
+          ((with-drawing-options (*standard-output* :ink +gray33+ :text-size :small)
+             (format-message* (format nil "Not permitted: ~A" (irc:trailing-argument message)))))))
+
 (defun print-topic (receiver message sender channel topic)
   (formatting-message (t message receiver)
           ((format t "    "))


Index: beirc/receivers.lisp
diff -u beirc/receivers.lisp:1.2 beirc/receivers.lisp:1.3
--- beirc/receivers.lisp:1.2	Sun Sep 25 19:51:34 2005
+++ beirc/receivers.lisp	Sun Sep 25 20:19:28 2005
@@ -72,7 +72,7 @@
                                               :display-time nil
                                               :width 400 :height 600
                                               :incremental-redisplay t)))
-            (setf (gethash name (receivers frame)) receiver)
+            (setf (gethash normalized-name (receivers frame)) receiver)
             receiver)))))
 
 (defun remove-receiver (receiver frame)
@@ -138,7 +138,7 @@
                                            (intern-receiver target frame :channel target))))))))
   (define-nth-arg-message-receiver-lookup
       (0 irc:irc-topic-message irc:irc-kick-message)
-      (1 irc:irc-rpl_topic-message)
+      (1 irc:irc-rpl_topic-message irc:irc-err_chanoprivsneeded-message)
       (2 irc:irc-rpl_namreply-message)
       (nil irc:irc-join-message)))
 
@@ -181,7 +181,11 @@
     cl-irc:irc-rpl_endofexceptlist-message
     cl-irc:irc-ping-message))
 
+
+;;; default receiver.
 (defmethod receiver-for-message ((message irc:irc-message) frame)
+  #+or                    ; comment out to debug on uncaught messages.
+  (break)                   
   (server-receiver frame))
 
 ;; TODO: more receiver-for-message methods.



From afuchs at common-lisp.net  Sun Sep 25 18:21:09 2005
From: afuchs at common-lisp.net (Andreas Fuchs)
Date: Sun, 25 Sep 2005 20:21:09 +0200 (CEST)
Subject: [beirc-cvs] CVS update: beirc/application.lisp 
Message-ID: <20050925182109.76AFB88556@common-lisp.net>

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

Modified Files:
	application.lisp 
Log Message:
add "unfocus" translator by mgr.

Date: Sun Sep 25 20:21:08 2005
Author: afuchs

Index: beirc/application.lisp
diff -u beirc/application.lisp:1.8 beirc/application.lisp:1.9
--- beirc/application.lisp:1.8	Sun Sep 25 19:58:14 2005
+++ beirc/application.lisp	Sun Sep 25 20:21:08 2005
@@ -407,6 +407,15 @@
     (object)
   (list object))
 
+(define-presentation-to-command-translator nickname-to-unfocus-translator
+    (nickname com-unfocus beirc
+              :gesture :menu
+              :menu t
+              :documentation "Unfocus this user"
+              :pointer-documentation "Unfocus this user")
+    (object)
+  (list object))
+
 (define-presentation-to-command-translator nickname-to-query-translator
     (nickname com-query beirc
               :gesture :menu



From afuchs at common-lisp.net  Sun Sep 25 18:53:54 2005
From: afuchs at common-lisp.net (Andreas Fuchs)
Date: Sun, 25 Sep 2005 20:53:54 +0200 (CEST)
Subject: [beirc-cvs] CVS update: beirc/receivers.lisp 
Message-ID: <20050925185354.F422E88556@common-lisp.net>

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

Modified Files:
	receivers.lisp 
Log Message:
fix receiver lookup in the presence of global notices and Chanserv on channels.

Date: Sun Sep 25 20:53:54 2005
Author: afuchs

Index: beirc/receivers.lisp
diff -u beirc/receivers.lisp:1.3 beirc/receivers.lisp:1.4
--- beirc/receivers.lisp:1.3	Sun Sep 25 20:19:28 2005
+++ beirc/receivers.lisp	Sun Sep 25 20:53:53 2005
@@ -70,7 +70,7 @@
                                               (lambda (frame pane)
                                                 (beirc-app-display frame pane receiver))
                                               :display-time nil
-                                              :width 400 :height 600
+                                              :width 600 :height 800
                                               :incremental-redisplay t)))
             (setf (gethash normalized-name (receivers frame)) receiver)
             receiver)))))
@@ -85,26 +85,30 @@
   unless the user has opened a query window to the source
   already.")
 
-(defun network-service-p (source frame)
+(defun from-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)))))
 
+(defun global-notice-p (message target)
+  (and (typep message 'irc:irc-notice-message) (string= target "$*")))
+
 (macrolet ((define-privmsg-receiver-lookup (message-type)
                `(defmethod receiver-for-message ((message ,message-type) frame)
-                  (if (or
-                       (find-receiver (irc:source message) frame)
-                       (not (network-service-p (irc:source message) frame)))
-                      (let* ((mynick (irc:normalize-nickname (current-connection 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)))))
+                    (if (or (find-receiver (irc:source message) frame)
+                            (not (from-network-service-p (irc:source message) frame))
+                            (and (string= nominal-target target)
+                                 (not (global-notice-p 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))



From mretzlaff at common-lisp.net  Sun Sep 25 18:57:26 2005
From: mretzlaff at common-lisp.net (Max-Gerd Retzlaff)
Date: Sun, 25 Sep 2005 20:57:26 +0200 (CEST)
Subject: [beirc-cvs] CVS update: beirc/application.lisp beirc/variables.lisp
Message-ID: <20050925185726.4B6F588556@common-lisp.net>

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

Modified Files:
	application.lisp variables.lisp 
Log Message:
Adds the new variable *default-nick* with the default value "brucio-X"
(where X is a random number below 100).

The second parameter NICK of COM-CONNECT is now a &KEY parameter, the
default being *default-nick*.

Date: Sun Sep 25 20:57:25 2005
Author: mretzlaff

Index: beirc/application.lisp
diff -u beirc/application.lisp:1.9 beirc/application.lisp:1.10
--- beirc/application.lisp:1.9	Sun Sep 25 20:21:08 2005
+++ beirc/application.lisp	Sun Sep 25 20:57:25 2005
@@ -479,7 +479,9 @@
   (irc:join (current-connection *application-frame*) channel))
 
 (define-beirc-command (com-connect :name t)
-    ((server 'string :prompt "Server") (nick 'string :prompt "Nick name"))
+    ((server 'string :prompt "Server")
+     &key
+     (nick 'string :prompt "Nick name" :default *default-nick*))
   (cond ((current-connection *application-frame*)
          (format *query-io* "You are already connected.~%"))
         (t


Index: beirc/variables.lisp
diff -u beirc/variables.lisp:1.2 beirc/variables.lisp:1.3
--- beirc/variables.lisp:1.2	Sun Sep 25 14:55:10 2005
+++ beirc/variables.lisp	Sun Sep 25 20:57:25 2005
@@ -1,8 +1,9 @@
 (in-package :beirc)
 
-(defparameter *hyperspec-base-url* "file://localhost/Users/dmurray/lisp/HyperSpec/")
-(defparameter *default-fill-column* 80)
-(defparameter *timestamp-column-orientation* :right)
+(defvar *hyperspec-base-url* "file://localhost/Users/dmurray/lisp/HyperSpec/")
+(defvar *default-fill-column* 80)
+(defvar *timestamp-column-orientation* :right)
+(defvar *default-nick* (format nil "Brucio-~d" (random 100)))
 
 (defvar *beirc-user-init-file* (merge-pathnames (make-pathname :name ".beirc.lisp")
                                                 (user-homedir-pathname)))



From afuchs at common-lisp.net  Mon Sep 26 08:28:13 2005
From: afuchs at common-lisp.net (Andreas Fuchs)
Date: Mon, 26 Sep 2005 10:28:13 +0200 (CEST)
Subject: [beirc-cvs] CVS update: beirc/application.lisp 
Message-ID: <20050926082813.2B9D98815C@common-lisp.net>

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

Modified Files:
	application.lisp 
Log Message:
replace (read-line ...) with (accept 'mumble ...) in read-frame-command.

this makes RET in the middle of the line work!

Date: Mon Sep 26 10:28:10 2005
Author: afuchs

Index: beirc/application.lisp
diff -u beirc/application.lisp:1.10 beirc/application.lisp:1.11
--- beirc/application.lisp:1.10	Sun Sep 25 20:57:25 2005
+++ beirc/application.lisp	Mon Sep 26 10:28:10 2005
@@ -524,7 +524,7 @@
                  (clim:accept 'clim:command :stream stream
                               :prompt nil))
                 (t
-                 (list 'com-say (read-line stream))))))
+                 (list 'com-say (accept 'mumble :prompt nil :stream stream))))))
     (window-clear stream)))
 
 (defmethod read-frame-command :around ((frame beirc)



From afuchs at common-lisp.net  Mon Sep 26 09:02:41 2005
From: afuchs at common-lisp.net (Andreas Fuchs)
Date: Mon, 26 Sep 2005 11:02:41 +0200 (CEST)
Subject: [beirc-cvs] CVS update: beirc/message-display.lisp 
Message-ID: <20050926090241.C57BD8815C@common-lisp.net>

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

Modified Files:
	message-display.lisp 
Log Message:
present the sender nickname in ctcp-action messages as unhighlighted-nickname.

Date: Mon Sep 26 11:02:41 2005
Author: afuchs

Index: beirc/message-display.lisp
diff -u beirc/message-display.lisp:1.17 beirc/message-display.lisp:1.18
--- beirc/message-display.lisp:1.17	Sun Sep 25 20:19:28 2005
+++ beirc/message-display.lisp	Mon Sep 26 11:02:41 2005
@@ -149,7 +149,7 @@
         (matter (trailing-argument* message)))
     (formatting-message (t message receiver)
           ((format t "*"))
-          ((present source 'nickname)
+          ((present source 'unhighlighted-nickname)
            (format t " ")
            (format-message* matter :start-length (+ 2 (length source)))))))
 



From afuchs at common-lisp.net  Mon Sep 26 09:46:29 2005
From: afuchs at common-lisp.net (Andreas Fuchs)
Date: Mon, 26 Sep 2005 11:46:29 +0200 (CEST)
Subject: [beirc-cvs] CVS update: beirc/application.lisp
	beirc/message-display.lisp beirc/receivers.lisp 
Message-ID: <20050926094629.7417F8815C@common-lisp.net>

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

Modified Files:
	application.lisp message-display.lisp receivers.lisp 
Log Message:
add a /whois command, nick translator, display methods, and a channel->join translator.


Date: Mon Sep 26 11:46:25 2005
Author: afuchs

Index: beirc/application.lisp
diff -u beirc/application.lisp:1.11 beirc/application.lisp:1.12
--- beirc/application.lisp:1.11	Mon Sep 26 10:28:10 2005
+++ beirc/application.lisp	Mon Sep 26 11:46:25 2005
@@ -297,6 +297,9 @@
         (remove who (current-focused-nicks) :test #'string=))
   (redraw-receiver (current-receiver *application-frame*)))
 
+(define-beirc-command (com-whois :name t) ((who 'nickname :prompt "who"))
+  (irc:whois (current-connection *application-frame*) who))
+
 (define-beirc-command (com-eval :name t) ((command 'string :prompt "command")
                                           (args '(sequence string) :prompt "arguments"))
   (multiple-value-bind (symbol status) (find-symbol (string-upcase command) :irc)
@@ -449,6 +452,24 @@
               :menu t
               :documentation "Ban this user's hostmask"
               :pointer-documentation "Ban this user's hostmask")
+    (object)
+  (list object))
+
+(define-presentation-to-command-translator nickname-to-whois-translator
+    (nickname com-whois beirc
+              :gesture :select
+              :menu t
+              :documentation "Perform WHOIS query on user"
+              :pointer-documentation "Perform WHOIS query on user")
+    (object)
+  (list object))
+
+(define-presentation-to-command-translator channel-to-join-translator
+    (channel com-join beirc
+              :gesture :describe
+              :menu t
+              :documentation "Join this channel"
+              :pointer-documentation "Join this channel")
     (object)
   (list object))
 


Index: beirc/message-display.lisp
diff -u beirc/message-display.lisp:1.18 beirc/message-display.lisp:1.19
--- beirc/message-display.lisp:1.18	Mon Sep 26 11:02:41 2005
+++ beirc/message-display.lisp	Mon Sep 26 11:46:25 2005
@@ -112,6 +112,7 @@
                    (and (current-connection *application-frame*)
                         (irc:find-user (current-connection *application-frame*) word%)))
                   (present word% 'nickname))
+                 ((channelp word%) (present word% 'channel))
                  (t (write-string word%)))
                (write-string stripped-punctuation)))
 	   ;; TODO: more highlighting
@@ -153,6 +154,15 @@
            (format t " ")
            (format-message* matter :start-length (+ 2 (length source)))))))
 
+(defmethod print-message ((message irc:ctcp-version-message) receiver)
+  (let ((source (cl-irc:source message)))
+    (formatting-message (t message receiver)
+          ((format t "    "))
+          ((with-drawing-options (*standard-output* :ink +gray33+ :text-size :small)
+             (present source 'unhighlighted-nickname)
+             (format t " ")
+             (format-message* "asked for your IRC client version" :start-length (+ 2 (length source))))))))
+
 ;;; server messages
 
 (defmethod print-message ((message irc:irc-rpl_motd-message) receiver)
@@ -165,7 +175,7 @@
   (formatting-message (t message receiver)
           ((format t "!!! ~A" (irc:source message)))
           ((with-drawing-options (*standard-output* :ink +red+ :text-size :small)
-             (format t "args: ~A :~A" (irc:arguments message) (irc:trailing-argument message))))))
+             (format t "~A ~A :~A" (irc:command message) (irc:arguments message) (irc:trailing-argument message))))))
 
 ;;; user-related messages
 
@@ -187,6 +197,50 @@
                          (present (irc:source message) 'nickname)
                          (format t " (~A@~A) is now known as " (irc:user message) (irc:host message))
                          (present (irc:trailing-argument message) 'nickname)))))
+
+(defmethod print-message ((message irc:irc-rpl_whoisuser-message) receiver)
+  (formatting-message (t message receiver)
+                      ((format t "   "))
+                      ((with-drawing-options (*standard-output* :ink +gray33+ :text-size :small)
+                         (destructuring-bind (me nickname user host &rest args) (irc:arguments message)
+                           (declare (ignore me args))
+                           (present nickname 'nickname)
+                           (format t " is (~A@~A) (~A)" user host (irc:trailing-argument message)))))))
+
+(defmethod print-message ((message irc:irc-rpl_whoischannels-message) receiver)
+  (formatting-message (t message receiver)
+                      ((format t "   "))
+                      ((with-drawing-options (*standard-output* :ink +gray33+ :text-size :small)
+                         (present (second (irc:arguments message)) 'nickname)
+                         (format-message* (format nil " is in ~A" (irc:trailing-argument message))
+                                          :start-length (length (second (irc:arguments message))))))))
+
+(defmethod print-message ((message irc:irc-rpl_whoisserver-message) receiver)
+  (formatting-message (t message receiver)
+                      ((format t "   "))
+                      ((with-drawing-options (*standard-output* :ink +gray33+ :text-size :small)
+                         (present (second (irc:arguments message)) 'nickname)
+                         (format-message* (format nil " is on ~A: ~A"
+                                                  (third (irc:arguments message))
+                                                  (irc:trailing-argument message))
+                                          :start-length (length (second (irc:arguments message))))))))
+
+(defmethod print-message ((message irc:irc-rpl_away-message) receiver)
+  (formatting-message (t message receiver)
+                      ((format t "   "))
+                      ((with-drawing-options (*standard-output* :ink +gray33+ :text-size :small)
+                         (present (second (irc:arguments message)) 'nickname)
+                         (format-message* (format nil "is away: ~A" (irc:trailing-argument message))
+                                          :start-length (length (second (irc:arguments message))))))))
+
+(defmethod print-message ((message irc:irc-rpl_whoisidentified-message) receiver)
+  (formatting-message (t message receiver)
+                      ((format t "   "))
+                      ((with-drawing-options (*standard-output* :ink +gray33+ :text-size :small)
+                         (present (second (irc:arguments message)) 'nickname)
+                         (write-char #\Space)
+                         (format-message* (irc:trailing-argument message)
+                                          :start-length (length (second (irc:arguments message))))))))
 
 ;;; channel management messages
 


Index: beirc/receivers.lisp
diff -u beirc/receivers.lisp:1.4 beirc/receivers.lisp:1.5
--- beirc/receivers.lisp:1.4	Sun Sep 25 20:53:53 2005
+++ beirc/receivers.lisp	Mon Sep 26 11:46:25 2005
@@ -142,7 +142,7 @@
                                            (intern-receiver target frame :channel target))))))))
   (define-nth-arg-message-receiver-lookup
       (0 irc:irc-topic-message irc:irc-kick-message)
-      (1 irc:irc-rpl_topic-message irc:irc-err_chanoprivsneeded-message)
+      (1 irc:irc-rpl_topic-message irc:irc-rpl_topicwhotime-message irc:irc-err_chanoprivsneeded-message irc:irc-err_nosuchnick-message)
       (2 irc:irc-rpl_namreply-message)
       (nil irc:irc-join-message)))
 
@@ -160,6 +160,16 @@
     (3 (destructuring-bind (channel modes args) (irc:arguments message)
          (declare (ignore modes args))
          (intern-receiver channel frame :channel channel)))))
+
+(macrolet ((define-current-receiver-message-types (&rest mtypes)
+               `(progn
+                  ,@(loop for mtype in mtypes
+                          collect `(defmethod receiver-for-message ((message ,mtype) frame)
+                                     (current-receiver frame))))))
+  (define-current-receiver-message-types
+      irc:irc-rpl_whoisuser-message
+      irc:irc-rpl_whoischannels-message
+      irc:irc-rpl_whoisserver-message))
 
 (macrolet ((define-ignore-message-types (&rest mtypes)
              `(progn



From afuchs at common-lisp.net  Mon Sep 26 10:52:06 2005
From: afuchs at common-lisp.net (Andreas Fuchs)
Date: Mon, 26 Sep 2005 12:52:06 +0200 (CEST)
Subject: [beirc-cvs] CVS update: beirc/application.lisp
	beirc/message-display.lisp beirc/receivers.lisp 
Message-ID: <20050926105206.DCEE088549@common-lisp.net>

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

Modified Files:
	application.lisp message-display.lisp receivers.lisp 
Log Message:
add handling for the "no such nick or channel" message.

Date: Mon Sep 26 12:52:05 2005
Author: afuchs

Index: beirc/application.lisp
diff -u beirc/application.lisp:1.12 beirc/application.lisp:1.13
--- beirc/application.lisp:1.12	Mon Sep 26 11:46:25 2005
+++ beirc/application.lisp	Mon Sep 26 12:52:05 2005
@@ -269,6 +269,8 @@
   (raise-receiver receiver))
 
 (define-beirc-command (com-close :name t) ((receiver 'receiver :prompt "receiver"))
+  (when (eql receiver (server-receiver *application-frame*))
+    (error "Can't close the server tab for this application!"))
   (let* ((connection (current-connection *application-frame*))
          (channel (irc:find-channel connection (title receiver))))
     (when channel


Index: beirc/message-display.lisp
diff -u beirc/message-display.lisp:1.19 beirc/message-display.lisp:1.20
--- beirc/message-display.lisp:1.19	Mon Sep 26 11:46:25 2005
+++ beirc/message-display.lisp	Mon Sep 26 12:52:05 2005
@@ -244,10 +244,23 @@
 
 ;;; channel management messages
 
+(defmethod print-message ((message irc:irc-err_nosuchnick-message) receiver)
+  (formatting-message (t message receiver)
+          ((format t "    "))
+          ((with-drawing-options (*standard-output* :ink +red3+ :text-size :small)
+             (let* ((target (second (irc:arguments message)))
+                    (close-p (string= (title receiver)
+                                      (irc:normalize-nickname (current-connection *application-frame*)
+                                                              target))))
+              (format-message* (format nil "No such nick or channel \"~A\". ~@[To close this tab, click ~]"
+                                       target close-p))
+              (when close-p
+                (present `(com-close ,receiver) 'command)))))))
+
 (defmethod print-message ((message irc:irc-err_chanoprivsneeded-message) receiver)
   (formatting-message (t message receiver)
           ((format t "    "))
-          ((with-drawing-options (*standard-output* :ink +gray33+ :text-size :small)
+          ((with-drawing-options (*standard-output* :ink +red3+ :text-size :small)
              (format-message* (format nil "Not permitted: ~A" (irc:trailing-argument message)))))))
 
 (defun print-topic (receiver message sender channel topic)
@@ -267,6 +280,16 @@
 (defmethod print-message ((message irc:irc-rpl_topic-message) receiver)
   (print-topic receiver message nil
                (second (irc:arguments message)) (irc:trailing-argument message)))
+
+(defmethod print-message ((message irc:irc-rpl_topicwhotime-message) receiver)
+  (formatting-message (t message receiver)
+          ((format t "   "))
+          ((with-drawing-options (*standard-output* :ink +gray33+ :text-size :small)
+             (destructuring-bind (me channel who time) (irc:arguments message)
+               (declare (ignore me
+                                time ; TODO: no date display for now.
+                                ))
+              (format-message* (format nil "~A topic set by ~A" channel who)))))))
 
 (defmethod print-message ((message irc:irc-rpl_namreply-message) receiver)
   (formatting-message (t message receiver)


Index: beirc/receivers.lisp
diff -u beirc/receivers.lisp:1.5 beirc/receivers.lisp:1.6
--- beirc/receivers.lisp:1.5	Mon Sep 26 11:46:25 2005
+++ beirc/receivers.lisp	Mon Sep 26 12:52:05 2005
@@ -142,7 +142,7 @@
                                            (intern-receiver target frame :channel target))))))))
   (define-nth-arg-message-receiver-lookup
       (0 irc:irc-topic-message irc:irc-kick-message)
-      (1 irc:irc-rpl_topic-message irc:irc-rpl_topicwhotime-message irc:irc-err_chanoprivsneeded-message irc:irc-err_nosuchnick-message)
+      (1 irc:irc-rpl_topic-message irc:irc-rpl_topicwhotime-message irc:irc-err_chanoprivsneeded-message)
       (2 irc:irc-rpl_namreply-message)
       (nil irc:irc-join-message)))
 
@@ -169,7 +169,8 @@
   (define-current-receiver-message-types
       irc:irc-rpl_whoisuser-message
       irc:irc-rpl_whoischannels-message
-      irc:irc-rpl_whoisserver-message))
+      irc:irc-rpl_whoisserver-message
+      irc:irc-err_nosuchnick-message))
 
 (macrolet ((define-ignore-message-types (&rest mtypes)
              `(progn



From afuchs at common-lisp.net  Tue Sep 27 20:53:42 2005
From: afuchs at common-lisp.net (Andreas Fuchs)
Date: Tue, 27 Sep 2005 22:53:42 +0200 (CEST)
Subject: [beirc-cvs] CVS update: beirc/application.lisp
	beirc/presentations.lisp beirc/receivers.lisp 
Message-ID: <20050927205342.268D688558@common-lisp.net>

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

Modified Files:
	application.lisp presentations.lisp receivers.lisp 
Log Message:
Add nickname tab completion using complete-input and a custom
completion function.

Date: Tue Sep 27 22:53:41 2005
Author: afuchs

Index: beirc/application.lisp
diff -u beirc/application.lisp:1.13 beirc/application.lisp:1.14
--- beirc/application.lisp:1.13	Mon Sep 26 12:52:05 2005
+++ beirc/application.lisp	Tue Sep 27 22:53:41 2005
@@ -352,6 +352,9 @@
 (define-beirc-command (com-names :name t) ()
   (irc:names (current-connection *application-frame*) (target)))
 
+(define-beirc-command (com-away :name t) ((reason 'mumble :prompt "reason"))
+  (irc:away (current-connection *application-frame*) reason))
+
 (define-beirc-command (com-quit :name t) ((reason 'mumble :prompt "reason"))
   (when (current-connection *application-frame*)
     (disconnect *application-frame* reason))


Index: beirc/presentations.lisp
diff -u beirc/presentations.lisp:1.2 beirc/presentations.lisp:1.3
--- beirc/presentations.lisp:1.2	Sun Sep 25 17:48:32 2005
+++ beirc/presentations.lisp	Tue Sep 27 22:53:41 2005
@@ -14,14 +14,54 @@
 
 ;;; mumble
 
+(defun split-input-line (so-far)
+  (multiple-value-bind (word subseq-index)
+      (split-sequence:split-sequence #\Space so-far
+                                     :from-end t
+                                     :remove-empty-subseqs nil
+                                     :count 1)
+    (values (first word)
+            (if (= 0 subseq-index)
+                ""
+                (concatenate 'string (subseq so-far 0 subseq-index) " ")))))
+
+(defun nickname-completer (so-far mode)
+  (multiple-value-bind (word prefix) (split-input-line so-far)
+    (labels ((prefixify (word)
+               (if (zerop (length prefix))
+                   (concatenate 'string word ": ")
+                   (concatenate 'string prefix word " "))))
+      (multiple-value-bind (string success object nmatches possibilities)
+          (complete-from-possibilities word
+                                       (if (not (null (current-channel)))
+                                           (hash-alist
+                                            (irc:users
+                                             (irc:find-channel
+                                              (current-connection *application-frame*)
+                                              (current-channel))))
+                                           nil)
+                                       '()
+                                       :action mode
+                                       :value-key #'cdr)
+        (values (prefixify string)
+                success object nmatches (mapcar (lambda (possibility)
+                                                  (cons (prefixify (car possibility))
+                                                        (cdr possibility)))
+                                                possibilities))))))
+
+;; FIXME/FIXMCCLIM: :possibility-printer is ignored in current
+;; McCLIM's COMPLETE-INPUT implementation.
+#+(or)
+(defun nickname-completion-printer (string object stream)
+  (declare (ignore string))
+  (present (irc:name object) 'nickname :stream stream))
+
 (define-presentation-method accept ((type mumble) *standard-input* (view textual-view) &key)
-  (with-output-to-string (bag)
-    (loop
-        (let ((c (peek-char nil)))
-          (cond ((char= c #\newline)
-                 (return))
-                (t
-                 (write-char (read-char) bag)))))))
+  (let ((*completion-gestures* '(#\Tab)))
+      (nth-value 2
+                 (complete-input *standard-input* 'nickname-completer
+                                 #+(or):possibility-printer #+(or) 'nickname-competion-printer
+                                 :allow-any-input t))))
 
 ;;; nicknames
 


Index: beirc/receivers.lisp
diff -u beirc/receivers.lisp:1.6 beirc/receivers.lisp:1.7
--- beirc/receivers.lisp:1.6	Mon Sep 26 12:52:05 2005
+++ beirc/receivers.lisp	Tue Sep 27 22:53:41 2005
@@ -170,6 +170,7 @@
       irc:irc-rpl_whoisuser-message
       irc:irc-rpl_whoischannels-message
       irc:irc-rpl_whoisserver-message
+      irc:irc-rpl_whoisidentified-message
       irc:irc-err_nosuchnick-message))
 
 (macrolet ((define-ignore-message-types (&rest mtypes)



From afuchs at common-lisp.net  Tue Sep 27 20:58:43 2005
From: afuchs at common-lisp.net (Andreas Fuchs)
Date: Tue, 27 Sep 2005 22:58:43 +0200 (CEST)
Subject: [beirc-cvs] CVS update: beirc/presentations.lisp 
Message-ID: <20050927205843.962A788558@common-lisp.net>

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

Modified Files:
	presentations.lisp 
Log Message:
fix case in completion results.

This means that completion is now case-insensitive and always
completes to the correct case.

Date: Tue Sep 27 22:58:42 2005
Author: afuchs

Index: beirc/presentations.lisp
diff -u beirc/presentations.lisp:1.3 beirc/presentations.lisp:1.4
--- beirc/presentations.lisp:1.3	Tue Sep 27 22:53:41 2005
+++ beirc/presentations.lisp	Tue Sep 27 22:58:41 2005
@@ -43,7 +43,9 @@
                                        '()
                                        :action mode
                                        :value-key #'cdr)
-        (values (prefixify string)
+        (values (if (null object)
+                    (prefixify string)
+                    (prefixify (irc:nickname object)))
                 success object nmatches (mapcar (lambda (possibility)
                                                   (cons (prefixify (car possibility))
                                                         (cdr possibility)))
@@ -54,7 +56,7 @@
 #+(or)
 (defun nickname-completion-printer (string object stream)
   (declare (ignore string))
-  (present (irc:name object) 'nickname :stream stream))
+  (present (irc:nickname object) 'nickname :stream stream))
 
 (define-presentation-method accept ((type mumble) *standard-input* (view textual-view) &key)
   (let ((*completion-gestures* '(#\Tab)))



From afuchs at common-lisp.net  Wed Sep 28 19:33:29 2005
From: afuchs at common-lisp.net (Andreas Fuchs)
Date: Wed, 28 Sep 2005 21:33:29 +0200 (CEST)
Subject: [beirc-cvs] CVS update: beirc/application.lisp
	beirc/message-display.lisp beirc/presentations.lisp 
Message-ID: <20050928193329.E513D88031@common-lisp.net>

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

Modified Files:
	application.lisp message-display.lisp presentations.lisp 
Log Message:
Fix accepting 'mumble when entering /command args; some style issues; fix
accepting 'nickname when in non-channel buffers.

Date: Wed Sep 28 21:33:28 2005
Author: afuchs

Index: beirc/application.lisp
diff -u beirc/application.lisp:1.14 beirc/application.lisp:1.15
--- beirc/application.lisp:1.14	Tue Sep 27 22:53:41 2005
+++ beirc/application.lisp	Wed Sep 28 21:33:28 2005
@@ -547,8 +547,7 @@
         (let ((c (clim:read-gesture :stream stream :peek-p t)))
           (cond ((eql c #\/)
                  (clim:read-gesture :stream stream)
-                 (clim:accept 'clim:command :stream stream
-                              :prompt nil))
+                 (clim:accept 'clim:command :stream stream :prompt nil))
                 (t
                  (list 'com-say (accept 'mumble :prompt nil :stream stream))))))
     (window-clear stream)))


Index: beirc/message-display.lisp
diff -u beirc/message-display.lisp:1.20 beirc/message-display.lisp:1.21
--- beirc/message-display.lisp:1.20	Mon Sep 26 12:52:05 2005
+++ beirc/message-display.lisp	Wed Sep 28 21:33:28 2005
@@ -230,7 +230,7 @@
                       ((format t "   "))
                       ((with-drawing-options (*standard-output* :ink +gray33+ :text-size :small)
                          (present (second (irc:arguments message)) 'nickname)
-                         (format-message* (format nil "is away: ~A" (irc:trailing-argument message))
+                         (format-message* (format nil " is away: ~A" (irc:trailing-argument message))
                                           :start-length (length (second (irc:arguments message))))))))
 
 (defmethod print-message ((message irc:irc-rpl_whoisidentified-message) receiver)


Index: beirc/presentations.lisp
diff -u beirc/presentations.lisp:1.4 beirc/presentations.lisp:1.5
--- beirc/presentations.lisp:1.4	Tue Sep 27 22:58:41 2005
+++ beirc/presentations.lisp	Wed Sep 28 21:33:28 2005
@@ -33,19 +33,20 @@
                    (concatenate 'string prefix word " "))))
       (multiple-value-bind (string success object nmatches possibilities)
           (complete-from-possibilities word
-                                       (if (not (null (current-channel)))
-                                           (hash-alist
-                                            (irc:users
-                                             (irc:find-channel
-                                              (current-connection *application-frame*)
-                                              (current-channel))))
-                                           nil)
+                                       (let ((channel (and
+                                                       (current-channel)
+                                                       (irc:find-channel
+                                                        (current-connection *application-frame*)
+                                                        (current-channel)))))
+                                        (if (not (null channel))
+                                            (hash-alist (irc:users channel))
+                                            nil))
                                        '()
                                        :action mode
                                        :value-key #'cdr)
-        (values (if (null object)
-                    (prefixify string)
-                    (prefixify (irc:nickname object)))
+        (values (prefixify (if (null object)
+                               string
+                               (irc:nickname object)))
                 success object nmatches (mapcar (lambda (possibility)
                                                   (cons (prefixify (car possibility))
                                                         (cdr possibility)))
@@ -59,18 +60,22 @@
   (present (irc:nickname object) 'nickname :stream stream))
 
 (define-presentation-method accept ((type mumble) *standard-input* (view textual-view) &key)
-  (let ((*completion-gestures* '(#\Tab)))
+  (with-delimiter-gestures (nil :override t)
+    (let ((*completion-gestures* '(#\Tab)))
       (nth-value 2
                  (complete-input *standard-input* 'nickname-completer
                                  #+(or):possibility-printer #+(or) 'nickname-competion-printer
-                                 :allow-any-input t))))
+                                 :allow-any-input t
+                                 :partial-completers '())))))
 
 ;;; nicknames
 
 (define-presentation-method accept ((type nickname) *standard-input* (view textual-view) &key)
   (with-slots (connection nick) *application-frame*
-    (let ((users (unless (null (current-channel))
-                   (mapcar #'car (hash-alist (irc:users (irc:find-channel connection (current-channel))))))))
+    (let ((users (let ((channel (and (not (null (current-channel)))
+                                     (irc:find-channel connection (current-channel)))))
+                   (if (not (null channel))
+                     (mapcar #'car (hash-alist (irc:users (irc:find-channel connection (current-channel)))))))))
       (accept `(or (member , at users) string) :prompt nil))))
 
 (define-presentation-method accept ((type ignored-nickname) *standard-input* (view textual-view) &key)



From afuchs at common-lisp.net  Wed Sep 28 19:40:08 2005
From: afuchs at common-lisp.net (Andreas Fuchs)
Date: Wed, 28 Sep 2005 21:40:08 +0200 (CEST)
Subject: [beirc-cvs] CVS update: beirc/application.lisp 
Message-ID: <20050928194008.A875C88031@common-lisp.net>

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

Modified Files:
	application.lisp 
Log Message:
Fix the hostname translator: add a tester to it that returns true only
for the 'hostmask input-context.

Date: Wed Sep 28 21:40:08 2005
Author: afuchs

Index: beirc/application.lisp
diff -u beirc/application.lisp:1.15 beirc/application.lisp:1.16
--- beirc/application.lisp:1.15	Wed Sep 28 21:33:28 2005
+++ beirc/application.lisp	Wed Sep 28 21:40:07 2005
@@ -493,9 +493,11 @@
   (receiver-from-tab-pane
          (find-in-tab-panes-list object 'tab-layout-pane)))
 
-#+(or) ; XXX: for some reason, this translator is activated when accepting NICKNAME.
 (define-presentation-translator nickname-to-hostmask-translator
-    (nickname hostmask beirc)
+    (nickname hostmask beirc
+              :tester ((object context-type)
+                       (declare (ignore object))
+                        (eql context-type 'hostmask)))
     (object)
   (format nil "*!*@~A" (irc:hostname (irc:find-user (current-connection *application-frame*) object))))
 



From afuchs at common-lisp.net  Thu Sep 29 14:51:26 2005
From: afuchs at common-lisp.net (Andreas Fuchs)
Date: Thu, 29 Sep 2005 16:51:26 +0200 (CEST)
Subject: [beirc-cvs] CVS update: beirc/application.lisp beirc/receivers.lisp
Message-ID: <20050929145126.58C7588549@common-lisp.net>

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

Modified Files:
	application.lisp receivers.lisp 
Log Message:
change (EQL input-context 'hostmask) to (presenation-subtypep i-c 'h);.

Date: Thu Sep 29 16:51:25 2005
Author: afuchs

Index: beirc/application.lisp
diff -u beirc/application.lisp:1.16 beirc/application.lisp:1.17
--- beirc/application.lisp:1.16	Wed Sep 28 21:40:07 2005
+++ beirc/application.lisp	Thu Sep 29 16:51:25 2005
@@ -497,7 +497,7 @@
     (nickname hostmask beirc
               :tester ((object context-type)
                        (declare (ignore object))
-                        (eql context-type 'hostmask)))
+                        (presentation-subtypep context-type 'hostmask)))
     (object)
   (format nil "*!*@~A" (irc:hostname (irc:find-user (current-connection *application-frame*) object))))
 


Index: beirc/receivers.lisp
diff -u beirc/receivers.lisp:1.7 beirc/receivers.lisp:1.8
--- beirc/receivers.lisp:1.7	Tue Sep 27 22:53:41 2005
+++ beirc/receivers.lisp	Thu Sep 29 16:51:25 2005
@@ -103,9 +103,9 @@
                              (target (if (equal nominal-target mynick)
                                          (irc:source message)
                                          nominal-target)))
-                    (if (or (find-receiver (irc:source message) frame)
+                    (if (or (find-receiver target frame)
                             (not (from-network-service-p (irc:source message) frame))
-                            (and (string= nominal-target target)
+                            (and (eql nominal-target target)
                                  (not (global-notice-p message nominal-target))))
                         (intern-receiver target frame :channel target)
                         (server-receiver frame))))))
@@ -171,6 +171,7 @@
       irc:irc-rpl_whoischannels-message
       irc:irc-rpl_whoisserver-message
       irc:irc-rpl_whoisidentified-message
+      irc:irc-rpl_away-message
       irc:irc-err_nosuchnick-message))
 
 (macrolet ((define-ignore-message-types (&rest mtypes)



From afuchs at common-lisp.net  Fri Sep 30 13:30:58 2005
From: afuchs at common-lisp.net (Andreas Fuchs)
Date: Fri, 30 Sep 2005 15:30:58 +0200 (CEST)
Subject: [beirc-cvs] CVS update: beirc/application.lisp
	beirc/presentations.lisp 
Message-ID: <20050930133058.92F6D88565@common-lisp.net>

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

Modified Files:
	application.lisp presentations.lisp 
Log Message:
Query for a sarcastic kick message on /kick. Also, fix  completion of incomplete nicknames

Date: Fri Sep 30 15:30:56 2005
Author: afuchs

Index: beirc/application.lisp
diff -u beirc/application.lisp:1.17 beirc/application.lisp:1.18
--- beirc/application.lisp:1.17	Thu Sep 29 16:51:25 2005
+++ beirc/application.lisp	Fri Sep 30 15:30:34 2005
@@ -346,8 +346,8 @@
 (define-beirc-command (com-ban-hostmask :name t) ((who 'hostmask :prompt "hostmask"))
   (irc:ban (current-connection *application-frame*) (target) who))
 
-(define-beirc-command (com-kick :name t) ((who 'nickname :prompt "who"))
-  (irc:kick (current-connection *application-frame*) (target) who))
+(define-beirc-command (com-kick :name t) ((who 'nickname :prompt "who") (reason 'mumble :prompt "reason"))
+  (irc:kick (current-connection *application-frame*) (target) who reason))
 
 (define-beirc-command (com-names :name t) ()
   (irc:names (current-connection *application-frame*) (target)))
@@ -440,7 +440,11 @@
               :documentation "Kick this user"
               :pointer-documentation "Kick this user")
     (object)
-  (list object))
+  (list object
+        ;; XXX: not the best way to do it. McCLIM should recognize
+        ;; that this is a partial command and query for the rest of
+        ;; the args itself.
+        (accept 'mumble :prompt " Reason")))
 
 (define-presentation-to-command-translator nickname-to-ban-nick-translator
     (nickname com-ban-nick beirc


Index: beirc/presentations.lisp
diff -u beirc/presentations.lisp:1.5 beirc/presentations.lisp:1.6
--- beirc/presentations.lisp:1.5	Wed Sep 28 21:33:28 2005
+++ beirc/presentations.lisp	Fri Sep 30 15:30:36 2005
@@ -27,10 +27,11 @@
 
 (defun nickname-completer (so-far mode)
   (multiple-value-bind (word prefix) (split-input-line so-far)
-    (labels ((prefixify (word)
-               (if (zerop (length prefix))
-                   (concatenate 'string word ": ")
-                   (concatenate 'string prefix word " "))))
+    (labels ((prefixify (word &optional (success t))
+               (concatenate 'string prefix word
+                            (cond ((not success) "")
+                                  ((zerop (length prefix)) ": ")
+                                  (t " ")))))
       (multiple-value-bind (string success object nmatches possibilities)
           (complete-from-possibilities word
                                        (let ((channel (and
@@ -38,15 +39,16 @@
                                                        (irc:find-channel
                                                         (current-connection *application-frame*)
                                                         (current-channel)))))
-                                        (if (not (null channel))
-                                            (hash-alist (irc:users channel))
-                                            nil))
+                                         (if (not (null channel))
+                                             (hash-alist (irc:users channel))
+                                             nil))
                                        '()
                                        :action mode
                                        :value-key #'cdr)
-        (values (prefixify (if (null object)
+        (values (prefixify (if (not success)
                                string
-                               (irc:nickname object)))
+                               (irc:nickname object))
+                           success)
                 success object nmatches (mapcar (lambda (possibility)
                                                   (cons (prefixify (car possibility))
                                                         (cdr possibility)))



From afuchs at common-lisp.net  Fri Sep 30 13:46:19 2005
From: afuchs at common-lisp.net (Andreas Fuchs)
Date: Fri, 30 Sep 2005 15:46:19 +0200 (CEST)
Subject: [beirc-cvs] CVS update: beirc/receivers.lisp 
Message-ID: <20050930134619.2914F8854C@common-lisp.net>

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

Modified Files:
	receivers.lisp 
Log Message:
Re-do global notices. Again. This time, for sure!

(At least we'll have a chance of understanding the logic now (-:)

Date: Fri Sep 30 15:46:18 2005
Author: afuchs

Index: beirc/receivers.lisp
diff -u beirc/receivers.lisp:1.8 beirc/receivers.lisp:1.9
--- beirc/receivers.lisp:1.8	Thu Sep 29 16:51:25 2005
+++ beirc/receivers.lisp	Fri Sep 30 15:46:18 2005
@@ -85,14 +85,23 @@
   unless the user has opened a query window to the source
   already.")
 
+(defparameter *global-notice-targets* '("$*" "auth")
+  "NOTICE message targets that should be treated as network
+service targets.")
+
+(defun nickname-comparator (frame)
+  (lambda (nick1 nick2)
+    (string= (irc:normalize-nickname (current-connection frame) nick1)
+             (irc:normalize-nickname (current-connection frame) nick2))))
+
 (defun from-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)))))
+          :test (nickname-comparator frame)))
 
-(defun global-notice-p (message target)
-  (and (typep message 'irc:irc-notice-message) (string= target "$*")))
+(defun global-notice-p (message target frame)
+  (and (typep message 'irc:irc-notice-message)
+       (member target *global-notice-targets*
+               :test (nickname-comparator frame))))
 
 (macrolet ((define-privmsg-receiver-lookup (message-type)
                `(defmethod receiver-for-message ((message ,message-type) frame)
@@ -103,12 +112,14 @@
                              (target (if (equal nominal-target mynick)
                                          (irc:source message)
                                          nominal-target)))
-                    (if (or (find-receiver target frame)
-                            (not (from-network-service-p (irc:source message) frame))
-                            (and (eql nominal-target target)
-                                 (not (global-notice-p message nominal-target))))
-                        (intern-receiver target frame :channel target)
-                        (server-receiver frame))))))
+                    (cond ((find-receiver target frame)
+                           (intern-receiver target frame :channel target))
+                          ((or (global-notice-p message nominal-target frame)
+                               (and (from-network-service-p (irc:source message) frame)
+                                    (equal nominal-target mynick)))
+                           (server-receiver frame))
+                          (t
+                           (intern-receiver target frame :channel target)))))))
   (define-privmsg-receiver-lookup irc:irc-privmsg-message)
   (define-privmsg-receiver-lookup irc:ctcp-action-message)
   (define-privmsg-receiver-lookup irc:irc-notice-message))