[beirc-cvs] CVS update: beirc/application.lisp beirc/message-display.lisp beirc/receivers.lisp
Andreas Fuchs
afuchs at common-lisp.net
Mon Sep 26 09:46:29 UTC 2005
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
More information about the Beirc-cvs
mailing list