Update of /project/net-nittin-irc/cvsroot/net-nittin-irc In directory common-lisp.net:/tmp/cvs-serv2300
Modified Files: TODO event.lisp package.lisp parse-message.lisp protocol.lisp Log Message: many fixes, exports and partial DCC SEND/CHAT implementation
Date: Mon Nov 10 12:25:38 2003 Author: eenge
Index: net-nittin-irc/TODO diff -u net-nittin-irc/TODO:1.5 net-nittin-irc/TODO:1.6 --- net-nittin-irc/TODO:1.5 Fri Nov 7 10:40:19 2003 +++ net-nittin-irc/TODO Mon Nov 10 12:25:38 2003 @@ -11,6 +11,3 @@ equivalence of two nicknames or channel names.
So when we do FIND-USER etc. we need to be mindful of this fact. - - - Make it so that the user can choose whether to automatically - accept DCC CHAT requests or not.
Index: net-nittin-irc/event.lisp diff -u net-nittin-irc/event.lisp:1.5 net-nittin-irc/event.lisp:1.6 --- net-nittin-irc/event.lisp:1.5 Fri Nov 7 10:40:19 2003 +++ net-nittin-irc/event.lisp Mon Nov 10 12:25:38 2003 @@ -1,4 +1,4 @@ -;;;; $Id: event.lisp,v 1.5 2003/11/07 15:40:19 eenge Exp $ +;;;; $Id: event.lisp,v 1.6 2003/11/10 17:25:38 eenge Exp $ ;;;; $Source: /project/net-nittin-irc/cvsroot/net-nittin-irc/event.lisp,v $
;;;; See LICENSE for licensing information. @@ -976,12 +976,30 @@ (defmethod irc-message-event ((message ctcp-dcc-chat-request-message)) (apply-to-hooks message) (client-log (connection message) message) - (let* ((user (find-user (connection message) (source message))) - (args (tokenize-string (trailing-argument message))) - (remote-address (hbo-to-vector-quad (parse-integer (fourth args)))) - (remote-port (parse-integer (fifth args) :junk-allowed t))) - (push (make-dcc-connection :user user - :remote-address remote-address - :remote-port remote-port) - *dcc-connections*))) + (when (automatically-accept-dcc-connections (configuration (connection message))) + (let* ((user (find-user (connection message) (source message))) + (args (tokenize-string (trailing-argument message))) + (remote-address (hbo-to-vector-quad (parse-integer (fourth args)))) + (remote-port (parse-integer (fifth args) :junk-allowed t))) + (push (make-dcc-connection :user user + :remote-address remote-address + :remote-port remote-port) + *dcc-connections*)))) + +(defmethod irc-message-event ((message ctcp-dcc-send-request-message)) + (apply-to-hooks message) + (client-log (connection message) message) + (when (automatically-accept-dcc-downloads (configuration (connection message))) + (let* ((user (find-user (connection message) (source message))) + (args (tokenize-string (trailing-argument message))) + (filename (third args)) + (remote-address (hbo-to-vector-quad (parse-integer (fourth args)))) + (remote-port (parse-integer (fifth args))) + (filesize (parse-integer (sixth args) :junk-allowed t))) + (let ((dcc-connection (make-dcc-connection :user user + :remote-address remote-address + :remote-port remote-port))) + (with-open-file (stream filename :direction :output + :if-exists :supersede) + (write-sequence (read-message-loop dcc-connection) stream))))))
Index: net-nittin-irc/package.lisp diff -u net-nittin-irc/package.lisp:1.3 net-nittin-irc/package.lisp:1.4 --- net-nittin-irc/package.lisp:1.3 Fri Nov 7 08:43:06 2003 +++ net-nittin-irc/package.lisp Mon Nov 10 12:25:38 2003 @@ -1,4 +1,4 @@ -;;;; $Id: package.lisp,v 1.3 2003/11/07 13:43:06 eenge Exp $ +;;;; $Id: package.lisp,v 1.4 2003/11/10 17:25:38 eenge Exp $ ;;;; $Source: /project/net-nittin-irc/cvsroot/net-nittin-irc/package.lisp,v $
;;;; See the LICENSE file for licensing information. @@ -12,6 +12,15 @@ (:export :read-message-loop :read-message :send-message + :server-name + :server-stream + :client-stream + :channels + :configuration + :all-users + :all-channels + :dangling-users + :channel-list :add-hook :remove-hook :remove-hooks
Index: net-nittin-irc/parse-message.lisp diff -u net-nittin-irc/parse-message.lisp:1.3 net-nittin-irc/parse-message.lisp:1.4 --- net-nittin-irc/parse-message.lisp:1.3 Fri Nov 7 10:40:19 2003 +++ net-nittin-irc/parse-message.lisp Mon Nov 10 12:25:38 2003 @@ -1,4 +1,4 @@ -;;;; $Id: parse-message.lisp,v 1.3 2003/11/07 15:40:19 eenge Exp $ +;;;; $Id: parse-message.lisp,v 1.4 2003/11/10 17:25:38 eenge Exp $ ;;;; $Source: /project/net-nittin-irc/cvsroot/net-nittin-irc/parse-message.lisp,v $
;;;; See the LICENSE file for licensing information. @@ -75,6 +75,9 @@ (:dcc-chat-request (when (string-equal (char string 5) #\C) :dcc-chat-request)) + (:dcc-send-request + (when (string-equal (char string 5) #\S) + :dcc-send-request)) (otherwise nil)))
(defun parse-ctcp-message (string) @@ -86,7 +89,8 @@ (#\A (ctcp-type-p string :action)) (#\C (ctcp-type-p string :clientinfo)) (#\D - (dcc-type-p string :dcc-chat-request)) + (or (dcc-type-p string :dcc-chat-request) + (dcc-type-p string :dcc-send-request))) (#\F (ctcp-type-p string :finger)) (#\P (ctcp-type-p string :ping)) (#\S (ctcp-type-p string :source))
Index: net-nittin-irc/protocol.lisp diff -u net-nittin-irc/protocol.lisp:1.6 net-nittin-irc/protocol.lisp:1.7 --- net-nittin-irc/protocol.lisp:1.6 Fri Nov 7 10:40:19 2003 +++ net-nittin-irc/protocol.lisp Mon Nov 10 12:25:38 2003 @@ -1,4 +1,4 @@ -;;;; $Id: protocol.lisp,v 1.6 2003/11/07 15:40:19 eenge Exp $ +;;;; $Id: protocol.lisp,v 1.7 2003/11/10 17:25:38 eenge Exp $ ;;;; $Source: /project/net-nittin-irc/cvsroot/net-nittin-irc/protocol.lisp,v $
;;;; See LICENSE for licensing information. @@ -52,6 +52,11 @@ :initarg :hooks :accessor hooks :initform (make-hash-table :test #'equal)) + (configuration + :initarg :configuration + :accessor configuration + :documentation "A CONFIGURATION object which would dictate much of +the behaviour of the library towards the connection object.") (dangling-users :initarg :dangling-users :accessor dangling-users @@ -72,15 +77,19 @@ (channels nil) (dangling-users nil) (hooks nil) - (channel-list nil)) - (let ((connection (make-instance 'connection - :user user - :server-name server-name - :server-stream server-stream - :client-stream client-stream - :channels channels - :dangling-users dangling-users - :channel-list channel-list))) + (channel-list nil) + (configuration nil)) + (let* ((configuration (or configuration + (make-configuration))) + (connection (make-instance 'connection + :user user + :server-name server-name + :server-stream server-stream + :client-stream client-stream + :channels channels + :dangling-users dangling-users + :channel-list channel-list + :configuration configuration))) (dolist (hook hooks) (add-hook connection (car hook) (cadr hook))) connection)) @@ -156,6 +165,33 @@ (setf (gethash class (hooks connection)) nil))
;; +;; Configuration +;; + +(defclass configuration () + ((automatically-accept-dcc-connections + :initarg :automatically-accept-dcc-connections + :accessor automatically-accept-dcc-connections + :initform t) + (automatically-accept-dcc-downloads + :initarg :automatically-accept-dcc-downloads + :accessor automatically-accept-dcc-downloads + :initform t) + (dcc-download-directory + :initarg :dcc-download-directory + :accessor dcc-download-directory + :initform (user-homedir-pathname)))) + +(defun make-configuration (&key + (automatically-accept-dcc-connections t) + (automatically-accept-dcc-downloads t) + (dcc-download-directory (user-homedir-pathname))) + (make-instance 'configuration + :automatically-accept-dcc-connections automatically-accept-dcc-connections + :automatically-accept-dcc-downloads automatically-accept-dcc-downloads + :dcc-download-directory dcc-download-directory)) + +;; ;; DCC Connection ;;
@@ -201,9 +237,10 @@ :output-stream t)))
(defmethod read-message ((connection dcc-connection)) - (format (output-stream connection) "~A~%" (read-line (stream connection))) - (force-output (output-stream connection)) - t) + (let ((message (read-line (stream connection)))) + (format (output-stream connection) "~A~%" message) + (force-output (output-stream connection)) + message))
(defmethod read-message-loop ((connection dcc-connection)) (loop while (read-message connection))) @@ -412,12 +449,14 @@
(defclass irc-error-reply (irc-message) ())
-(defmacro define-irc-message (command) - (let ((name (intern (format nil "IRC-~A-MESSAGE" command)))) - `(progn - (defmethod find-irc-message-class ((type (eql ,command))) - (find-class ',name)) - (defclass ,name (irc-message) ())))) +(let ((*print-case* :upcase)) + (defmacro define-irc-message (command) + (let ((name (intern (format nil "IRC-~A-MESSAGE" command)))) + `(progn + (defmethod find-irc-message-class ((type (eql ,command))) + (find-class ',name)) + (export ',name) + (defclass ,name (irc-message) ())))))
(defun create-irc-message-classes (class-list) (dolist (class class-list) @@ -458,12 +497,14 @@
(defclass standard-ctcp-message (ctcp-mixin message) ())
-(defmacro define-ctcp-message (ctcp-command) - (let ((name (intern (format nil "CTCP-~A-MESSAGE" ctcp-command)))) - `(progn - (defmethod find-ctcp-message-class ((type (eql ,ctcp-command))) - (find-class ',name)) - (defclass ,name (ctcp-mixin irc-message) ())))) +(let ((*print-case* :upcase)) + (defmacro define-ctcp-message (ctcp-command) + (let ((name (intern (format nil "CTCP-~A-MESSAGE" ctcp-command)))) + `(progn + (defmethod find-ctcp-message-class ((type (eql ,ctcp-command))) + (find-class ',name)) + (export ',name) + (defclass ,name (ctcp-mixin irc-message) ())))))
(defun create-ctcp-message-classes (class-list) (dolist (class class-list) @@ -471,7 +512,8 @@
;; should perhaps wrap this in an eval-when? (create-ctcp-message-classes '(:action :source :finger :ping - :version :userinfo :time :dcc-chat-request)) + :version :userinfo :time :dcc-chat-request + :dcc-send-request))
(defmethod find-ctcp-message-class (type) (find-class 'standard-ctcp-message))