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)
