Update of /project/beirc/cvsroot/beirc In directory common-lisp:/tmp/cvs-serv14752

Modified Files: application.lisp message-display.lisp receivers.lisp Log Message: remove calls to deprecated function irc:trailing-argument and replace them (where useful) with the irc:destructuring-arguments binding form.

also, fix the (change-space-requirements ) reader error that annoyed Paolo Amoroso. Sorry for that.

--- /project/beirc/cvsroot/beirc/application.lisp 2006/02/16 23:46:57 1.38 +++ /project/beirc/cvsroot/beirc/application.lisp 2006/02/22 16:30:50 1.39 @@ -244,9 +244,9 @@ (clim-sys:destroy-process ticker-process))))))))

(defun message-directed-to-me-p (frame message) - (let ((my-nick (slot-value frame 'nick)) - (text (or (irc:trailing-argument message) ""))) - (search my-nick text))) + (irc:destructuring-arguments (&last body) message + (let ((my-nick (slot-value frame 'nick))) + (search my-nick (or body "")))))

(defun interesting-message-p (message) (typep message '(or irc:irc-privmsg-message irc:irc-notice-message irc:irc-topic-message irc:irc-kick-message irc:ctcp-action-message))) @@ -411,8 +411,7 @@ (make-instance message-type :received-time (get-universal-time) :connection :local - :trailing-argument trailing-argument - :arguments arguments + :arguments `(,@arguments ,trailing-argument) :command command :HOST "localhost" :USER "localuser" @@ -788,15 +787,15 @@ nil) ;### put the server you initially connected to here.

(defmethod trailing-argument* (message) - (irc:trailing-argument message)) + (car (last (irc:arguments message))))

(defmethod trailing-argument* ((message cl-irc:ctcp-action-message)) (or (ignore-errors ;### - (let ((p1 (position #\space (irc:trailing-argument message)))) - (subseq (irc:trailing-argument message) + (let ((p1 (position #\space (car (last (irc:arguments message)))))) + (subseq (car (last (irc:arguments message))) (1+ p1) - (1- (length (irc:trailing-argument message)))))) + (1- (length (car (last (irc:arguments message)))))))) "#Garbage parsing message#"))

(defmethod process-message (*application-frame* (message cl-irc:ctcp-action-message)) --- /project/beirc/cvsroot/beirc/message-display.lisp 2006/02/16 23:46:57 1.31 +++ /project/beirc/cvsroot/beirc/message-display.lisp 2006/02/22 16:30:50 1.32 @@ -1,5 +1,8 @@ (in-package :beirc)

+(declaim (optimize (debug 2) (speed 0) + (space 0))) + (defvar *max-preamble-length* 0)

(define-presentation-type url () @@ -29,6 +32,7 @@ (member (irc:source message) (focused-nicks receiver) :test #'string=))

(defun message-from-ignored-nick-p (message receiver) + (declare (ignore receiver)) (member (irc:source message) (slot-value *application-frame* 'ignored-nicks) :test #'string=))

@@ -136,11 +140,12 @@ (with-text-face (*standard-output* (if (message-from-focused-nick-p message receiver) :bold :roman)) - (formatting-message (t message receiver) - ((write-string start-string *standard-output*) - (present (irc:source message) 'unhighlighted-nickname) - (write-string end-string *standard-output*)) - ((format-message* (irc:trailing-argument message)))))))) + (irc:destructuring-arguments (&last body) message + (formatting-message (t message receiver) + ((write-string start-string *standard-output*) + (present (irc:source message) 'unhighlighted-nickname) + (write-string end-string *standard-output*)) + ((format-message* body))))))))

(defmethod print-message ((message irc:IRC-PRIVMSG-MESSAGE) receiver) (print-privmsg-like-message message receiver "<" ">")) @@ -149,13 +154,13 @@ (print-privmsg-like-message message receiver "-" "-"))

(defmethod print-message ((message irc:ctcp-action-message) receiver) - (let ((source (cl-irc:source message)) - (matter (trailing-argument* message))) + (let ((source (cl-irc:source message))) (formatting-message (t message receiver) - ((format t "*")) - ((present source 'unhighlighted-nickname) - (format t " ") - (format-message* matter :start-length (+ 2 (length source))))))) + ((format t "*")) + ((present source 'unhighlighted-nickname) + (format t " ") + (format-message* (trailing-argument* message) + :start-length (+ 2 (length source)))))))

(defmethod print-message ((message irc:ctcp-version-message) receiver) (let ((source (cl-irc:source message))) @@ -173,14 +178,13 @@ ,@(loop for (message-type . message-name) in message-specs collect `(defmethod print-message ((message ,message-type) receiver) - (formatting-message (t message receiver) - ((format t "~A" (irc:source message))) - ((with-drawing-options (*standard-output* :ink +gray33+ :text-size :small) - (format-message* - (format nil "~@[~A: ~]~{~A ~}~A" - ,message-name - (cdr (irc:arguments message)) - (irc:trailing-argument message))))))))))) + (irc:destructuring-arguments (_ &rest arguments &last body) message + (declare (ignore _)) + (formatting-message (t message receiver) + ((format t "~A" (irc:source message))) + ((with-drawing-options (*standard-output* :ink +gray33+ :text-size :small) + (format-message* + (format nil "~@[~A: ~]~{~A ~}~A" ,message-name (butlast arguments) body))))))))))) (define-server-message-printer ((irc:irc-rpl_motd-message . "MODT") (irc:irc-rpl_motdstart-message . "MOTD") (irc:irc-rpl_isupport-message) @@ -204,37 +208,25 @@ (irc:irc-rpl_noaway-message) (irc:irc-rpl_unaway-message))))

-(defmethod print-message ((message irc:irc-rpl_isupport-message) receiver) - (formatting-message (t message receiver) - ((format t "~A" (irc:source message))) - ((with-drawing-options (*standard-output* :ink +gray33+ :text-size :small) - (format t "MOTD: ~A" (irc:trailing-argument message)))))) - -(defmethod print-message ((message irc:irc-rpl_motd-message) receiver) - (formatting-message (t message receiver) - ((format t "~A" (irc:source message))) - ((with-drawing-options (*standard-output* :ink +gray33+ :text-size :small) - (format t "MOTD: ~A" (irc:trailing-argument message)))))) - (defmethod print-message (message receiver) - (formatting-message (t message receiver) - ((format t "!!! ~A" (irc:source message))) - ((with-drawing-options (*standard-output* :ink +red+ :text-size :small) - (format t "~A ~A :~A" (irc:command message) - (irc:arguments message) - (irc:trailing-argument message)))))) + (irc:destructuring-arguments (&whole args &last body) message + (formatting-message (t message receiver) + ((format t "!!! ~A" (irc:source message))) + ((with-drawing-options (*standard-output* :ink +red+ :text-size :small) + (format t "~A ~A :~A" (irc:command message) (butlast args) body))))))

;;; user-related messages

(defmethod print-message ((message irc:irc-quit-message) receiver) - (formatting-message (t message receiver) - ((format t " ")) - ((with-drawing-options (*standard-output* :ink +gray33+ :text-size :small) - (format t "Quit: ") - (present (irc:source message) 'nickname) - (format t ": ") - (format-message* (irc:trailing-argument message) - :start-length (+ 8 (length (irc:source message)))))))) + (irc:destructuring-arguments (&optional body) message + (formatting-message (t message receiver) + ((format t " ")) + ((with-drawing-options (*standard-output* :ink +gray33+ :text-size :small) + (format t "Quit: ") + (present (irc:source message) 'nickname) + (unless (null body) + (format t ": ") + (format-message* body :start-length (+ 8 (length (irc:source message))))))))))

(defun present-as-hostmask (user host) (write-char #() @@ -243,61 +235,66 @@ (write-char #)))

(defmethod print-message ((message irc:irc-nick-message) receiver) - (formatting-message (t message receiver) - ((format t " ")) - ((with-drawing-options (*standard-output* :ink +gray33+ :text-size :small) - (format t "Nick change: ") - (present (irc:source message) 'nickname) - (write-string " ") - (present-as-hostmask (irc:user message) (irc:host message)) - (write-string " is now known as ") - (present (irc:trailing-argument message) 'nickname))))) + (irc:destructuring-arguments (&last body) message + (formatting-message (t message receiver) + ((format t " ")) + ((with-drawing-options (*standard-output* :ink +gray33+ :text-size :small) + (format t "Nick change: ") + (present (irc:source message) 'nickname) + (write-string " ") + (present-as-hostmask (irc:user message) (irc:host message)) + (write-string " is now known as ") + (present body '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)) + (irc:destructuring-arguments (me nickname user host &last ircname) message + (declare (ignore me)) (present nickname 'nickname) (format t " is ") (present-as-hostmask user host) - (format t " (~A)" (irc:trailing-argument message))))))) + (format t " (~A)" ircname))))))

(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)))))))) + (irc:destructuring-arguments (me nickname &last body) message + (declare (ignore me)) + (formatting-message (t message receiver) + ((format t " ")) + ((with-drawing-options (*standard-output* :ink +gray33+ :text-size :small) + (present nickname 'nickname) + (format-message* (format nil " is in ~A" body) :start-length (length nickname)))))))

(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)))))))) + (irc:destructuring-arguments (me nickname server &last server-callout) message + (declare (ignore me)) + (formatting-message (t message receiver) + ((format t " ")) + ((with-drawing-options (*standard-output* :ink +gray33+ :text-size :small) + (present nickname 'nickname) + (format-message* (format nil " is on ~A: ~A" server server-callout) + :start-length (length nickname)))))))

(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)))))))) + (irc:destructuring-arguments (me nickname &last away-msg) message + (declare (ignore me)) + (formatting-message (t message receiver) + ((format t " ")) + ((with-drawing-options (*standard-output* :ink +gray33+ :text-size :small) + (present nickname 'nickname) + (format-message* (format nil " is away: ~A" away-msg) + :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)))))))) + (irc:destructuring-arguments (me nickname body) message + (declare (ignore me)) + (formatting-message (t message receiver) + ((format t " ")) + ((with-drawing-options (*standard-output* :ink +gray33+ :text-size :small) + (present nickname 'nickname) + (write-char #\Space) + (format-message* body :start-length (length (second (irc:arguments message)))))))))

;;; channel management messages

@@ -305,20 +302,22 @@ (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))))))) + (irc:destructuring-arguments (me target &rest rest) message + (declare (ignore me rest)) + (let* ((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 +red3+ :text-size :small) - (format-message* (format nil "Not permitted: ~A" (irc:trailing-argument message))))))) + (irc:destructuring-arguments (&last body) message + (formatting-message (t message receiver) + ((format t " ")) + ((with-drawing-options (*standard-output* :ink +red3+ :text-size :small) + (format-message* (format nil "Not permitted: ~A" body)))))))

(defun print-topic (receiver message sender channel topic) (formatting-message (t message receiver) @@ -331,38 +330,41 @@ (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))) + (irc:destructuring-arguments (channel &last topic) message + (print-topic receiver message (irc:source message) channel topic)))

(defmethod print-message ((message irc:irc-rpl_topic-message) receiver) - (print-topic receiver message nil - (second (irc:arguments message)) (irc:trailing-argument message))) + (irc:destructuring-arguments (channel &last topic) message + (print-topic receiver message nil channel topic)))

(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) + (irc:destructuring-arguments (me channel who time) 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) - ((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))))))) + (irc:destructuring-arguments (me privacy channel &last nicks) message + (declare (ignore me privacy)) + (formatting-message (t message receiver) + ((format t " ")) + ((with-drawing-options (*standard-output* :ink +gray33+ :text-size :small) + (format-message* (format nil "~A Names: ~A" channel nicks)))))))

(defmethod print-message ((message irc:irc-part-message) receiver) - (formatting-message (t message receiver) - ((format t " ")) - ((with-drawing-options (*standard-output* :ink +gray33+ :text-size :small) - (format t "Part: ") - (present (irc:source message) 'nickname) - (format-message* (format nil " left ~A: ~A" (first (irc:arguments message)) - (irc:trailing-argument message))))))) + (irc:destructuring-arguments (channel &optional part-msg) message + (formatting-message (t message receiver) + ((format t " ")) + ((with-drawing-options (*standard-output* :ink +gray33+ :text-size :small) + (format t "Part: ") + (present (irc:source message) 'nickname) + (format t " left ~A" channel) + (unless (null part-msg) + (format-message* (format nil ": ~A" part-msg))))))))

(defmethod print-message ((message irc:irc-join-message) receiver) (formatting-message (t message receiver) @@ -374,15 +376,17 @@ (present-as-hostmask (irc:user message) (irc:host message))))))

(defmethod print-message ((message irc:irc-kick-message) receiver) - (formatting-message (t message receiver) - ((format t " ")) - ((with-drawing-options (*standard-output* :ink +gray33+ :text-size :small) - (present (irc:source message) 'nickname) - (write-string " kicked ") - (present (second (irc:arguments message)) 'nickname) - (format-message* (format nil ": ~A" (irc:trailing-argument message)) - :start-length (+ 9 (length (second (irc:arguments message))) - (length (irc:source message)))))))) + (irc:destructuring-arguments (channel victim &optional kick-msg) message + (declare (ignore channel)) + (formatting-message (t message receiver) + ((format t " ")) + ((with-drawing-options (*standard-output* :ink +gray33+ :text-size :small) + (present (irc:source message) 'nickname) + (write-string " kicked ") + (present victim 'nickname) + (unless (null kick-msg) + (format-message* (format nil ": ~A" kick-msg) + :start-length (+ 9 (length victim) (length (irc:source message))))))))))

;;; XXX: uses unexported symbols from cl-irc, but I think their ;;; unexportedness is accidental. @@ -422,12 +426,12 @@ (case (length (irc:arguments message)) (1 (formatting-message (t message receiver) ((format t " ")) - ((with-drawing-options (*standard-output* :ink +gray33+ :text-size :small) - (format-message* (format nil "~A set mode ~A ~A" (irc:source message) - (irc:trailing-argument message) - (first (irc:arguments message)))))))) + ((irc:destructuring-arguments (channel 1c-mode) message + (with-drawing-options (*standard-output* :ink +gray33+ :text-size :small) + (format-message* (format nil "~A set mode ~A ~A" (irc:source message) + channel 1c-mode))))))) (t - (destructuring-bind (target &rest args) (irc:arguments message) + (irc:destructuring-arguments (target &rest args) message (let* ((connection (current-connection *application-frame*)) (target (or (irc:find-user connection target) (irc:find-channel connection target))) --- /project/beirc/cvsroot/beirc/receivers.lisp 2006/02/16 23:46:57 1.15 +++ /project/beirc/cvsroot/beirc/receivers.lisp 2006/02/22 16:30:50 1.16 @@ -55,7 +55,8 @@ (setf (slot-value receiver 'tab-pane) (make-tab-pane-from-list (title receiver) (pane receiver) 'receiver-pane)) (add-pane (tab-pane receiver) (find-pane-named frame 'query)) - ;; resize the pane to fit the tab container change-space-requirements pane))) + ;; resize the pane to fit the tab container + (change-space-requirements pane))) (setf (gethash (tab-pane receiver) (tab-panes-to-receivers frame)) receiver))

(defun find-receiver (name frame) @@ -146,7 +147,7 @@ (macrolet ((define-nth-arg-message-receiver-lookup (&rest clauses) "Defines receiver-for-message methods that return the receiver associated with the nth arg of the - irc message or the trailing arg if NTH in the + irc message or the last arg if NTH in the clauses is nil.

Each clause must have this format: @@ -158,7 +159,7 @@ `(defmethod receiver-for-message ((message ,message-type) frame) (let ((target ,(if (numberp nth) `(nth ,nth (irc:arguments message)) - `(irc:trailing-argument message)))) + `(first (last (irc:arguments message)))))) (intern-receiver target frame :channel target)))))))) (define-nth-arg-message-receiver-lookup (0 irc:irc-topic-message irc:irc-kick-message)