[cl-irc-cvs] CVS cl-irc - cl-irc-cvs@common-lisp.net - mailman3.common-lisp.net

15 Feb 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

    