From ehuelsmann at common-lisp.net Wed Apr 18 18:57:33 2007
From: ehuelsmann at common-lisp.net (ehuelsmann at common-lisp.net)
Date: Wed, 18 Apr 2007 14:57:33 -0400 (EDT)
Subject: [cl-irc-cvs] r179 - trunk
Message-ID: <20070418185733.19E5D19007@common-lisp.net>
Author: ehuelsmann
Date: Wed Apr 18 14:57:32 2007
New Revision: 179
Modified:
trunk/event.lisp
trunk/package.lisp
trunk/protocol.lisp
Log:
KICK messages generally don't originate at the user being kicked. Fixed.
Modified: trunk/event.lisp
==============================================================================
--- trunk/event.lisp (original)
+++ trunk/event.lisp Wed Apr 18 14:57:32 2007
@@ -315,7 +315,7 @@
(let* ((channel (find-channel connection channel))
(user (find-user connection nick)))
(when (and user channel)
- (if (self-message-p message)
+ (if (user-eq-me-p connection user)
(remove-channel user channel)
(remove-user channel user)))))))
Modified: trunk/package.lisp
==============================================================================
--- trunk/package.lisp (original)
+++ trunk/package.lisp Wed Apr 18 14:57:32 2007
@@ -85,6 +85,7 @@
:remove-all-users
:remove-user
:self-message-p
+ :user-eq-me-p
:pass
:nick
:user-
Modified: trunk/protocol.lisp
==============================================================================
--- trunk/protocol.lisp (original)
+++ trunk/protocol.lisp Wed Apr 18 14:57:32 2007
@@ -914,6 +914,7 @@
(car (last (arguments message))))
(defgeneric self-message-p (message))
+(defgeneric user-eq-me-p (connection user))
(defgeneric find-irc-message-class (type))
(defgeneric client-log (connection message &optional prefix))
(defgeneric apply-to-hooks (message))
@@ -923,6 +924,13 @@
(string-equal (source message)
(nickname (user (connection message)))))
+(defmethod user-eq-me-p (connection (user user))
+ (eq user (user connection)))
+
+(defmethod user-eq-me-p (connection (user string))
+ (let ((user (find-user connection user)))
+ (user-eq-me-p connection user)))
+
(defclass irc-error-reply (irc-message) ())
(eval-when (:compile-toplevel :load-toplevel :execute)
From ehuelsmann at common-lisp.net Thu Apr 19 20:12:44 2007
From: ehuelsmann at common-lisp.net (ehuelsmann at common-lisp.net)
Date: Thu, 19 Apr 2007 16:12:44 -0400 (EDT)
Subject: [cl-irc-cvs] r180 - trunk
Message-ID: <20070419201244.26EC12105E@common-lisp.net>
Author: ehuelsmann
Date: Thu Apr 19 16:12:44 2007
New Revision: 180
Removed:
trunk/.cvsignore
Log:
Remove - now unused - .cvsignore file.
The contents has already moved to the svn:ignore property.
From ehuelsmann at common-lisp.net Thu Apr 19 20:30:38 2007
From: ehuelsmann at common-lisp.net (ehuelsmann at common-lisp.net)
Date: Thu, 19 Apr 2007 16:30:38 -0400 (EDT)
Subject: [cl-irc-cvs] r181 - tags/0.8.1
Message-ID: <20070419203038.D2426A103@common-lisp.net>
Author: ehuelsmann
Date: Thu Apr 19 16:30:37 2007
New Revision: 181
Added:
tags/0.8.1/
- copied from r179, trunk/
Modified:
tags/0.8.1/cl-irc.asd
tags/0.8.1/variable.lisp
Log:
Tag 0.8.1, a minor fixes release.
Modified: tags/0.8.1/cl-irc.asd
==============================================================================
--- trunk/cl-irc.asd (original)
+++ tags/0.8.1/cl-irc.asd Thu Apr 19 16:30:37 2007
@@ -13,7 +13,7 @@
(defsystem cl-irc
:name "cl-irc"
:author "Erik Enge & Contributors"
- :version "0.8-dev"
+ :version "0.8.1"
:licence "MIT"
:description "Common Lisp interface to the IRC protocol"
:depends-on (:split-sequence :usocket :flexi-streams)
Modified: tags/0.8.1/variable.lisp
==============================================================================
--- trunk/variable.lisp (original)
+++ tags/0.8.1/variable.lisp Thu Apr 19 16:30:37 2007
@@ -10,7 +10,7 @@
(defconstant +soh+ #.(code-char 1))
-(defparameter *version* "0.8.0-dev")
+(defparameter *version* "0.8.1")
(defparameter *ctcp-version*
(format nil "CL IRC library, cl-irc:~A:~A ~A"
*version* (machine-type) (machine-version)))
From ehuelsmann at common-lisp.net Thu Apr 19 20:31:25 2007
From: ehuelsmann at common-lisp.net (ehuelsmann at common-lisp.net)
Date: Thu, 19 Apr 2007 16:31:25 -0400 (EDT)
Subject: [cl-irc-cvs] r182 - in public_html: . releases
Message-ID: <20070419203125.74109360DE@common-lisp.net>
Author: ehuelsmann
Date: Thu Apr 19 16:31:12 2007
New Revision: 182
Added:
public_html/releases/cl-irc-0.8.1.tar.gz (contents, props changed)
public_html/releases/cl-irc-0.8.1.tar.gz.asc
Modified:
public_html/index.html
public_html/releases/cl-irc_latest.tar.gz
public_html/releases/cl-irc_latest.tar.gz.asc
Log:
Update the website according to the 0.8.1 release (and upload release files).
Modified: public_html/index.html
==============================================================================
--- public_html/index.html (original)
+++ public_html/index.html Thu Apr 19 16:31:12 2007
@@ -5,7 +5,7 @@
@@ -28,7 +28,8 @@
News
- - Version 0.8.0 released (user and channel mode tracking, characterset support on the irc network)
+
- Version 0.8.1 released (small fixes: KICK message processing, channel mode tracking)
+ - Version 0.8.0 released (user and channel mode tracking, characterset support on the irc network)
- Version 0.7.0 released (RPL_ISUPPORT, many small tweaks and fixes)
- Version 0.6.0 released (interim release while common-lisp.net was down)
- Version 0.5.0 released (package rename and minor changes)
Added: public_html/releases/cl-irc-0.8.1.tar.gz
==============================================================================
Binary file. No diff available.
Added: public_html/releases/cl-irc-0.8.1.tar.gz.asc
==============================================================================
--- (empty file)
+++ public_html/releases/cl-irc-0.8.1.tar.gz.asc Thu Apr 19 16:31:12 2007
@@ -0,0 +1,7 @@
+-----BEGIN PGP SIGNATURE-----
+Version: GnuPG v1.4.6 (GNU/Linux)
+
+iD8DBQBGJ+yQi5O0Epaz9TkRAqNfAJ9zGgX2qWrUvNjew8xnrEry8yPhAwCeKEl9
+PaVl6xRO9UWtLQUqLWmCpBY=
+=iOtY
+-----END PGP SIGNATURE-----
Modified: public_html/releases/cl-irc_latest.tar.gz
==============================================================================
--- public_html/releases/cl-irc_latest.tar.gz (original)
+++ public_html/releases/cl-irc_latest.tar.gz Thu Apr 19 16:31:12 2007
@@ -1 +1 @@
-link cl-irc-0.8.0.tar.gz
\ No newline at end of file
+link cl-irc-0.8.1.tar.gz
\ No newline at end of file
Modified: public_html/releases/cl-irc_latest.tar.gz.asc
==============================================================================
--- public_html/releases/cl-irc_latest.tar.gz.asc (original)
+++ public_html/releases/cl-irc_latest.tar.gz.asc Thu Apr 19 16:31:12 2007
@@ -1 +1 @@
-link cl-irc-0.8.0.tar.gz.asc
\ No newline at end of file
+link cl-irc-0.8.1.tar.gz.asc
\ No newline at end of file
From ehuelsmann at common-lisp.net Thu Apr 19 21:50:37 2007
From: ehuelsmann at common-lisp.net (ehuelsmann at common-lisp.net)
Date: Thu, 19 Apr 2007 17:50:37 -0400 (EDT)
Subject: [cl-irc-cvs] r183 - trunk
Message-ID: <20070419215037.993FD431BE@common-lisp.net>
Author: ehuelsmann
Date: Thu Apr 19 17:50:36 2007
New Revision: 183
Modified:
trunk/package.lisp
trunk/utility.lisp
Log:
No idea why I wrote this, but I think it's generally usefull: hostmask matching.
Modified: trunk/package.lisp
==============================================================================
--- trunk/package.lisp (original)
+++ trunk/package.lisp Thu Apr 19 17:50:36 2007
@@ -86,6 +86,7 @@
:remove-user
:self-message-p
:user-eq-me-p
+ :mask-matches-p
:pass
:nick
:user-
Modified: trunk/utility.lisp
==============================================================================
--- trunk/utility.lisp (original)
+++ trunk/utility.lisp Thu Apr 19 17:50:36 2007
@@ -473,3 +473,44 @@
(find-user connection (pop arguments))
(pop arguments)))) ops)))))))))))
+
+;;;
+;;; Hostmask matcher
+;;;
+
+(defun do-mask-match (mask hostname mask-consumed host-consumed)
+ (if (= (length mask) (1+ mask-consumed))
+ ;; we're out of mask to match, hopefully, we're out of hostname too
+ (= (length hostname) (1+ host-consumed))
+ (let ((mask-char (char mask (1+ mask-consumed))))
+ (cond
+ ((eq mask-char #\?)
+ ;; match any character, if there is one
+ (do-mask-match mask hostname (1+ mask-consumed) (1+ host-consumed)))
+ ((eq mask-char #\*)
+ ;; match any number of characters (including zero)
+ (do ((match (do-mask-match mask hostname
+ (incf mask-consumed)
+ host-consumed)
+ (do-mask-match mask hostname
+ mask-consumed
+ (incf host-consumed))))
+ ((or (= (length hostname) (1+ host-consumed))
+ match)
+ match)))
+ ((= (1+ host-consumed) (length hostname))
+ ;; we're out of hostname...
+ nil)
+ (t
+ ;; match other characters by exact matches
+ (when (eq mask-char (char hostname (1+ host-consumed)))
+ (do-mask-match mask hostname
+ (1+ mask-consumed) (1+ host-consumed))))))))
+
+ (defun mask-matches-p (mask hostname)
+ "Wildcard matching.
+
+Uses `*' to match any number of characters and `?' to match exactly any
+one character. The routine does not enforce hostmask matching patterns,
+but can be used for the purpose."
+ (do-mask-match mask hostname -1 -1))
From ehuelsmann at common-lisp.net Thu Apr 19 21:54:50 2007
From: ehuelsmann at common-lisp.net (ehuelsmann at common-lisp.net)
Date: Thu, 19 Apr 2007 17:54:50 -0400 (EDT)
Subject: [cl-irc-cvs] r184 - trunk/test
Message-ID: <20070419215450.191044B023@common-lisp.net>
Author: ehuelsmann
Date: Thu Apr 19 17:54:49 2007
New Revision: 184
Modified:
trunk/test/test-parse-message.lisp (contents, props changed)
trunk/test/test-protocol.lisp (contents, props changed)
Log:
Harmonize keyword expansion in tests/ directory.
Modified: trunk/test/test-parse-message.lisp
==============================================================================
--- trunk/test/test-parse-message.lisp (original)
+++ trunk/test/test-parse-message.lisp Thu Apr 19 17:54:49 2007
@@ -1,5 +1,5 @@
;;;; $Id$
-;;;; $Source$
+;;;; $URL$
;;;; See the LICENSE file for licensing information.
Modified: trunk/test/test-protocol.lisp
==============================================================================
--- trunk/test/test-protocol.lisp (original)
+++ trunk/test/test-protocol.lisp Thu Apr 19 17:54:49 2007
@@ -1,5 +1,5 @@
;;;; $Id$
-;;;; $Source$
+;;;; $URL$
;;;; See the LICENSE file for licensing information.
From ehuelsmann at common-lisp.net Sat Apr 21 07:40:47 2007
From: ehuelsmann at common-lisp.net (ehuelsmann at common-lisp.net)
Date: Sat, 21 Apr 2007 03:40:47 -0400 (EDT)
Subject: [cl-irc-cvs] r185 - trunk
Message-ID: <20070421074047.7FD6A2407A@common-lisp.net>
Author: ehuelsmann
Date: Sat Apr 21 03:40:46 2007
New Revision: 185
Modified:
trunk/protocol.lisp
Log:
Fix typo, some refactoring and be more lenient on non-conforming input
(allow CRCRLF line terminators too).
Modified: trunk/protocol.lisp
==============================================================================
--- trunk/protocol.lisp (original)
+++ trunk/protocol.lisp Sat Apr 21 03:40:46 2007
@@ -142,7 +142,7 @@
:initarg :client-stream
:accessor client-stream
:initform t
- :documentation "Messages coming back from the server is sent to
+ :documentation "Messages coming back from the server are sent to
this stream.")
(channels
:initarg :channels
@@ -341,34 +341,52 @@
do (multiple-value-setq (decoded error)
(handler-case
(flexi-streams:with-input-from-sequence (in line)
- (let ((flexi (flexi-streams:make-flexi-stream in
-;; :element-type 'character
- :external-format
- (external-format-fixup external-format))))
+ (let* ((ex-fmt (external-format-fixup external-format))
+ (flexi (flexi-streams:make-flexi-stream
+ in
+ ;; :element-type 'character
+ :external-format ex-fmt)))
(read-line flexi nil nil)))
(flexi-streams:flexi-stream-encoding-error ()
nil)))
if decoded
do (return decoded)))
+(defun read-protocol-line (connection)
+ "Reads a line from the input network stream, returning a
+character array with the input read."
+ (multiple-value-bind
+ (buf buf-len)
+ ;; Note: we cannot use read-line here (or any other
+ ;; character based functions), since they may cause
+ ;; (at this time unwanted) character conversion
+ (read-sequence-until (network-stream connection)
+ (make-array 1024
+ :element-type '(unsigned-byte 8)
+ :fill-pointer t)
+ '(10))
+ ;; remove all trailing CR*LF characters (This allows CRCRLF as a line
+ ;; separator too.
+ (do ((ch (aref buf (1- buf-len))
+ (aref buf (1- buf-len))))
+ ((or (not (or (eq ch 10)
+ (eq ch 13)))
+ (= buf-len 0)))
+ (decf buf-len))
+ (setf (fill-pointer buf) buf-len)
+ (try-decode-line buf *default-incoming-external-formats*)))
+
(defmethod read-irc-message ((connection connection))
"Read and parse an IRC-message from the `connection'."
(handler-case
- (multiple-value-bind
- (buf buf-len)
- ;; Note: we cannot use read-line here (or any other
- ;; character based functions), since they may cause conversion
- (read-sequence-until (network-stream connection)
- (make-array 1024
- :element-type '(unsigned-byte 8)
- :fill-pointer t)
- '(13 10))
- (setf (fill-pointer buf) buf-len)
- (let* ((message (create-irc-message (try-decode-line buf *default-incoming-external-formats*))))
- (setf (connection message) connection)
- message))
- (end-of-file ())))
- ;; satisfy read-message-loop assumption of nil when no more messages
+ (let* ((msg-string (read-protocol-line connection))
+ (message (create-irc-message msg-string)))
+ (setf (connection message) connection)
+ message)
+ (end-of-file
+ ;; satisfy read-message-loop assumption of nil when no more messages
+ ())))
+
(defmethod send-irc-message ((connection connection) command
&rest arguments)
From ehuelsmann at common-lisp.net Sat Apr 21 21:02:06 2007
From: ehuelsmann at common-lisp.net (ehuelsmann at common-lisp.net)
Date: Sat, 21 Apr 2007 17:02:06 -0400 (EDT)
Subject: [cl-irc-cvs] r186 - trunk
Message-ID: <20070421210206.CD60A48144@common-lisp.net>
Author: ehuelsmann
Date: Sat Apr 21 17:02:06 2007
New Revision: 186
Modified:
trunk/event.lisp
trunk/protocol.lisp
Log:
Silence UNHANDLED messages on the debug stream when they are in fact handled.
Modified: trunk/event.lisp
==============================================================================
--- trunk/event.lisp (original)
+++ trunk/event.lisp Sat Apr 21 17:02:06 2007
@@ -12,8 +12,8 @@
(defmethod irc-message-event (connection (message irc-message))
(declare (ignore connection))
- (apply-to-hooks message)
- (client-log (connection message) message "UNHANDLED-EVENT:"))
+ (unless (apply-to-hooks message)
+ (client-log (connection message) message "UNHANDLED-EVENT:")))
(defgeneric default-hook (message)
Modified: trunk/protocol.lisp
==============================================================================
--- trunk/protocol.lisp (original)
+++ trunk/protocol.lisp Sat Apr 21 17:02:06 2007
@@ -993,10 +993,17 @@
(car (last (arguments message))))
(force-output stream)))
+
(defmethod apply-to-hooks ((message irc-message))
- (let ((connection (connection message)))
- (dolist (hook (get-hooks connection (class-name (class-of message))))
- (funcall hook message))))
+ "Applies any applicable hooks to `message'.
+
+Returns non-nil if any of the hooks do."
+ (let ((connection (connection message))
+ (result nil))
+ (dolist (hook (get-hooks connection (class-name (class-of message)))
+ result)
+ (setf result (or (funcall hook message)
+ result)))))
;;
;; CTCP Message
From ehuelsmann at common-lisp.net Sat Apr 21 22:06:52 2007
From: ehuelsmann at common-lisp.net (ehuelsmann at common-lisp.net)
Date: Sat, 21 Apr 2007 18:06:52 -0400 (EDT)
Subject: [cl-irc-cvs] r187 - trunk
Message-ID: <20070421220652.45BDE1701C@common-lisp.net>
Author: ehuelsmann
Date: Sat Apr 21 18:06:51 2007
New Revision: 187
Modified:
trunk/protocol.lisp
Log:
Fix termination condition in read-protocol-line.
Modified: trunk/protocol.lisp
==============================================================================
--- trunk/protocol.lisp (original)
+++ trunk/protocol.lisp Sat Apr 21 18:06:51 2007
@@ -365,15 +365,13 @@
:element-type '(unsigned-byte 8)
:fill-pointer t)
'(10))
- ;; remove all trailing CR*LF characters (This allows CRCRLF as a line
- ;; separator too.
- (do ((ch (aref buf (1- buf-len))
- (aref buf (1- buf-len))))
- ((or (not (or (eq ch 10)
- (eq ch 13)))
- (= buf-len 0)))
- (decf buf-len))
- (setf (fill-pointer buf) buf-len)
+ (setf (fill-pointer buf)
+ ;; remove all trailing CR and LF characters
+ ;; (This allows non-conforming clients to send CRCRLF
+ ;; as a line separator too).
+ (or (position-if #'(lambda (x) (member x '(10 13)))
+ buf :from-end t :end buf-len)
+ buf-len))
(try-decode-line buf *default-incoming-external-formats*)))
(defmethod read-irc-message ((connection connection))
From ehuelsmann at common-lisp.net Sat Apr 21 22:50:12 2007
From: ehuelsmann at common-lisp.net (ehuelsmann at common-lisp.net)
Date: Sat, 21 Apr 2007 18:50:12 -0400 (EDT)
Subject: [cl-irc-cvs] r188 - trunk
Message-ID: <20070421225012.22C5A2E1BF@common-lisp.net>
Author: ehuelsmann
Date: Sat Apr 21 18:50:10 2007
New Revision: 188
Modified:
trunk/protocol.lisp
trunk/utility.lisp
Log:
Fix off-by-one error and make sure we don't keep looping when the network stream is lost.
Modified: trunk/protocol.lisp
==============================================================================
--- trunk/protocol.lisp (original)
+++ trunk/protocol.lisp Sat Apr 21 18:50:10 2007
@@ -365,21 +365,22 @@
:element-type '(unsigned-byte 8)
:fill-pointer t)
'(10))
- (setf (fill-pointer buf)
- ;; remove all trailing CR and LF characters
- ;; (This allows non-conforming clients to send CRCRLF
- ;; as a line separator too).
- (or (position-if #'(lambda (x) (member x '(10 13)))
- buf :from-end t :end buf-len)
- buf-len))
- (try-decode-line buf *default-incoming-external-formats*)))
+ (when (< 0 buf-len)
+ (setf (fill-pointer buf)
+ ;; remove all trailing CR and LF characters
+ ;; (This allows non-conforming clients to send CRCRLF
+ ;; as a line separator too).
+ (or (position-if #'(lambda (x) (member x '(10 13)))
+ buf :from-end t :end buf-len)
+ buf-len))
+ (try-decode-line buf *default-incoming-external-formats*))))
(defmethod read-irc-message ((connection connection))
"Read and parse an IRC-message from the `connection'."
(handler-case
(let* ((msg-string (read-protocol-line connection))
- (message (create-irc-message msg-string)))
- (setf (connection message) connection)
+ (message (when msg-string (create-irc-message msg-string))))
+ (when message (setf (connection message) connection))
message)
(end-of-file
;; satisfy read-message-loop assumption of nil when no more messages
Modified: trunk/utility.lisp
==============================================================================
--- trunk/utility.lisp (original)
+++ trunk/utility.lisp Sat Apr 21 18:50:10 2007
@@ -129,7 +129,7 @@
;; For others, if this becomes an efficiency problem, please report...
(loop for next-elt = (funcall read-fun stream nil nil)
if (null next-elt)
- do (return (values target targ-cur t))
+ do (return (values target (1+ targ-cur) t))
else do
(setf (elt target (incf targ-cur)) next-elt)
(if (eql next-elt (aref limit-vector limit-cur))
From ehuelsmann at common-lisp.net Sun Apr 22 08:12:25 2007
From: ehuelsmann at common-lisp.net (ehuelsmann at common-lisp.net)
Date: Sun, 22 Apr 2007 04:12:25 -0400 (EDT)
Subject: [cl-irc-cvs] r189 - trunk
Message-ID: <20070422081225.820393D033@common-lisp.net>
Author: ehuelsmann
Date: Sun Apr 22 04:12:22 2007
New Revision: 189
Modified:
trunk/protocol.lisp
trunk/utility.lisp
Log:
Move 2 utility routines.
Modified: trunk/protocol.lisp
==============================================================================
--- trunk/protocol.lisp (original)
+++ trunk/protocol.lisp Sun Apr 22 04:12:22 2007
@@ -334,46 +334,6 @@
(defun read-message-loop (connection)
(loop while (read-message connection)))
-(defun try-decode-line (line external-formats)
- (loop for external-format in external-formats
- for decoded = nil
- for error = nil
- do (multiple-value-setq (decoded error)
- (handler-case
- (flexi-streams:with-input-from-sequence (in line)
- (let* ((ex-fmt (external-format-fixup external-format))
- (flexi (flexi-streams:make-flexi-stream
- in
- ;; :element-type 'character
- :external-format ex-fmt)))
- (read-line flexi nil nil)))
- (flexi-streams:flexi-stream-encoding-error ()
- nil)))
- if decoded
- do (return decoded)))
-
-(defun read-protocol-line (connection)
- "Reads a line from the input network stream, returning a
-character array with the input read."
- (multiple-value-bind
- (buf buf-len)
- ;; Note: we cannot use read-line here (or any other
- ;; character based functions), since they may cause
- ;; (at this time unwanted) character conversion
- (read-sequence-until (network-stream connection)
- (make-array 1024
- :element-type '(unsigned-byte 8)
- :fill-pointer t)
- '(10))
- (when (< 0 buf-len)
- (setf (fill-pointer buf)
- ;; remove all trailing CR and LF characters
- ;; (This allows non-conforming clients to send CRCRLF
- ;; as a line separator too).
- (or (position-if #'(lambda (x) (member x '(10 13)))
- buf :from-end t :end buf-len)
- buf-len))
- (try-decode-line buf *default-incoming-external-formats*))))
(defmethod read-irc-message ((connection connection))
"Read and parse an IRC-message from the `connection'."
Modified: trunk/utility.lisp
==============================================================================
--- trunk/utility.lisp (original)
+++ trunk/utility.lisp Sun Apr 22 04:12:22 2007
@@ -106,6 +106,24 @@
(setf (getf (cdr new-format) :eol-style) :crlf)
new-format))
+(defun try-decode-line (line external-formats)
+ (loop for external-format in external-formats
+ for decoded = nil
+ for error = nil
+ do (multiple-value-setq (decoded error)
+ (handler-case
+ (flexi-streams:with-input-from-sequence (in line)
+ (let* ((ex-fmt (external-format-fixup external-format))
+ (flexi (flexi-streams:make-flexi-stream
+ in
+ ;; :element-type 'character
+ :external-format ex-fmt)))
+ (read-line flexi nil nil)))
+ (flexi-streams:flexi-stream-encoding-error ()
+ nil)))
+ if decoded
+ do (return decoded)))
+
(defun read-byte-no-hang (stream &optional eof-error-p eof-value)
(declare (optimize (speed 3) (debug 0) (safety 0)))
(when (listen stream)
@@ -140,6 +158,30 @@
(= limit-cur limit-max))
do (return (values target (1+ targ-cur) nil)))))
+(defun read-protocol-line (connection)
+ "Reads a line from the input network stream, returning a
+character array with the input read."
+ (multiple-value-bind
+ (buf buf-len)
+ ;; Note: we cannot use read-line here (or any other
+ ;; character based functions), since they may cause
+ ;; (at this time unwanted) character conversion
+ (read-sequence-until (network-stream connection)
+ (make-array 1024
+ :element-type '(unsigned-byte 8)
+ :fill-pointer t)
+ '(10))
+ (when (< 0 buf-len)
+ (setf (fill-pointer buf)
+ ;; remove all trailing CR and LF characters
+ ;; (This allows non-conforming clients to send CRCRLF
+ ;; as a line separator too).
+ (or (position-if #'(lambda (x) (member x '(10 13)))
+ buf :from-end t :end buf-len)
+ buf-len))
+ (try-decode-line buf *default-incoming-external-formats*))))
+
+
(defun substring (string start &optional end)
(let* ((end-index (if end end (length string)))
(seq-len (- end-index start)))
From ehuelsmann at common-lisp.net Sun Apr 22 20:01:45 2007
From: ehuelsmann at common-lisp.net (ehuelsmann at common-lisp.net)
Date: Sun, 22 Apr 2007 16:01:45 -0400 (EDT)
Subject: [cl-irc-cvs] r190 - trunk
Message-ID: <20070422200145.57CB349032@common-lisp.net>
Author: ehuelsmann
Date: Sun Apr 22 16:01:44 2007
New Revision: 190
Modified:
trunk/parse-message.lisp
Log:
Other DCC protocols starting with an #\S have been introduced now (SCHAT,SSEND).
Modified: trunk/parse-message.lisp
==============================================================================
--- trunk/parse-message.lisp (original)
+++ trunk/parse-message.lisp Sun Apr 22 16:01:44 2007
@@ -118,17 +118,21 @@
type)
type
nil))
-
+
(defun dcc-type-p (string type)
"Is the `string' actually a representation of the DCC `type'?"
- (case type
- (: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)))
+ (let* ((args (tokenize-string (string-trim (list +soh+) string)))
+ (dcc (string-upcase (first args)))
+ (type (string-upcase (second args))))
+ (when (string= dcc "DCC")
+ (case type
+ (:dcc-chat-request
+ (when (string= type "CHAT")
+ :dcc-chat-request))
+ (:dcc-send-request
+ (when (string= type "SEND")
+ :dcc-send-request))
+ (otherwise nil)))))
(defun ctcp-message-type (string)
"If `string' is a CTCP message, return the type of the message or
From ehuelsmann at common-lisp.net Sun Apr 22 21:05:12 2007
From: ehuelsmann at common-lisp.net (ehuelsmann at common-lisp.net)
Date: Sun, 22 Apr 2007 17:05:12 -0400 (EDT)
Subject: [cl-irc-cvs] r191 - trunk
Message-ID: <20070422210512.D58CC3A01C@common-lisp.net>
Author: ehuelsmann
Date: Sun Apr 22 17:05:11 2007
New Revision: 191
Modified:
trunk/parse-message.lisp
Log:
Add a list of DCC session types.
Modified: trunk/parse-message.lisp
==============================================================================
--- trunk/parse-message.lisp (original)
+++ trunk/parse-message.lisp Sun Apr 22 17:05:11 2007
@@ -125,14 +125,38 @@
(dcc (string-upcase (first args)))
(type (string-upcase (second args))))
(when (string= dcc "DCC")
- (case type
- (:dcc-chat-request
- (when (string= type "CHAT")
- :dcc-chat-request))
- (:dcc-send-request
- (when (string= type "SEND")
- :dcc-send-request))
- (otherwise nil)))))
+ (let ((r
+ ;; the list below was found on Wikipedia and in kvirc docs
+ (second (assoc type '(("CHAT" :dcc-chat-request)
+ ("SEND" :dcc-send-request)
+ ("XMIT" :dcc-xmit-request)
+ ("SCHAT" :dcc-schat-request)
+ ("SSEND" :dcc-ssend-request)
+ ("REVERSE" :dcc-reverse-request)
+ ("RSEND" :dcc-rsend-request)
+ ("TSEND" :dcc-tsend-request)
+ ("STSEND" :dcc-stsend-request)
+ ("TSSEND" :dcc-stsend-request)
+ ("RESUME" :dcc-resume-request)
+ ("ACCEPT" :dcc-accept-request)
+ ;; GET
+ ;; TGET
+ ;; STGET
+ ;; TSGET
+ ;; RECV
+ ;; SRECV
+ ;; TRECV
+ ;; STRECV
+ ;; TSRECV
+ ;; RSEND
+ ;; SRSEND
+ ;; TRSEND
+ ;; STRSEND
+ ;; TSRSEND
+ ;; VOICE
+ ) :test #'string=))))
+ (when (eq r type)
+ type)))))
(defun ctcp-message-type (string)
"If `string' is a CTCP message, return the type of the message or
From ehuelsmann at common-lisp.net Mon Apr 23 06:47:18 2007
From: ehuelsmann at common-lisp.net (ehuelsmann at common-lisp.net)
Date: Mon, 23 Apr 2007 02:47:18 -0400 (EDT)
Subject: [cl-irc-cvs] r192 - trunk
Message-ID: <20070423064718.D3DF3830C6@common-lisp.net>
Author: ehuelsmann
Date: Mon Apr 23 02:47:15 2007
New Revision: 192
Modified:
trunk/parse-message.lisp
Log:
Rename shadowing local binding (type -> sess-type).
Modified: trunk/parse-message.lisp
==============================================================================
--- trunk/parse-message.lisp (original)
+++ trunk/parse-message.lisp Mon Apr 23 02:47:15 2007
@@ -123,38 +123,38 @@
"Is the `string' actually a representation of the DCC `type'?"
(let* ((args (tokenize-string (string-trim (list +soh+) string)))
(dcc (string-upcase (first args)))
- (type (string-upcase (second args))))
+ (sess-type (string-upcase (second args))))
(when (string= dcc "DCC")
(let ((r
;; the list below was found on Wikipedia and in kvirc docs
- (second (assoc type '(("CHAT" :dcc-chat-request)
- ("SEND" :dcc-send-request)
- ("XMIT" :dcc-xmit-request)
- ("SCHAT" :dcc-schat-request)
- ("SSEND" :dcc-ssend-request)
- ("REVERSE" :dcc-reverse-request)
- ("RSEND" :dcc-rsend-request)
- ("TSEND" :dcc-tsend-request)
- ("STSEND" :dcc-stsend-request)
- ("TSSEND" :dcc-stsend-request)
- ("RESUME" :dcc-resume-request)
- ("ACCEPT" :dcc-accept-request)
- ;; GET
- ;; TGET
- ;; STGET
- ;; TSGET
- ;; RECV
- ;; SRECV
- ;; TRECV
- ;; STRECV
- ;; TSRECV
- ;; RSEND
- ;; SRSEND
- ;; TRSEND
- ;; STRSEND
- ;; TSRSEND
- ;; VOICE
- ) :test #'string=))))
+ (second (assoc sess-type '(("CHAT" :dcc-chat-request)
+ ("SEND" :dcc-send-request)
+ ("XMIT" :dcc-xmit-request)
+ ("SCHAT" :dcc-schat-request)
+ ("SSEND" :dcc-ssend-request)
+ ("REVERSE" :dcc-reverse-request)
+ ("RSEND" :dcc-rsend-request)
+ ("TSEND" :dcc-tsend-request)
+ ("STSEND" :dcc-stsend-request)
+ ("TSSEND" :dcc-stsend-request)
+ ("RESUME" :dcc-resume-request)
+ ("ACCEPT" :dcc-accept-request)
+ ;; GET
+ ;; TGET
+ ;; STGET
+ ;; TSGET
+ ;; RECV
+ ;; SRECV
+ ;; TRECV
+ ;; STRECV
+ ;; TSRECV
+ ;; RSEND
+ ;; SRSEND
+ ;; TRSEND
+ ;; STRSEND
+ ;; TSRSEND
+ ;; VOICE
+ ) :test #'string=))))
(when (eq r type)
type)))))
From ehuelsmann at common-lisp.net Tue Apr 24 20:16:52 2007
From: ehuelsmann at common-lisp.net (ehuelsmann at common-lisp.net)
Date: Tue, 24 Apr 2007 16:16:52 -0400 (EDT)
Subject: [cl-irc-cvs] r193 - trunk
Message-ID: <20070424201652.9D41B2E1AE@common-lisp.net>
Author: ehuelsmann
Date: Tue Apr 24 16:16:50 2007
New Revision: 193
Modified:
trunk/package.lisp
trunk/protocol.lisp
Log:
Rearrange code. Make dcc-connection an abstract base class.
Modified: trunk/package.lisp
==============================================================================
--- trunk/package.lisp (original)
+++ trunk/package.lisp Tue Apr 24 16:16:50 2007
@@ -138,5 +138,12 @@
:users-
:wallops
:userhost
- :ison)))
+ :ison
+ ;; DCC specific dictionary
+ :dcc-connection
+ :irc-connection
+ :close-on-main
+ :remote-user
+ :dcc-close
+ )))
Modified: trunk/protocol.lisp
==============================================================================
--- trunk/protocol.lisp (original)
+++ trunk/protocol.lisp Tue Apr 24 16:16:50 2007
@@ -144,6 +144,10 @@
:initform t
:documentation "Messages coming back from the server are sent to
this stream.")
+ (dcc-connections
+ :accessor dcc-connections
+ :initform '()
+ :documentation "The DCC connections associated with this IRC connection.")
(channels
:initarg :channels
:accessor channels
@@ -417,18 +421,43 @@
;;
(defclass dcc-connection ()
- ((user
- :initarg :user
- :accessor user
+ ((irc-connection
+ :initarg :irc-connection
+ :accessor irc-connection
+ :initform nil
+ :documentation "The associated IRC connection used to send
+CTCP control commands. When this connection is closed/lost,
+the DCC connection should be terminated too for security reasons.")
+ (close-on-main
+ :initarg :close-on-main
+ :accessor close-on-main
+ :initform t
+ :documentation "Makes sure that the DCC connection is closed
+as soon as either the IRC connection is actively closed or when
+a lost connection is detected.")
+ (remote-user
+ :initarg :remote-user
+ :accessor remote-user
:documentation "The user at the other end of this connection. The
user at this end can be reached via your normal connection object.")
+ (socket
+ :initarg :socket
+ :accessor socket
+ :initform nil
+ :documentation "Socket used to do the remote client.")
(network-stream
:initarg :network-stream
:accessor network-stream)
- (output-stream
- :initarg :output-stream
- :accessor output-stream
- :initform t)))
+ (client-stream
+ :initarg :client-stream
+ :accessor client-stream
+ :documentation "Input from the remote is sent to this stream."))
+ (:documentation "Abstract superclass of all types of DCC connections.
+
+This class isn't meant to be instanciated. The different DCC subprotocols
+differ widely in the way they transmit their data, meaning there are
+relatively few methods which can be defined for this class. They do
+share a number of properties though."))
(defmethod print-object ((object dcc-connection) stream)
"Print the object for the Lisp reader."
@@ -439,43 +468,31 @@
(hostname (user object)))
"")))
-(defun make-dcc-connection (&key (user nil)
- (remote-address nil)
- (remote-port nil)
- (output-stream t))
- (make-instance 'dcc-connection
- :user user
- :network-stream (usocket:socket-connect remote-address
- remote-port)
- :output-stream output-stream))
+;; Common generic functions
+
+;; argh. I want to name this quit but that gives me issues with
+;; generic functions. need to resolve.
(defgeneric dcc-close (connection))
+;;already defined in relation to `connection':
+;; (defgeneric connectedp (connection))
+
+;; CHAT related generic functions
(defgeneric send-dcc-message (connection message))
-(defmethod read-message ((connection dcc-connection))
- (when (connectedp connection)
- (let ((message (read-line (network-stream connection))))
- (format (output-stream connection) "~A~%" message)
- (force-output (output-stream connection))
- (when *debug-p*
- (format *debug-stream* "~A" (describe message)))
- ;; (dcc-message-event message)
- message))) ; needed because of the "loop while" in read-message-loop
+;; SEND related generic functions
+;;
-(defmethod send-dcc-message ((connection dcc-connection) message)
- (format (network-stream connection) "~A~%" message)
- (force-output (network-stream connection)))
-;; argh. I want to name this quit but that gives me issues with
-;; generic functions. need to resolve.
(defmethod dcc-close ((connection dcc-connection))
#+(and sbcl (not sb-thread))
(sb-sys:invalidate-descriptor
(sb-sys:fd-stream-fd (network-stream connection)))
(close (network-stream connection))
- (setf (user connection) nil)
- (setf *dcc-connections* (remove connection *dcc-connections*))
- )
+ (setf (remote-user connection) nil
+ *dcc-connections* (remove connection *dcc-connections*)
+ (dcc-connections (irc-connection connection))
+ (remove connection (dcc-connections (irc-connection connection)))))
(defmethod connectedp ((connection dcc-connection))
(let ((stream (network-stream connection)))
From ehuelsmann at common-lisp.net Tue Apr 24 20:24:26 2007
From: ehuelsmann at common-lisp.net (ehuelsmann at common-lisp.net)
Date: Tue, 24 Apr 2007 16:24:26 -0400 (EDT)
Subject: [cl-irc-cvs] r194 - trunk
Message-ID: <20070424202426.CD91F3A01C@common-lisp.net>
Author: ehuelsmann
Date: Tue Apr 24 16:24:26 2007
New Revision: 194
Modified:
trunk/protocol.lisp
Log:
Define fallback functions for the case where the message passed isn't even
a subtype of ctcp-mixin.
Modified: trunk/protocol.lisp
==============================================================================
--- trunk/protocol.lisp (original)
+++ trunk/protocol.lisp Tue Apr 24 16:24:26 2007
@@ -1020,9 +1020,21 @@
(defmethod ctcp-request-p ((message ctcp-mixin))
(string= (command message) :privmsg))
+(defmethod ctcp-request-p (message)
+ ;; If we're not calling the above method, then, obviously
+ ;; this was never a ctcp-thing to start with
+ (declare (ignore message))
+ nil)
+
(defmethod ctcp-reply-p ((message ctcp-mixin))
(string= (command message) :notice))
+(defmethod ctcp-reply-p (message)
+ (declare (ignore message))
+ ;; If we're not calling the above method, then, obviously
+ ;; this was never a ctcp-thing to start with
+ nil)
+
(defmethod client-log ((connection connection) (message ctcp-mixin) &optional (prefix ""))
(let ((stream (client-stream connection)))
(format stream "~A~A: ~A (~A): ~A~{ ~A~} \"~A\"~%"
From ehuelsmann at common-lisp.net Tue Apr 24 20:27:36 2007
From: ehuelsmann at common-lisp.net (ehuelsmann at common-lisp.net)
Date: Tue, 24 Apr 2007 16:27:36 -0400 (EDT)
Subject: [cl-irc-cvs] r195 - trunk
Message-ID: <20070424202736.2B17C3F003@common-lisp.net>
Author: ehuelsmann
Date: Tue Apr 24 16:27:35 2007
New Revision: 195
Modified:
trunk/protocol.lisp
Log:
r193 followup: 'user' was renamed to 'remote-user' to disambiguate its meaning.
Modified: trunk/protocol.lisp
==============================================================================
--- trunk/protocol.lisp (original)
+++ trunk/protocol.lisp Tue Apr 24 16:27:35 2007
@@ -462,10 +462,10 @@
(defmethod print-object ((object dcc-connection) stream)
"Print the object for the Lisp reader."
(print-unreadable-object (object stream :type t :identity t)
- (if (user object)
+ (if (remote-user object)
(format stream "with ~A@~A"
- (nickname (user object))
- (hostname (user object)))
+ (nickname (remote-user object))
+ (hostname (remote-user object)))
"")))
From ehuelsmann at common-lisp.net Tue Apr 24 21:51:57 2007
From: ehuelsmann at common-lisp.net (ehuelsmann at common-lisp.net)
Date: Tue, 24 Apr 2007 17:51:57 -0400 (EDT)
Subject: [cl-irc-cvs] r196 - trunk
Message-ID: <20070424215157.44EE24904E@common-lisp.net>
Author: ehuelsmann
Date: Tue Apr 24 17:51:56 2007
New Revision: 196
Modified:
trunk/protocol.lisp
Log:
Move connectedp into the dcc-connection section;
ignore errors when closing a connection.
Modified: trunk/protocol.lisp
==============================================================================
--- trunk/protocol.lisp (original)
+++ trunk/protocol.lisp Tue Apr 24 17:51:56 2007
@@ -482,23 +482,22 @@
;; SEND related generic functions
;;
-
+(defmethod connectedp ((connection dcc-connection))
+ (let ((stream (network-stream connection)))
+ (and (streamp stream)
+ (open-stream-p stream))))
(defmethod dcc-close ((connection dcc-connection))
#+(and sbcl (not sb-thread))
(sb-sys:invalidate-descriptor
(sb-sys:fd-stream-fd (network-stream connection)))
- (close (network-stream connection))
+ (ignore-errors
+ (close (network-stream connection)))
(setf (remote-user connection) nil
*dcc-connections* (remove connection *dcc-connections*)
(dcc-connections (irc-connection connection))
(remove connection (dcc-connections (irc-connection connection)))))
-(defmethod connectedp ((connection dcc-connection))
- (let ((stream (network-stream connection)))
- (and (streamp stream)
- (open-stream-p stream))))
-
;;
;; Channel
;;
From ehuelsmann at common-lisp.net Tue Apr 24 22:01:02 2007
From: ehuelsmann at common-lisp.net (ehuelsmann at common-lisp.net)
Date: Tue, 24 Apr 2007 18:01:02 -0400 (EDT)
Subject: [cl-irc-cvs] r197 - trunk
Message-ID: <20070424220102.A5C5F6B0EB@common-lisp.net>
Author: ehuelsmann
Date: Tue Apr 24 18:01:01 2007
New Revision: 197
Modified:
trunk/parse-message.lisp
trunk/protocol.lisp
Log:
Create a DCC CHAT message class, just like the IRC message classes we have.
Modified: trunk/parse-message.lisp
==============================================================================
--- trunk/parse-message.lisp (original)
+++ trunk/parse-message.lisp Tue Apr 24 18:01:01 2007
@@ -222,3 +222,17 @@
(when ctcp
(setf (ctcp-command instance) ctcp))
instance))))
+
+(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)))
+ (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))
+ instance)))
Modified: trunk/protocol.lisp
==============================================================================
--- trunk/protocol.lisp (original)
+++ trunk/protocol.lisp Tue Apr 24 18:01:01 2007
@@ -981,6 +981,61 @@
result)))))
;;
+;; DCC CHAT messages
+;;
+
+(defclass dcc-message ()
+ ((connection
+ :initarg :connection
+ :accessor connection
+ :documentation "")
+ (arguments
+ :initarg :arguments
+ :accessor arguments
+ :type list
+ :documentation "")
+ (received-time
+ :initarg :received-time
+ :accessor received-time)
+ (raw-message-string
+ :initarg :raw-message-string
+ :accessor raw-message-string
+ :type sting))
+ (:documentation ""))
+
+(defmethod print-object ((object dcc-message) stream)
+ "Print the object for the Lisp reader."
+ (print-unreadable-object (object stream :type t :identity t)
+ (format stream "~A ~A"
+ (nickname (remote-user (connection object)))
+ (command object))))
+
+(defgeneric find-dcc-message-class (type))
+;;already defined in the context of IRC messages:
+;; (defgeneric client-log (connection message &optional prefix))
+;; (defgeneric apply-to-hooks (message))
+
+
+(export 'dcc-privmsg-message)
+(defclass dcc-privmsg-message (dcc-message) ())
+(defmethod find-dcc-message-class ((type (eql :privmsg)))
+ (find-class 'dcc-privmsg-message))
+
+(defmethod find-dcc-message-class (type)
+ (declare (ignore type))
+ (find-class 'dcc-message))
+
+(defmethod client-log ((connection dcc-connection)
+ (message dcc-message) &optional (prefix ""))
+ (let ((stream (client-stream connection)))
+ (format stream "~A~A: ~{ ~A~} \"~A\"~%"
+ prefix
+ (received-time message)
+ (butlast (arguments message))
+ (car (last (arguments message))))
+ (force-output stream)))
+
+;;
;; CTCP Message
;;
From ehuelsmann at common-lisp.net Tue Apr 24 22:02:48 2007
From: ehuelsmann at common-lisp.net (ehuelsmann at common-lisp.net)
Date: Tue, 24 Apr 2007 18:02:48 -0400 (EDT)
Subject: [cl-irc-cvs] r198 - trunk
Message-ID: <20070424220248.4EC771008@common-lisp.net>
Author: ehuelsmann
Date: Tue Apr 24 18:02:47 2007
New Revision: 198
Modified:
trunk/parse-message.lisp
Log:
r197 followup: disable (yet) unimplemented part (ctcp messages).
Modified: trunk/parse-message.lisp
==============================================================================
--- trunk/parse-message.lisp (original)
+++ trunk/parse-message.lisp Tue Apr 24 18:02:47 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)))
From ehuelsmann at common-lisp.net Tue Apr 24 22:15:08 2007
From: ehuelsmann at common-lisp.net (ehuelsmann at common-lisp.net)
Date: Tue, 24 Apr 2007 18:15:08 -0400 (EDT)
Subject: [cl-irc-cvs] r199 - trunk
Message-ID: <20070424221508.81A132D076@common-lisp.net>
Author: ehuelsmann
Date: Tue Apr 24 18:15:07 2007
New Revision: 199
Modified:
trunk/package.lisp
trunk/protocol.lisp
Log:
Add a dcc-chat-connection class; a non-abstract subclass of dcc-connection.
Modified: trunk/package.lisp
==============================================================================
--- trunk/package.lisp (original)
+++ trunk/package.lisp Tue Apr 24 18:15:07 2007
@@ -141,9 +141,11 @@
:ison
;; DCC specific dictionary
:dcc-connection
+ :dcc-chat-connection
:irc-connection
:close-on-main
:remote-user
:dcc-close
+ :make-dcc-chat-connection
)))
Modified: trunk/protocol.lisp
==============================================================================
--- trunk/protocol.lisp (original)
+++ trunk/protocol.lisp Tue Apr 24 18:15:07 2007
@@ -335,7 +335,8 @@
#+openmcl (ccl:process-kill process)
#+armedbear (ext:destroy-thread process))
-(defun read-message-loop (connection)
+(defgeneric read-message-loop (connection))
+(defmethod read-message-loop (connection)
(loop while (read-message connection)))
@@ -360,11 +361,13 @@
(force-output (output-stream connection))
raw-message))
-(defmethod get-hooks ((connection connection) (class symbol))
+;;applies to both irc and dcc-connections
+(defmethod get-hooks (connection (class symbol))
"Return a list of all hooks for `class'."
(gethash class (hooks connection)))
-(defmethod add-hook ((connection connection) class hook)
+;;applies to both irc and dcc-connections
+(defmethod add-hook (connection class hook)
"Add `hook' to `class'."
(setf (gethash class (hooks connection))
(pushnew hook (gethash class (hooks connection)))))
@@ -479,6 +482,9 @@
;; CHAT related generic functions
(defgeneric send-dcc-message (connection message))
+;;already defined in relation to `connection'
+;; (defgeneric read-message (connection))
+;;(defgeneric dcc-message-event (message))
;; SEND related generic functions
;;
@@ -487,6 +493,10 @@
(and (streamp stream)
(open-stream-p stream))))
+(defmethod send-dcc-message ((connection dcc-connection) message)
+ (format (output-stream connection) "~A~%" message)
+ (force-output (network-stream connection)))
+
(defmethod dcc-close ((connection dcc-connection))
#+(and sbcl (not sb-thread))
(sb-sys:invalidate-descriptor
@@ -498,6 +508,68 @@
(dcc-connections (irc-connection connection))
(remove connection (dcc-connections (irc-connection connection)))))
+
+(defclass dcc-chat-connection (dcc-connection)
+ ((output-stream
+ :initarg :output-stream
+ :initform nil
+ :accessor output-stream
+ :documentation "Stream used to communicate with the other end
+of the network pipe.")
+ (hooks
+ :initform (make-hash-table :test #'equal)
+ :accessor hooks))
+ (:documentation ""))
+
+
+(defun make-dcc-chat-connection (&key (remote-user nil)
+;; (remote-address nil)
+;; (remote-port nil)
+ (client-stream nil)
+ (irc-connection nil)
+ (close-on-main t)
+ (socket nil)
+ (network-stream nil)
+ (outgoing-external-format *default-outgoing-external-format*)
+ (hooks nil))
+ (let* ((output-stream (flexi-streams:make-flexi-stream
+ network-stream
+ :element-type 'character
+ :external-format (external-format-fixup
+ outgoing-external-format)))
+ (connection (make-instance 'dcc-chat-connection
+ :remote-user remote-user
+ :client-stream client-stream
+ :output-stream output-stream
+ :irc-connection irc-connection
+ :close-on-main close-on-main
+ :socket socket
+ :network-stream network-stream)))
+ (dolist (hook hooks)
+ (add-hook connection (car hook) (cdar hook)))
+ connection))
+
+(defmethod read-message ((connection dcc-chat-connection))
+ (when (connectedp connection)
+ (let* ((msg-string (read-protocol-line connection))
+ (message (create-dcc-message msg-string)))
+ (setf (connection message) connection)
+ (when *debug-p*
+ (format *debug-stream* "~A" (describe message))
+ (force-output *debug-stream*))
+ (dcc-message-event connection message)
+ message))) ; needed because of the "loop while" in read-message-loop
+
+(defmethod read-message-loop ((connection dcc-chat-connection))
+ ;; no special setup
+ (call-next-method)
+ ;; now, make sure the connection was closed and cleaned up properly...
+ ;; it *was* the last message, after all...
+ ;;##TODO, maybe we need some kind of 'auto-clean' slot to indicate
+ ;; this is the desired behaviour?
+ )
+
+
;;
;; Channel
;;
@@ -968,8 +1040,8 @@
(car (last (arguments message))))
(force-output stream)))
-
-(defmethod apply-to-hooks ((message irc-message))
+;; applies to both irc- and dcc-messages
+(defmethod apply-to-hooks (message)
"Applies any applicable hooks to `message'.
Returns non-nil if any of the hooks do."
From ehuelsmann at common-lisp.net Tue Apr 24 22:23:40 2007
From: ehuelsmann at common-lisp.net (ehuelsmann at common-lisp.net)
Date: Tue, 24 Apr 2007 18:23:40 -0400 (EDT)
Subject: [cl-irc-cvs] r200 - trunk
Message-ID: <20070424222340.93EC03F003@common-lisp.net>
Author: ehuelsmann
Date: Tue Apr 24 18:23:39 2007
New Revision: 200
Modified:
trunk/event.lisp
trunk/package.lisp
Log:
r199 followup: read-message calls dcc-message-event. Provide it.
Modified: trunk/event.lisp
==============================================================================
--- trunk/event.lisp (original)
+++ trunk/event.lisp Tue Apr 24 18:23:39 2007
@@ -15,6 +15,16 @@
(unless (apply-to-hooks message)
(client-log (connection message) message "UNHANDLED-EVENT:")))
+(defgeneric dcc-message-event (connection message)
+ (:documentation "Upon receipt of an IRC message from the
+connection's stream, irc-message-event will be called with the
+message."))
+
+(defmethod dcc-message-event (connection (message dcc-message))
+ (declare (ignore connection))
+ (unless (apply-to-hooks message)
+ (client-log (connection message) message "UNHANDLED-EVENT:")))
+
(defgeneric default-hook (message)
(:documentation "Minimum action to be executed upon reception
Modified: trunk/package.lisp
==============================================================================
--- trunk/package.lisp (original)
+++ trunk/package.lisp Tue Apr 24 18:23:39 2007
@@ -146,6 +146,7 @@
:close-on-main
:remote-user
:dcc-close
+ :dcc-message-event
:make-dcc-chat-connection
)))
From ehuelsmann at common-lisp.net Tue Apr 24 22:28:03 2007
From: ehuelsmann at common-lisp.net (ehuelsmann at common-lisp.net)
Date: Tue, 24 Apr 2007 18:28:03 -0400 (EDT)
Subject: [cl-irc-cvs] r201 - trunk
Message-ID: <20070424222803.80AFD1008@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))
From ehuelsmann at common-lisp.net Sat Apr 28 14:14:23 2007
From: ehuelsmann at common-lisp.net (ehuelsmann at common-lisp.net)
Date: Sat, 28 Apr 2007 10:14:23 -0400 (EDT)
Subject: [cl-irc-cvs] r202 - trunk
Message-ID: <20070428141423.D294372086@common-lisp.net>
Author: ehuelsmann
Date: Sat Apr 28 10:14:23 2007
New Revision: 202
Modified:
trunk/command.lisp
Log:
Add missing CTCP primitive: ctcp-reply.
Modified: trunk/command.lisp
==============================================================================
--- trunk/command.lisp (original)
+++ trunk/command.lisp Sat Apr 28 10:14:23 2007
@@ -58,6 +58,7 @@
(defgeneric userhost (connection nickname))
(defgeneric ison (connection user))
(defgeneric ctcp (connection target message))
+(defgeneric ctcp-reply (connection target message))
(defgeneric ctcp-chat-initiate (connection nickname))
@@ -348,6 +349,9 @@
(defmethod ctcp ((connection connection) target message)
(send-irc-message connection :privmsg target (make-ctcp-message message)))
+(defmethod ctcp-reply ((connection connection) target message)
+ (send-irc-message connection :notice target (make-ctcp-message message)))
+
#|
There's too much wrong with this method to fix it now.
From ehuelsmann at common-lisp.net Sun Apr 29 18:08:23 2007
From: ehuelsmann at common-lisp.net (ehuelsmann at common-lisp.net)
Date: Sun, 29 Apr 2007 14:08:23 -0400 (EDT)
Subject: [cl-irc-cvs] r203 - trunk
Message-ID: <20070429180823.10F063D00B@common-lisp.net>
Author: ehuelsmann
Date: Sun Apr 29 14:08:22 2007
New Revision: 203
Modified:
trunk/command.lisp
trunk/utility.lisp
trunk/variable.lisp
Log:
Add SSL support for IRC connections, only if CL+SSL is available when calling
connect.
Modified: trunk/command.lisp
==============================================================================
--- trunk/command.lisp (original)
+++ trunk/command.lisp Sun Apr 29 14:08:22 2007
@@ -247,13 +247,29 @@
(password nil)
(mode 0)
(server *default-irc-server*)
- (port *default-irc-server-port*)
+ (port :default)
(connection-type 'connection)
+ (connection-security :none)
(logging-stream t))
- "Connect to server and return a connection object."
- (let* ((socket (usocket:socket-connect server port
+ "Connect to server and return a connection object.
+
+`port' and `connection-security' have a relation: when `port' equals
+`:default' `*default-irc-server-port*' is used to find which port to
+connect to. `connection-security' determines which port number is found.
+
+`connection-security' can be either `:none' or `:ssl'. When passing
+`:ssl', the cl+ssl library must have been loaded by the caller.
+"
+ (let* ((port (if (eq port :default)
+ ;; get the default port for this type of connection
+ (getf *default-irc-server-port* connection-security)
+ port))
+ (socket (usocket:socket-connect server port
:element-type 'flexi-streams:octet))
- (stream (usocket:socket-stream socket))
+ (stream (if (eq connection-security :ssl)
+ (dynfound-funcall (make-ssl-client-stream :cl+ssl)
+ (usocket:socket-stream socket))
+ (usocket:socket-stream socket)))
(connection (make-connection :connection-type connection-type
:socket socket
:network-stream stream
Modified: trunk/utility.lisp
==============================================================================
--- trunk/utility.lisp (original)
+++ trunk/utility.lisp Sun Apr 29 14:08:22 2007
@@ -181,6 +181,30 @@
buf-len))
(try-decode-line buf *default-incoming-external-formats*))))
+(defmacro dynfound-funcall ((symbol-name &optional package) &rest parameters)
+ (let ((package-sym (gensym))
+ (symbol-sym (gensym))
+ (fun-sym (gensym)))
+ `(let* ((,package-sym ,(if package package *package*))
+ (,symbol-sym ,(if (symbolp symbol-name)
+ `',symbol-name
+ symbol-name))
+ (,symbol-sym (find-symbol
+ ,(if (symbolp symbol-name)
+ `(symbol-name ,symbol-sym)
+ `(if (symbolp ,symbol-sym)
+ (symbol-name ,symbol-sym)
+ ,symbol-sym))
+ ,package-sym))
+ (,fun-sym (when (and ,symbol-sym (fboundp ,symbol-sym))
+ (symbol-function ,symbol-sym))))
+ (unless ,symbol-sym
+ (error "Can't resolve symbol ~A in package ~A"
+ ,symbol-sym ,package-sym))
+ (if ,fun-sym
+ (funcall ,fun-sym , at parameters)
+ (error "Symbol ~A in package ~A isn't fbound"
+ ,symbol-sym ,package-sym)))))
(defun substring (string start &optional end)
(let* ((end-index (if end end (length string)))
Modified: trunk/variable.lisp
==============================================================================
--- trunk/variable.lisp (original)
+++ trunk/variable.lisp Sun Apr 29 14:08:22 2007
@@ -22,7 +22,9 @@
(defvar *default-nickname* "cl-irc")
(defvar *default-irc-server* "irc.freenode.net")
-(defvar *default-irc-server-port* 6667)
+(defvar *default-irc-server-port* '(:none 6667 ;; most used for normal IRC
+ :ssl 6679 ;; most used for SSL IRC
+ ))
(defvar *default-quit-message*
"Common Lisp IRC library - http://common-lisp.net/project/cl-irc")
From ehuelsmann at common-lisp.net Mon Apr 30 07:56:06 2007
From: ehuelsmann at common-lisp.net (ehuelsmann at common-lisp.net)
Date: Mon, 30 Apr 2007 03:56:06 -0400 (EDT)
Subject: [cl-irc-cvs] r204 - trunk
Message-ID: <20070430075606.EE6803700E@common-lisp.net>
Author: ehuelsmann
Date: Mon Apr 30 03:56:05 2007
New Revision: 204
Modified:
trunk/command.lisp
trunk/event.lisp
trunk/package.lisp
trunk/protocol.lisp
Log:
DCC implementation checkpoint: Working DCC CHAT with passive local side.
'passive local' == either remote initiates or local passive initiative.
Modified: trunk/command.lisp
==============================================================================
--- trunk/command.lisp (original)
+++ trunk/command.lisp Mon Apr 30 03:56:05 2007
@@ -59,7 +59,19 @@
(defgeneric ison (connection user))
(defgeneric ctcp (connection target message))
(defgeneric ctcp-reply (connection target message))
-(defgeneric ctcp-chat-initiate (connection nickname))
+(defgeneric ctcp-chat-initiate (connection nickname &key passive)
+ (:documentation "Initiate a DCC chat session with `nickname' associated
+with `connection'.
+
+If `passive' is non-NIL, the remote is requested to serve as a DCC
+host. Otherwise, the local system will serve as a DCC host. The
+latter may be a problem for firewalled or NATted hosts."))
+(defgeneric dcc-request-accept (message)
+ (:documentation ""))
+(defgeneric dcc-request-reject (message &optional reason)
+ (:documentation ""))
+(defgeneric dcc-request-cancel (connection token)
+ (:documentation ""))
(defmethod pass ((connection connection) (password string))
@@ -138,6 +150,9 @@
(defmethod quit ((connection connection) &optional (message *default-quit-message*))
(remove-all-channels connection)
(remove-all-users connection)
+ (dolist (dcc (dcc-connections connection))
+ (when (close-on-main dcc)
+ (quit dcc "Main IRC server connection lost.")))
(unwind-protect
(send-irc-message connection :quit message)
#+(and sbcl (not sb-thread))
@@ -368,23 +383,174 @@
(defmethod ctcp-reply ((connection connection) target message)
(send-irc-message connection :notice target (make-ctcp-message message)))
-#|
-There's too much wrong with this method to fix it now.
-(defmethod ctcp-chat-initiate ((connection connection) (nickname string))
- #+sbcl
- (let ((socket (sb-bsd-sockets:make-inet-socket :stream :tcp))
- (port 44347))
- (sb-bsd-sockets:socket-bind socket #(127 0 0 1) port) ; arbitrary port
- (sb-bsd-sockets:socket-listen socket 1) ; accept one connection
- (ctcp connection nickname
- (format nil "DCC CHAT chat ~A ~A"
- ; the use of hostname here is incorrect (it could be a firewall's IP)
- (host-byte-order (hostname (user connection))) port))
- (make-dcc-connection :user (find-user connection nickname)
- :input-stream t
- :output-stream (sb-bsd-sockets:socket-make-stream socket :input t :output t :buffering :none)
- :socket socket))
- #-sbcl (warn "ctcp-chat-initiate is not supported on this implementation.")
- )
+;; Intermezzo: Manage outstanding offers
+
+(defvar *passive-offer-sequence-token* 0)
+
+(defgeneric dcc-add-offer (connection nickname type token &optional proto)
+ (:documentation "Adds an offer to the list off outstanding offers list
+for `connection'."))
+
+(defgeneric dcc-remove-offer (connection token)
+ ;; Tokens are uniquely defined within the scope of the library,
+ ;; so we don't need anything but the token to actually remove an offer
+ (:documentation "Remove an offer from the list of outstanding offers
+for `connection'."))
+
+(defgeneric dcc-get-offer (connection token))
+(defgeneric dcc-get-offers (connection nickname &key type token))
+
+(defun matches-offer-by-token-p (offer token)
+ (equal (third offer) token))
+
+(defun matches-offer-by-user-p (offer user)
+ (equal (first offer) user))
+
+(defun offer-matches-message-p (offer message-nick message-type message-token)
+ (and (equal (first offer) message-nick)
+ (equal (second offer) message-type)
+ (equal (third offer) message-token)))
+
+(defmethod dcc-add-offer (connection nickname type token &optional proto)
+ (push (list nickname type token) (dcc-offers connection)))
+
+(defmethod dcc-remove-offer (connection token)
+ (setf (dcc-offers connection)
+ (remove-if #'(lambda (x)
+ (matches-offer-by-token-p x token))
+ (dcc-offers connection))))
+
+(defmethod dcc-get-offer (connection token)
+ (let ((offer-list (remove-if #'(lambda (x)
+ (not (equal (third x) token)))
+ (dcc-offers connection))))
+ (first offer-list)))
+
+(defmethod dcc-get-offers (connection nickname &key type token)
+ (let* ((results (remove-if #'(lambda (x)
+ (not (matches-offer-by-user-p x nickname)))
+ (dcc-offers connection)))
+ (results (if type
+ (remove-if #'(lambda (x)
+ (not (equal type (second x)))) results)
+ results))
+ (results (if token
+ (remove-if #'(lambda (x)
+ (not (equal token (third x)))) results))))
+ results))
+
+;; End of intermezzo
+
+;;
+;; And we move on with the definitions required to manage the protocol
+;;
+
+(defmethod ctcp-chat-initiate ((connection connection) (nickname string)
+ &key passive)
+ (if passive
+ ;; do passive request
+ (let ((token (princ-to-string (incf *passive-offer-sequence-token*))))
+ ;; tokens have been specified to be integer values,
+ (dcc-add-offer connection nickname "CHAT" token)
+ (ctcp connection nickname
+ (format nil "DCC CHAT CHAT ~A 0 ~A"
+ (usocket:host-byte-order #(1 1 1 1))
+ token))
+ token)
+ ;; or do active request
+ (error "Active DCC initiating not (yet) supported.")))
+
+(defmethod dcc-request-cancel (connection token)
+ (dcc-remove-offer connection token)
+ (if (stringp token)
+ (let ((offer (dcc-offer-get connection token)))
+ ;; We have a passive request; active ones have an associated
+ ;; socket instead...
+ (ctcp-reply connection (first offer)
+ (format nil "DCC REJECT ~A ~A" (second offer) token)))
+ (progn
+ ;; do something to close the socket here...
+ ;; OTOH, we don't support active sockets (yet), so, comment out.
+#|
+ (usocket:socket-close token)
+ (ctcp-reply connection nickname (format nil
+ "ERRMSG DCC ~A timed out" type))
|#
+ )))
+
+(defmethod dcc-request-accept ((message ctcp-dcc-chat-request-message))
+ ;; There are 2 options here: it was an active dcc offer or a passive one
+ ;; For now, we'll support only active offers (where we act as a client)
+ (let* ((raw-offer (car (last (arguments message))))
+ (clean-offer (string-trim (list +soh+) raw-offer))
+ (args (tokenize-string clean-offer))
+ (remote-ip (ignore-errors (parse-integer (fourth args))))
+ (remote-port (ignore-errors (parse-integer (fifth args))))
+ (their-token (sixth args))
+ (irc-connection (connection message)))
+ (when (string= (string-upcase (third args)) "CHAT")
+ (if (= remote-port 0)
+ ;; a passive chat request, which we don't support (yet):
+ ;; we don't act as a server yet
+ (ctcp-reply irc-connection (source message)
+ "ERRMSG DCC CHAT passive-CHAT unavailable")
+ (progn
+ (when their-token
+ (let ((offer (dcc-get-offer irc-connection their-token)))
+ (when (or (null offer)
+ (not (offer-matches-message-p offer
+ (source message)
+ "CHAT" their-token)))
+ (ctcp-reply irc-connection (source message)
+ (format nil
+ "ERRMSG DCC CHAT invalid token (~A)"
+ their-token))
+ (return-from dcc-request-accept))))
+ ;; ok, so either there was no token, or it matches
+ ;;
+ ;; When there was no token, but there was a chat request
+ ;; with the same nick and type, maybe we achieved the same
+ ;; in the end. (This would be caused by the other side
+ ;; initiating the request manually after the client blocked
+ ;; and automatic response.
+ (let ((offers (dcc-get-offers irc-connection (source message)
+ :type "CHAT")))
+ (when offers
+ ;; if there are more offers, consider the first fulfilled.
+ (dcc-remove-offer irc-connection (third (first offers)))))
+
+ (let ((socket (unless (or (null remote-ip)
+ (null remote-port)
+ (= 0 remote-port))
+ (usocket:socket-connect
+ remote-ip remote-port
+ :element-type 'flexi-streams:octet))))
+ (dcc-remove-offer irc-connection their-token)
+ (make-dcc-chat-connection
+ :irc-connection irc-connection
+ :remote-user (find-user irc-connection (source message))
+ :socket socket
+ :network-stream (usocket:socket-stream socket))))))))
+
+(defmethod dcc-request-reject ((message ctcp-dcc-chat-request-message)
+ &optional reason)
+ (ctcp-reply (connection message) (source message)
+ (format nil "ERRMSG DCC CHAT ~A" (if reason reason
+ "rejected"))))
+
+;;
+;; IRC commands which make some sence in a DCC CHAT context
+;;
+
+(defmethod quit ((connection dcc-chat-connection)
+ &optional message)
+ (when message
+ (ignore-errors (send-dcc-message connection message)))
+ (ignore-errors
+ (dcc-close connection)))
+
+;;## TODO
+;; ctcp action, time, source, finger, ping+pong message generation
+;; btw: those could be defined for 'normal' IRC too; currently
+;; we only generate the responses to others' messages.
Modified: trunk/event.lisp
==============================================================================
--- trunk/event.lisp (original)
+++ trunk/event.lisp Mon Apr 30 03:56:05 2007
@@ -329,6 +329,7 @@
(remove-channel user channel)
(remove-user channel user)))))))
+;;###TODO: generate these responses in a DCC CHAT context too.
(macrolet ((define-ctcp-reply-hook ((message-var message-type) &body body)
`(defmethod default-hook ((,message-var ,message-type))
(when (ctcp-request-p ,message-var)
Modified: trunk/package.lisp
==============================================================================
--- trunk/package.lisp (original)
+++ trunk/package.lisp Mon Apr 30 03:56:05 2007
@@ -149,5 +149,9 @@
:dcc-message
:dcc-message-event
:make-dcc-chat-connection
+ :ctcp-chat-initiate
+ :dcc-request-reject
+ :dcc-request-accept
+ :dcc-request-cancel
)))
Modified: trunk/protocol.lisp
==============================================================================
--- trunk/protocol.lisp (original)
+++ trunk/protocol.lisp Mon Apr 30 03:56:05 2007
@@ -124,6 +124,7 @@
:initform *default-irc-server-port*)
(socket
:initarg :socket
+ :reader socket
:documentation "Slot to store socket (for internal use only).")
(network-stream
:initarg :network-stream
@@ -144,6 +145,11 @@
:initform t
:documentation "Messages coming back from the server are sent to
this stream.")
+ (dcc-offers
+ :accessor dcc-offers
+ :initform '()
+ :documentation "The DCC offers sent out in association with this
+connection.")
(dcc-connections
:accessor dcc-connections
:initform '()
@@ -497,6 +503,14 @@
(format (output-stream connection) "~A~%" message)
(force-output (network-stream connection)))
+(defmethod initialize-instance :after ((instance dcc-connection)
+ &rest initargs
+ &key &allow-other-keys)
+ (push instance *dcc-connections*)
+ (when (irc-connection instance)
+ (push instance (dcc-connections (irc-connection instance)))))
+
+
(defmethod dcc-close ((connection dcc-connection))
#+(and sbcl (not sb-thread))
(sb-sys:invalidate-descriptor
@@ -1186,4 +1200,3 @@
(butlast (arguments message))
(car (last (arguments message))))
(force-output stream)))
-