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)