[cl-irc-cvs] r201 - trunk

[ehuelsmann at common-lisp.net]

Author: ehuelsmann
Date: Tue Apr 24 18:28:02 2007
New Revision: 201

Modified:
   trunk/package.lisp
   trunk/parse-message.lisp
   trunk/protocol.lisp
Log:
Implement CTCP-over-DCC framework.

Modified: trunk/package.lisp
==============================================================================
--- trunk/package.lisp	(original)
+++ trunk/package.lisp	Tue Apr 24 18:28:02 2007
@@ -146,6 +146,7 @@
              :close-on-main
              :remote-user
              :dcc-close
+             :dcc-message
              :dcc-message-event
              :make-dcc-chat-connection
              )))

Modified: trunk/parse-message.lisp
==============================================================================
--- trunk/parse-message.lisp	(original)
+++ trunk/parse-message.lisp	Tue Apr 24 18:28:02 2007
@@ -226,13 +226,13 @@
 (defun create-dcc-message (string)
   (let* ((class 'dcc-privmsg-message)
          (ctcp (ctcp-message-type string)))
-;;    (when ctcp
-;;      (setf class (find-dcc-ctcp-message class ctcp)))
+    (when ctcp
+      (setf class (find-dcc-ctcp-message class ctcp)))
     (let ((instance (make-instance class
                                    :arguments (list string)
                                    :connection nil
                                    :received-time (get-universal-time)
                                    :raw-message-string string)))
-;;      (when ctcp
-;;        (setf (ctcp-command instance) ctcp))
+      (when ctcp
+        (setf (ctcp-command instance) ctcp))
       instance)))

Modified: trunk/protocol.lisp
==============================================================================
--- trunk/protocol.lisp	(original)
+++ trunk/protocol.lisp	Tue Apr 24 18:28:02 2007
@@ -1117,12 +1117,21 @@
     :accessor ctcp-command)))
 
 (defclass standard-ctcp-message (ctcp-mixin irc-message) ())
+(defclass standard-dcc-ctcp-message (ctcp-mixin dcc-message) ())
 
 (defgeneric find-ctcp-message-class (type))
+(defgeneric find-dcc-ctcp-message-class (type))
 (defgeneric ctcp-request-p (message))
 (defgeneric ctcp-reply-p (message))
 
 (eval-when (:compile-toplevel :load-toplevel :execute)
+  (defun define-dcc-ctcp-message (ctcp-command)
+    (let ((name (intern-message-symbol :dcc-ctcp ctcp-command)))
+      `(progn
+        (defmethod find-dcc-ctcp-message-class ((type (eql ,ctcp-command)))
+          (find-class ',name))
+        (export ',name)
+        (defclass ,name (ctcp-mixin dcc-message) ()))))
   (defun define-ctcp-message (ctcp-command)
     (let ((name (intern-message-symbol :ctcp ctcp-command)))
       `(progn
@@ -1132,7 +1141,8 @@
         (defclass ,name (ctcp-mixin irc-message) ())))))
 
 (defmacro create-ctcp-message-classes (class-list)
-  `(progn ,@(mapcar #'define-ctcp-message class-list)))
+  `(progn ,@(mapcar #'define-ctcp-message class-list)
+          ,@(mapcar #'define-dcc-ctcp-message class-list)))
 
 ;; should perhaps wrap this in an eval-when?
 (create-ctcp-message-classes (:action :source :finger :ping
@@ -1143,6 +1153,10 @@
   (declare (ignore type))
   (find-class 'standard-ctcp-message))
 
+(defmethod find-dcc-ctcp-message-class (type)
+  (declare (ignore type))
+  (find-class 'standard-dcc-ctcp-message))
+
 (defmethod ctcp-request-p ((message ctcp-mixin))
   (string= (command message) :privmsg))