[Cl-irc-cvs] CVS update: cl-irc/protocol.lisp cl-irc/event.lisp

[Erik Huelsmann]

Update of /project/cl-irc/cvsroot/cl-irc
In directory common-lisp.net:/tmp/cvs-serv20592

Modified Files:
	protocol.lisp event.lisp 
Log Message:
Extend mode tracking: set absolute mode values for ban, except and
invite lists.

* event.lisp (generate-maskmode-hooks): New. Macro to define hooks for
  ban, except and invitelist messages and their endlist companions.
  (): Use generate-maskmode-hooks to generate hooks for ban, except
  and invite list messages.
  (default-hook [irc-rpl_namreply-message]): Register which users were
  sent in the namreply list.
  (default-hook [irc-rpl_endofnames-message]): Remove users which were
  not in the namreply-list. Before, only missing users were added,
  now spurious ones will be deleted too.

* protocol.lisp (add-default-hooks): Add hooks for new messages.

Date: Sun Mar 27 22:27:18 2005
Author: ehuelsmann

Index: cl-irc/protocol.lisp
diff -u cl-irc/protocol.lisp:1.20 cl-irc/protocol.lisp:1.21
--- cl-irc/protocol.lisp:1.20	Mon Mar 21 23:32:35 2005
+++ cl-irc/protocol.lisp	Sun Mar 27 22:27:18 2005
@@ -1,4 +1,4 @@
-;;;; $Id: protocol.lisp,v 1.20 2005/03/21 22:32:35 ehuelsmann Exp $
+;;;; $Id: protocol.lisp,v 1.21 2005/03/27 20:27:18 ehuelsmann Exp $
 ;;;; $Source: /project/cl-irc/cvsroot/cl-irc/protocol.lisp,v $
 
 ;;;; See LICENSE for licensing information.
@@ -202,9 +202,16 @@
 (defmethod add-default-hooks ((connection connection))
   (dolist (message '(irc-rpl_isupport-message
                      irc-rpl_whoisuser-message
+                     irc-rpl_banlist-message
+                     irc-rpl_endofbanlist-message
+                     irc-rpl_exceptlist-message
+                     irc-rpl_endofexceptlist-message
+                     irc-rpl_invitelist-message
+                     irc-rpl_endofinvitelist-message
                      irc-rpl_list-message
                      irc-rpl_topic-message
                      irc-rpl_namreply-message
+                     irc-rpl_endofnames-message
                      irc-ping-message
                      irc-join-message
                      irc-topic-message


Index: cl-irc/event.lisp
diff -u cl-irc/event.lisp:1.7 cl-irc/event.lisp:1.8
--- cl-irc/event.lisp:1.7	Sun Mar 20 17:55:36 2005
+++ cl-irc/event.lisp	Sun Mar 27 22:27:18 2005
@@ -1,4 +1,4 @@
-;;;; $Id: event.lisp,v 1.7 2005/03/20 16:55:36 ehuelsmann Exp $
+;;;; $Id: event.lisp,v 1.8 2005/03/27 20:27:18 ehuelsmann Exp $
 ;;;; $Source: /project/cl-irc/cvsroot/cl-irc/event.lisp,v $
 
 ;;;; See LICENSE for licensing information.
@@ -20,6 +20,47 @@
 of the IRC message to keep the connection, channel and user
 objects in sync."))
 
+(defmacro generate-maskmode-hooks (listmsg-class endmsg-class
+                                                 tmp-symbol mode-symbol)
+  `(progn
+     (defmethod default-hook ((message ,listmsg-class))
+       (destructuring-bind
+           (target channel-name mask set-by time-set)
+           (arguments message)
+         (declare (ignore target set-by time-set))
+         ;; note: the structure currently does not allow for logging
+         ;; set-by and time-set: the MODE message handling currently
+         ;; does not allow that.
+         (let ((channel (find-channel (connection message) channel-name)))
+           (when channel
+             (unless (has-mode-p channel ',tmp-symbol)
+               ;; start with a new list, replacing the old value later
+               (add-mode channel ',tmp-symbol
+                         (make-instance 'list-value-mode
+                                        :value-type :non-user)))
+             ;; use package-local symbol to prevent conflicts
+             (set-mode channel ',tmp-symbol mask)))))
+
+     (defmethod default-hook ((message ,endmsg-class))
+       (let ((channel (find-channel (connection message)
+                                    (car (arguments message)))))
+         (when channel
+           (let ((mode (has-mode-p channel ',tmp-symbol)))
+             (when mode
+               ;; replace list
+               (add-mode channel ',mode-symbol mode)
+               (remove-mode channel ',tmp-symbol))))))))
+
+(generate-maskmode-hooks irc-rpl_banlist-message
+                         irc-rpl_endofbanlist-message
+                         banlist-in-progress :ban)
+(generate-maskmode-hooks irc-rpl_exceptlist-message
+                         irc-rpl_endofexceptlist-message
+                         exceptlist-in-progress :except)
+(generate-maskmode-hooks irc-rpl_invitelist-message
+                         irc-rpl_endofinvitelist-message
+                         invitelist-in-progress :invite)
+
 (defmethod default-hook ((message irc-rpl_isupport-message))
   (let* ((capabilities (cdr (arguments message)))
          (connection (connection message))
@@ -72,13 +113,17 @@
 (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))
+          (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
@@ -91,6 +136,19 @@
                                         (make-mode connection
                                                    channel mode-name))
                               user))))))))
+
+(defmethod default-hook ((message irc-rpl_endofnames-message))
+  (let* ((channel (find-channel (connection message)
+                                (second (arguments message))))
+         (mode (get-mode channel 'namreply-in-progress))
+         (channel-users))
+    (remove-mode channel 'namreply-in-progress)
+    (maphash #'(lambda (nick user-obj)
+                 (declare (ignore nick))
+                 (pushnew user-obj channel-users)) (users channel))
+    (dolist (user (remove-if #'(lambda (x)
+                                 (member x mode)) channel-users))
+      (remove-user channel user))))
 
 (defmethod default-hook ((message irc-ping-message))
   (pong (connection message) (trailing-argument message)))