[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