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)))