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

Andreas Fuchs afuchs at common-lisp.net
Fri Sep 23 23:04:23 UTC 2005


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)




More information about the Beirc-cvs mailing list