cl-irc-cvs April 2007

cl-irc-cvs@common-lisp.net

1 participants
26 discussions

[cl-irc-cvs] r194 - trunk
by ehuelsmann＠common-lisp.net 24 Apr '07

24 Apr '07

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\"~%"

1 0

[cl-irc-cvs] r193 - trunk
by ehuelsmann＠common-lisp.net 24 Apr '07

24 Apr '07

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 +;;<none yet, we don't do SEND yet...> -(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)))

1 0

[cl-irc-cvs] r192 - trunk
by ehuelsmann＠common-lisp.net 23 Apr '07

23 Apr '07

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

1 0

[cl-irc-cvs] r191 - trunk
by ehuelsmann＠common-lisp.net 22 Apr '07

22 Apr '07

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

1 0

[cl-irc-cvs] r190 - trunk
by ehuelsmann＠common-lisp.net 22 Apr '07

22 Apr '07

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

1 0

[cl-irc-cvs] r189 - trunk
by ehuelsmann＠common-lisp.net 22 Apr '07

22 Apr '07

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

1 0

[cl-irc-cvs] r188 - trunk
by ehuelsmann＠common-lisp.net 22 Apr '07

22 Apr '07

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

1 0

[cl-irc-cvs] r187 - trunk
by ehuelsmann＠common-lisp.net 22 Apr '07

22 Apr '07

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

1 0

[cl-irc-cvs] r186 - trunk
by ehuelsmann＠common-lisp.net 21 Apr '07

21 Apr '07

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

1 0

[cl-irc-cvs] r185 - trunk
by ehuelsmann＠common-lisp.net 21 Apr '07

21 Apr '07

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)

1 0

2024

2023

2022

2021

2020

2019

2018

2017

2016

2015

2014

2013

2012

2011

2010

2009

2008

2007

2006

2005

2004

cl-irc-cvs April 2007