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