[cl-irc-cvs] CVS cl-irc
ehuelsmann
ehuelsmann at common-lisp.net
Wed Feb 15 19:03:53 UTC 2006
Update of /project/cl-irc/cvsroot/cl-irc
In directory common-lisp:/tmp/cvs-serv16147
Modified Files:
event.lisp protocol.lisp parse-message.lisp
Log Message:
Start eliminating trailing-argument to be RFC compliant.
Step 2 should follow in about half a year,
removing trailing-argument all together.
* event.lisp:
- Use destructuring-bind to decompose protocol messages (more often).
- Fix relative arguments-use (i.e. (last arugments)) which isn't applicable
anymore. [Only the case for irc-rpl_namreply-message.]
- Fix PONG message - previously using trailing-argument - to pass all
arguments to PING back into PONG (as per the RFC).
--- /project/cl-irc/cvsroot/cl-irc/event.lisp 2006/01/27 21:10:02 1.13
+++ /project/cl-irc/cvsroot/cl-irc/event.lisp 2006/02/15 19:03:53 1.14
@@ -1,4 +1,4 @@
-;;;; $Id: event.lisp,v 1.13 2006/01/27 21:10:02 ehuelsmann Exp $
+;;;; $Id: event.lisp,v 1.14 2006/02/15 19:03:53 ehuelsmann Exp $
;;;; $Source: /project/cl-irc/cvsroot/cl-irc/event.lisp,v $
;;;; See LICENSE for licensing information.
@@ -85,26 +85,27 @@
(re-apply-case-mapping connection))))
(defmethod default-hook ((message irc-rpl_whoisuser-message))
- (let ((user (find-user (connection message)
- (second (arguments message))))
- (realname (trailing-argument message))
- (username (third (arguments message)))
- (hostname (fourth (arguments message))))
- (when user
- (setf (realname user) realname)
- (setf (username user) username)
- (setf (hostname user) hostname))))
+ (destructuring-bind
+ (target nick username hostname star realname)
+ (arguments message)
+ (declare (ignore target star))
+ (let ((user (find-user (connection message) nick)))
+ (when user
+ (setf (realname user) realname
+ (username user) username
+ (hostname user) hostname)))))
(defmethod default-hook ((message irc-rpl_list-message))
- (let ((connection (connection message))
- (channel (second (arguments message)))
- (user-count (parse-integer (or (third (arguments message)) "0")))
- (topic (trailing-argument message)))
- (add-channel connection (or (find-channel connection channel)
- (make-channel connection
- :name channel
- :topic topic
- :user-count user-count)))))
+ (destructuring-bind
+ (channel count topic)
+ (arguments message)
+ (let ((connection (connection message))
+ (user-count (parse-integer count)))
+ (add-channel connection (or (find-channel connection channel)
+ (make-channel connection
+ :name channel
+ :topic topic
+ :user-count user-count))))))
(defmethod default-hook ((message irc-rpl_topic-message))
(setf (topic (find-channel (connection message)
@@ -112,31 +113,34 @@
(trailing-argument message)))
(defmethod default-hook ((message irc-rpl_namreply-message))
- (let* ((connection (connection message))
- (channel (find-channel connection (car (last (arguments message))))))
- (unless (has-mode-p channel 'namreply-in-progress)
- (add-mode channel 'namreply-in-progress
- (make-instance 'list-value-mode :value-type :user)))
- (dolist (nickname (tokenize-string (trailing-argument message)))
- (let ((user (find-or-make-user connection
- (canonicalize-nickname connection
- nickname))))
- (unless (equal user (user connection))
- (add-user connection user)
- (add-user channel user)
- (set-mode channel 'namreply-in-progress user))
- (let* ((mode-char (getf (nick-prefixes connection)
- (elt nickname 0)))
- (mode-name (when mode-char
- (mode-name-from-char connection
- channel mode-char))))
- (when mode-name
- (if (has-mode-p channel mode-name)
- (set-mode channel mode-name user)
- (set-mode-value (add-mode channel mode-name
- (make-mode connection
- channel mode-name))
- user))))))))
+ (let* ((connection (connection message)))
+ (destructuring-bind
+ (nick chan-mode channel names)
+ (arguments message)
+ (let ((channel (find-channel connection channel)))
+ (unless (has-mode-p channel 'namreply-in-progress)
+ (add-mode channel 'namreply-in-progress
+ (make-instance 'list-value-mode :value-type :user)))
+ (dolist (nickname (tokenize-string names))
+ (let ((user (find-or-make-user connection
+ (canonicalize-nickname connection
+ nickname))))
+ (unless (equal user (user connection))
+ (add-user connection user)
+ (add-user channel user)
+ (set-mode channel 'namreply-in-progress user))
+ (let* ((mode-char (getf (nick-prefixes connection)
+ (elt nickname 0)))
+ (mode-name (when mode-char
+ (mode-name-from-char connection
+ channel mode-char))))
+ (when mode-name
+ (if (has-mode-p channel mode-name)
+ (set-mode channel mode-name user)
+ (set-mode-value (add-mode channel mode-name
+ (make-mode connection
+ channel mode-name))
+ user))))))))))
(defmethod default-hook ((message irc-rpl_endofnames-message))
(let* ((channel (find-channel (connection message)
@@ -152,7 +156,7 @@
(remove-user channel user))))
(defmethod default-hook ((message irc-ping-message))
- (pong (connection message) (trailing-argument message)))
+ (apply #'pong (connection message) (arguments message)))
(defmethod default-hook ((message irc-join-message))
(let* ((connection (connection message))
--- /project/cl-irc/cvsroot/cl-irc/protocol.lisp 2006/02/12 08:08:07 1.33
+++ /project/cl-irc/cvsroot/cl-irc/protocol.lisp 2006/02/15 19:03:53 1.34
@@ -1,4 +1,4 @@
-;;;; $Id: protocol.lisp,v 1.33 2006/02/12 08:08:07 ehuelsmann Exp $
+;;;; $Id: protocol.lisp,v 1.34 2006/02/15 19:03:53 ehuelsmann Exp $
;;;; $Source: /project/cl-irc/cvsroot/cl-irc/protocol.lisp,v $
;;;; See LICENSE for licensing information.
@@ -817,10 +817,6 @@
:accessor arguments
:initarg :arguments
:type list)
- (trailing-argument
- :accessor trailing-argument
- :initarg :trailing-argument
- :type string)
(connection
:accessor connection
:initarg :connection)
@@ -837,6 +833,13 @@
(print-unreadable-object (object stream :type t :identity t)
(format stream "~A ~A" (source object) (command object))))
+;;Compat code; remove after 2006-08-01
+
+(defgeneric trailing-argument (message))
+(defmethod trailing-argument ((message irc-message))
+ (warn "Use of deprecated function irc:trailing-argument")
+ (car (last (arguments message))))
+
(defgeneric self-message-p (message))
(defgeneric find-irc-message-class (type))
(defgeneric client-log (connection message &optional prefix))
--- /project/cl-irc/cvsroot/cl-irc/parse-message.lisp 2005/03/21 18:15:52 1.6
+++ /project/cl-irc/cvsroot/cl-irc/parse-message.lisp 2006/02/15 19:03:53 1.7
@@ -1,4 +1,4 @@
-;;;; $Id: parse-message.lisp,v 1.6 2005/03/21 18:15:52 ehuelsmann Exp $
+;;;; $Id: parse-message.lisp,v 1.7 2006/02/15 19:03:53 ehuelsmann Exp $
;;;; $Source: /project/cl-irc/cvsroot/cl-irc/parse-message.lisp,v $
;;;; See the LICENSE file for licensing information.
@@ -60,6 +60,19 @@
trailing-argument part is not present."
(cut-between string #\: '(#\Return) :start start))
+(defun combine-arguments-and-trailing (string &key (start 0))
+ (multiple-value-bind
+ (start return-string)
+ (return-arguments string :start start)
+ (print return-string)
+ (multiple-value-bind
+ (return-index trailing)
+ (return-trailing-argument string :start start)
+ (print trailing)
+ (values return-index
+ (append return-string (when (and trailing (string/= "" trailing))
+ (list trailing)))))))
+
(defun parse-raw-message (string &key (start 0))
"Assuming `string' is a valid IRC message, parse the message and
return the values in the following order:
@@ -78,8 +91,7 @@
return-user
return-host
return-command
- return-arguments
- return-trailing-argument))
+ combine-arguments-and-trailing))
(multiple-value-bind (return-index return-string)
(funcall function string :start index)
(setf index return-index)
@@ -145,10 +157,11 @@
"If `string' is a valid IRC message parse it and return an object of
the correct type with its slots prefilled according to the information
in the message."
- (multiple-value-bind (source user host command arguments trailing-argument)
+ (multiple-value-bind (source user host command arguments)
(parse-raw-message string)
- (let ((class 'irc-message)
- (ctcp (ctcp-message-type trailing-argument)))
+ (let* ((class 'irc-message)
+ (trailing-argument (car (last arguments)))
+ (ctcp (ctcp-message-type trailing-argument)))
(when command
(cond
(nil ;(irc-error-reply-p command)
@@ -177,7 +190,6 @@
"")
:arguments arguments
:connection nil
- :trailing-argument (or trailing-argument "")
:received-time (get-universal-time)
:raw-message-string (or string ""))))
(when ctcp
More information about the cl-irc-cvs
mailing list