September 2005 - beirc-cvs@common-lisp.net

[beirc-cvs] CVS update: beirc/receivers.lisp
by afuchs＠common-lisp.net 30 Sep '05

30 Sep '05

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

1 0

[beirc-cvs] CVS update: beirc/application.lisp beirc/presentations.lisp
by afuchs＠common-lisp.net 30 Sep '05

30 Sep '05

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

1 0

[beirc-cvs] CVS update: beirc/application.lisp beirc/receivers.lisp
by afuchs＠common-lisp.net 29 Sep '05

29 Sep '05

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)

1 0

[beirc-cvs] CVS update: beirc/application.lisp
by afuchs＠common-lisp.net 28 Sep '05

28 Sep '05

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

1 0

[beirc-cvs] CVS update: beirc/application.lisp beirc/message-display.lisp beirc/presentations.lisp
by afuchs＠common-lisp.net 28 Sep '05

28 Sep '05

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 ,@users) string) :prompt nil)))) (define-presentation-method accept ((type ignored-nickname) *standard-input* (view textual-view) &key)

1 0

[beirc-cvs] CVS update: beirc/presentations.lisp
by afuchs＠common-lisp.net 27 Sep '05

27 Sep '05

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

1 0

[beirc-cvs] CVS update: beirc/application.lisp beirc/presentations.lisp beirc/receivers.lisp
by afuchs＠common-lisp.net 27 Sep '05

27 Sep '05

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)

1 0

[beirc-cvs] CVS update: beirc/application.lisp beirc/message-display.lisp beirc/receivers.lisp
by afuchs＠common-lisp.net 26 Sep '05

26 Sep '05

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

1 0

[beirc-cvs] CVS update: beirc/application.lisp beirc/message-display.lisp beirc/receivers.lisp
by afuchs＠common-lisp.net 26 Sep '05

26 Sep '05

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

1 0

[beirc-cvs] CVS update: beirc/message-display.lisp
by afuchs＠common-lisp.net 26 Sep '05

26 Sep '05

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

1 0