April 2007 - cl-irc-cvs@common-lisp.net - mailman3.common-lisp.net

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

30 Apr '07

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

1 0

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

29 Apr '07

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 ,@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")

1 0

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

28 Apr '07

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.

1 0

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

25 Apr '07

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

1 0

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

25 Apr '07

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

1 0

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

25 Apr '07

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)) <defined in event.lisp> ;; SEND related generic functions ;;<none yet, we don't do SEND yet...> @@ -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."

1 0

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

25 Apr '07

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

1 0

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

25 Apr '07

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

1 0

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

24 Apr '07

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

1 0

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

24 Apr '07

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

1 0

[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

[cl-irc-cvs] r184 - trunk/test
by ehuelsmann＠common-lisp.net 19 Apr '07

19 Apr '07

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.

1 0

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

19 Apr '07

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

1 0

[cl-irc-cvs] r182 - in public_html: . releases
by ehuelsmann＠common-lisp.net 19 Apr '07

19 Apr '07

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 @@ <body> <div class="header"> - <h1>cl-irc 0.8.0</h1> + <h1>cl-irc 0.8.1</h1> </div> <div class="body"> @@ -28,7 +28,8 @@ <h2>News</h2> <div class="level"> <ul> - <li>Version 0.8.0 released (user and channel mode tracking, characterset support on the irc network) + <li>Version 0.8.1 released (small fixes: KICK message processing, channel mode tracking)</li> + <li>Version 0.8.0 released (user and channel mode tracking, characterset support on the irc network)</li> <li>Version 0.7.0 released (RPL_ISUPPORT, many small tweaks and fixes)</li> <li>Version 0.6.0 released (interim release while common-lisp.net was down)</li> <li>Version 0.5.0 released (package rename and minor changes)</li> 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

1 0

[cl-irc-cvs] r181 - tags/0.8.1
by ehuelsmann＠common-lisp.net 19 Apr '07

19 Apr '07

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

1 0

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

19 Apr '07

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.

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