[cl-irc-cvs] CVS cl-irc

[ehuelsmann]

Update of /project/cl-irc/cvsroot/cl-irc
In directory common-lisp:/tmp/cvs-serv598

Modified Files:
	protocol.lisp event.lisp 
Log Message:
Prevent ctcp request loops: NOTICE messages are responses. By Andreas Fuchs.

--- /project/cl-irc/cvsroot/cl-irc/protocol.lisp	2006/02/22 18:55:18	1.38
+++ /project/cl-irc/cvsroot/cl-irc/protocol.lisp	2006/02/22 18:59:13	1.39
@@ -1,4 +1,4 @@
-;;;; $Id: protocol.lisp,v 1.38 2006/02/22 18:55:18 ehuelsmann Exp $
+;;;; $Id: protocol.lisp,v 1.39 2006/02/22 18:59:13 ehuelsmann Exp $
 ;;;; $Source: /project/cl-irc/cvsroot/cl-irc/protocol.lisp,v $
 
 ;;;; See LICENSE for licensing information.
@@ -932,6 +932,12 @@
   (declare (ignore type))
   (find-class 'standard-ctcp-message))
 
+(defmethod ctcp-request-p ((message ctcp-mixin))
+  (string= (command message) :privmsg))
+
+(defmethod ctcp-reply-p ((message ctcp-mixin))
+  (string= (command message) :notice))
+
 (defmethod client-log ((connection connection) (message ctcp-mixin) &optional (prefix ""))
   (let ((stream (client-stream connection)))
     (format stream "~A~A: ~A (~A): ~A~{ ~A~} \"~A\"~%"
--- /project/cl-irc/cvsroot/cl-irc/event.lisp	2006/02/22 18:54:18	1.23
+++ /project/cl-irc/cvsroot/cl-irc/event.lisp	2006/02/22 18:59:13	1.24
@@ -1,4 +1,4 @@
-;;;; $Id: event.lisp,v 1.23 2006/02/22 18:54:18 ehuelsmann Exp $
+;;;; $Id: event.lisp,v 1.24 2006/02/22 18:59:13 ehuelsmann Exp $
 ;;;; $Source: /project/cl-irc/cvsroot/cl-irc/event.lisp,v $
 
 ;;;; See LICENSE for licensing information.
@@ -289,52 +289,52 @@
               (remove-channel user channel)
             (remove-user channel user)))))))
 
-(defmethod default-hook ((message ctcp-time-message))
-  (multiple-value-bind
-      (second minute hour date month year day)
-      (get-decoded-time)
-    (send-irc-message
-     (connection message)
-     :notice (source message)
-     (make-ctcp-message
-      (format nil "TIME ~A"
-              (make-time-message second minute hour date month year day))))))
-
-(defmethod default-hook ((message ctcp-source-message))
-  (send-irc-message
-   (connection message)
-   :notice
-   (source message)
-   (make-ctcp-message
-    (format nil "SOURCE ~A:~A:~A"
-            *download-host*
-            *download-directory*
-            *download-file*))))
-
-(defmethod default-hook ((message ctcp-finger-message))
-  (let* ((user (user (connection message)))
-         (finger-info (if (not (zerop (length (realname user))))
-                          (realname user)
-                          (nickname user))))
-    (send-irc-message
-     (connection message)
-     :notice (source message)
-     (make-ctcp-message
-      (format nil "FINGER ~A" finger-info)))))
-
-(defmethod default-hook ((message ctcp-version-message))
-  (send-irc-message
-   (connection message)
-   :notice (source message)
-   (make-ctcp-message
-    (format nil "VERSION ~A" *ctcp-version*))))
-
-(defmethod default-hook ((message ctcp-ping-message))
-  (send-irc-message
-   (connection message)
-   :notice (source message)
-   (make-ctcp-message
-    (format nil "PING ~A" (car (last (arguments message)))))))
+(macrolet ((define-ctcp-reply-hook ((message-var message-type) &body body)
+               `(defmethod default-hook ((,message-var ,message-type))
+                  (when (ctcp-request-p ,message-var)
+                    , at body))))
+  (define-ctcp-reply-hook (message ctcp-time-message)
+      (multiple-value-bind
+          (second minute hour date month year day)
+          (get-decoded-time)
+        (send-irc-message
+         (connection message)
+         :notice (source message)
+         (make-ctcp-message
+          (format nil "TIME ~A"
+                  (make-time-message second minute hour date month year day))))))
+  (define-ctcp-reply-hook (message ctcp-source-message)
+      (send-irc-message
+       (connection message)
+       :notice
+       (source message)
+       (make-ctcp-message
+        (format nil "SOURCE ~A:~A:~A"
+                *download-host*
+                *download-directory*
+                *download-file*))))
+  (define-ctcp-reply-hook (message ctcp-finger-message)
+      (let* ((user (user (connection message)))
+             (finger-info (if (not (zerop (length (realname user))))
+                              (realname user)
+                              (nickname user))))
+        (send-irc-message
+         (connection message)
+         :notice (source message)
+         (make-ctcp-message
+          (format nil "FINGER ~A" finger-info)))))
+  (define-ctcp-reply-hook (message ctcp-version-message)
+      (send-irc-message
+       (connection message)
+       :notice (source message)
+       (make-ctcp-message
+        (format nil "VERSION ~A" *ctcp-version*))))
+  (define-ctcp-reply-hook (message ctcp-ping-message)
+      (send-irc-message
+       (connection message)
+       :notice (source message)
+       (make-ctcp-message
+        (format nil "PING ~A" (car (last (arguments message))))))))
 
 (defmethod irc-message-event (connection (message ctcp-dcc-chat-request-message))
   (declare (ignore connection))