cl-irc-cvs February 2006

cl-irc-cvs@common-lisp.net

1 participants
20 discussions

[cl-irc-cvs] CVS cl-irc
by ehuelsmann 22 Feb '06

22 Feb '06

Update of /project/cl-irc/cvsroot/cl-irc In directory common-lisp:/tmp/cvs-serv598 Modified Files: protocol.lisp event.lisp Log Message: Prevent ctcp request loops: NOTICE messages are responses. By Andreas Fuchs. --- /project/cl-irc/cvsroot/cl-irc/protocol.lisp 2006/02/22 18:55:18 1.38 +++ /project/cl-irc/cvsroot/cl-irc/protocol.lisp 2006/02/22 18:59:13 1.39 @@ -1,4 +1,4 @@ -;;;; $Id: protocol.lisp,v 1.38 2006/02/22 18:55:18 ehuelsmann Exp $ +;;;; $Id: protocol.lisp,v 1.39 2006/02/22 18:59:13 ehuelsmann Exp $ ;;;; $Source: /project/cl-irc/cvsroot/cl-irc/protocol.lisp,v $ ;;;; See LICENSE for licensing information. @@ -932,6 +932,12 @@ (declare (ignore type)) (find-class 'standard-ctcp-message)) +(defmethod ctcp-request-p ((message ctcp-mixin)) + (string= (command message) :privmsg)) + +(defmethod ctcp-reply-p ((message ctcp-mixin)) + (string= (command message) :notice)) + (defmethod client-log ((connection connection) (message ctcp-mixin) &optional (prefix "")) (let ((stream (client-stream connection))) (format stream "~A~A: ~A (~A): ~A~{ ~A~} \"~A\"~%" --- /project/cl-irc/cvsroot/cl-irc/event.lisp 2006/02/22 18:54:18 1.23 +++ /project/cl-irc/cvsroot/cl-irc/event.lisp 2006/02/22 18:59:13 1.24 @@ -1,4 +1,4 @@ -;;;; $Id: event.lisp,v 1.23 2006/02/22 18:54:18 ehuelsmann Exp $ +;;;; $Id: event.lisp,v 1.24 2006/02/22 18:59:13 ehuelsmann Exp $ ;;;; $Source: /project/cl-irc/cvsroot/cl-irc/event.lisp,v $ ;;;; See LICENSE for licensing information. @@ -289,52 +289,52 @@ (remove-channel user channel) (remove-user channel user))))))) -(defmethod default-hook ((message ctcp-time-message)) - (multiple-value-bind - (second minute hour date month year day) - (get-decoded-time) - (send-irc-message - (connection message) - :notice (source message) - (make-ctcp-message - (format nil "TIME ~A" - (make-time-message second minute hour date month year day)))))) - -(defmethod default-hook ((message ctcp-source-message)) - (send-irc-message - (connection message) - :notice - (source message) - (make-ctcp-message - (format nil "SOURCE ~A:~A:~A" - *download-host* - *download-directory* - *download-file*)))) - -(defmethod default-hook ((message ctcp-finger-message)) - (let* ((user (user (connection message))) - (finger-info (if (not (zerop (length (realname user)))) - (realname user) - (nickname user)))) - (send-irc-message - (connection message) - :notice (source message) - (make-ctcp-message - (format nil "FINGER ~A" finger-info))))) - -(defmethod default-hook ((message ctcp-version-message)) - (send-irc-message - (connection message) - :notice (source message) - (make-ctcp-message - (format nil "VERSION ~A" *ctcp-version*)))) - -(defmethod default-hook ((message ctcp-ping-message)) - (send-irc-message - (connection message) - :notice (source message) - (make-ctcp-message - (format nil "PING ~A" (car (last (arguments message))))))) +(macrolet ((define-ctcp-reply-hook ((message-var message-type) &body body) + `(defmethod default-hook ((,message-var ,message-type)) + (when (ctcp-request-p ,message-var) + ,@body)))) + (define-ctcp-reply-hook (message ctcp-time-message) + (multiple-value-bind + (second minute hour date month year day) + (get-decoded-time) + (send-irc-message + (connection message) + :notice (source message) + (make-ctcp-message + (format nil "TIME ~A" + (make-time-message second minute hour date month year day)))))) + (define-ctcp-reply-hook (message ctcp-source-message) + (send-irc-message + (connection message) + :notice + (source message) + (make-ctcp-message + (format nil "SOURCE ~A:~A:~A" + *download-host* + *download-directory* + *download-file*)))) + (define-ctcp-reply-hook (message ctcp-finger-message) + (let* ((user (user (connection message))) + (finger-info (if (not (zerop (length (realname user)))) + (realname user) + (nickname user)))) + (send-irc-message + (connection message) + :notice (source message) + (make-ctcp-message + (format nil "FINGER ~A" finger-info))))) + (define-ctcp-reply-hook (message ctcp-version-message) + (send-irc-message + (connection message) + :notice (source message) + (make-ctcp-message + (format nil "VERSION ~A" *ctcp-version*)))) + (define-ctcp-reply-hook (message ctcp-ping-message) + (send-irc-message + (connection message) + :notice (source message) + (make-ctcp-message + (format nil "PING ~A" (car (last (arguments message)))))))) (defmethod irc-message-event (connection (message ctcp-dcc-chat-request-message)) (declare (ignore connection))

1 0

[cl-irc-cvs] CVS cl-irc
by ehuelsmann 22 Feb '06

22 Feb '06

Update of /project/cl-irc/cvsroot/cl-irc In directory common-lisp:/tmp/cvs-serv472 Modified Files: protocol.lisp Log Message: When changing a nick: remove under the old nick, re-add with the new one. --- /project/cl-irc/cvsroot/cl-irc/protocol.lisp 2006/02/20 06:53:25 1.37 +++ /project/cl-irc/cvsroot/cl-irc/protocol.lisp 2006/02/22 18:55:18 1.38 @@ -1,4 +1,4 @@ -;;;; $Id: protocol.lisp,v 1.37 2006/02/20 06:53:25 ehuelsmann Exp $ +;;;; $Id: protocol.lisp,v 1.38 2006/02/22 18:55:18 ehuelsmann Exp $ ;;;; $Source: /project/cl-irc/cvsroot/cl-irc/protocol.lisp,v $ ;;;; See LICENSE for licensing information. @@ -781,17 +781,17 @@ user)) (defmethod change-nickname ((connection connection) (user user) new-nickname) - (let ((new-user user) - (channels (channels user))) + (let ((channels (channels user))) (remove-user connection user) - (setf (nickname new-user) new-nickname) - (setf (normalized-nickname new-user) + (dolist (channel channels) + (remove-user channel user)) + (setf (nickname user) new-nickname) + (setf (normalized-nickname user) (normalize-nickname connection new-nickname)) (dolist (channel channels) - (remove-user channel user) - (add-user channel new-user)) + (add-user channel user)) (add-user connection user) - new-user)) + user)) ;; IRC Message ;;

1 0

[cl-irc-cvs] CVS cl-irc
by ehuelsmann 22 Feb '06

22 Feb '06

Update of /project/cl-irc/cvsroot/cl-irc In directory common-lisp:/tmp/cvs-serv379 Modified Files: event.lisp Log Message: Verify there actually *is* a user to remove. --- /project/cl-irc/cvsroot/cl-irc/event.lisp 2006/02/20 17:27:57 1.22 +++ /project/cl-irc/cvsroot/cl-irc/event.lisp 2006/02/22 18:54:18 1.23 @@ -1,4 +1,4 @@ -;;;; $Id: event.lisp,v 1.22 2006/02/20 17:27:57 ehuelsmann Exp $ +;;;; $Id: event.lisp,v 1.23 2006/02/22 18:54:18 ehuelsmann Exp $ ;;;; $Source: /project/cl-irc/cvsroot/cl-irc/event.lisp,v $ ;;;; See LICENSE for licensing information. @@ -207,9 +207,10 @@ arguments (let ((channel (find-channel connection channel)) (user (find-user connection source))) - (if (self-message-p message) - (remove-channel user channel) - (remove-user channel user)))))) + (when (and user channel) + (if (self-message-p message) + (remove-channel user channel) + (remove-user channel user))))))) (defmethod default-hook ((message irc-quit-message)) (let* ((connection (connection message)) @@ -283,9 +284,10 @@ (declare (ignore arguments)) (let* ((channel (find-channel connection channel)) (user (find-user connection nick))) - (if (self-message-p message) - (remove-channel user channel) - (remove-user channel user)))))) + (when (and user channel) + (if (self-message-p message) + (remove-channel user channel) + (remove-user channel user))))))) (defmethod default-hook ((message ctcp-time-message)) (multiple-value-bind

1 0

[cl-irc-cvs] CVS cl-irc
by ehuelsmann 20 Feb '06

20 Feb '06

Update of /project/cl-irc/cvsroot/cl-irc In directory common-lisp:/tmp/cvs-serv5767 Modified Files: package.lisp Log Message: Add arguments binding helper macro now that trailing-argument is deprecated. --- /project/cl-irc/cvsroot/cl-irc/package.lisp 2006/01/27 22:54:17 1.10 +++ /project/cl-irc/cvsroot/cl-irc/package.lisp 2006/02/20 20:37:16 1.11 @@ -1,4 +1,4 @@ -;;;; $Id: package.lisp,v 1.10 2006/01/27 22:54:17 ehuelsmann Exp $ +;;;; $Id: package.lisp,v 1.11 2006/02/20 20:37:16 ehuelsmann Exp $ ;;;; $Source: /project/cl-irc/cvsroot/cl-irc/package.lisp,v $ ;;;; See the LICENSE file for licensing information. @@ -15,6 +15,7 @@ :irc-message-event :start-background-message-handler :stop-background-message-handler + :destructuring-arguments :socket-connect :server-name :no-such-reply

1 0

[cl-irc-cvs] CVS cl-irc
by ehuelsmann 20 Feb '06

20 Feb '06

Update of /project/cl-irc/cvsroot/cl-irc In directory common-lisp:/tmp/cvs-serv4290 Modified Files: utility.lisp Log Message: Add arguments binding helper macro now that trailing-argument is deprecated. --- /project/cl-irc/cvsroot/cl-irc/utility.lisp 2006/02/15 23:24:34 1.11 +++ /project/cl-irc/cvsroot/cl-irc/utility.lisp 2006/02/20 20:26:54 1.12 @@ -1,4 +1,4 @@ -;;;; $Id: utility.lisp,v 1.11 2006/02/15 23:24:34 ehuelsmann Exp $ +;;;; $Id: utility.lisp,v 1.12 2006/02/20 20:26:54 ehuelsmann Exp $ ;;;; $Source: /project/cl-irc/cvsroot/cl-irc/utility.lisp,v $ ;;;; See the LICENSE file for licensing information. @@ -158,6 +158,75 @@ (subseq string cut-from end-position)) (values start nil)))))) + +;; +;; Message arguments binding macro +;; + + +(defmacro destructuring-arguments (lambda-list message &body body) + "Destructures the arguments slot in MESSAGE according +to LAMBDA-LIST and binds them in BODY. +destructuring-irc-message-arguments's lambda list syntax is as follows: + +reqvars::= var* +optvars::= [&optional {var | (var [init-form [supplied-p-parameter]])}*] +restvar::= [&rest var] +wholevar::= [&whole var] +lastvar::= [&last var] +lambda-list::= (wholevar reqvars optvars restvar lastvar) + +With the exception of &last, all lambda list keywords are +analogous to a destructuring lambda list's (see clhs 3.4.5). + +If &last is given, the specified variable is bound to the last +argument in the message. Specifying &last implies that all +arguments past the last of the required variables will be +ignored, even if there is no &rest lambda list keyword present. + +If both &rest and &last are specified, the last element in the +list is also included in the rest list." + (let ((valid-bare-ll-keywords '(&optional &rest &whole)) + (nothing (gensym)) + (%message (gensym))) + (labels ((keyword-ll-entry-p (entry) + (eql (schar (symbol-name entry) 0) #\&)) + (valid-bare-ll-entry-p (entry) + (or (not (keyword-ll-entry-p entry)) + (member entry valid-bare-ll-keywords :test 'string=))) + (append-&rest-p (last-entries destructuring-ll) + (not (or (null last-entries) + (member '&rest destructuring-ll :test 'string=))))) + (let* ((last-entries (member '&last lambda-list :test 'string=)) + (last-variable (second last-entries)) + (destructuring-ll (butlast lambda-list (length last-entries))) + (invalid-ll-entries (remove-if #'valid-bare-ll-entry-p + destructuring-ll))) + (unless (or (null last-entries) (= 2 (length last-entries))) + (error "Invalid number of &last arguments in ~S" lambda-list)) + (when (and last-variable (member last-variable destructuring-ll)) + (error "Duplicate entry ~S in lambda list ~S" + last-variable lambda-list)) + (when invalid-ll-entries + (error "Invalid lambda list entries ~S found in ~S" + invalid-ll-entries lambda-list)) + `(let ((,%message ,message)) + (let (,@(when last-entries + `((,last-variable (car (last (arguments ,%message))))))) + (destructuring-bind ,(if (append-&rest-p last-entries + destructuring-ll) + (append destructuring-ll + `(&rest ,nothing)) + destructuring-ll) + (arguments ,%message) + ,@(when (append-&rest-p last-entries destructuring-ll) + `((declare (ignore ,nothing)))) + ,@body))))))) + +;; +;; RPL_ISUPPORT support routines +;; + (defun parse-isupport-prefix-argument (prefix) (declare (type string prefix)) (let ((closing-paren-pos (position #\) prefix)))

1 0

[cl-irc-cvs] CVS cl-irc
by ehuelsmann 20 Feb '06

20 Feb '06

Update of /project/cl-irc/cvsroot/cl-irc In directory common-lisp:/tmp/cvs-serv9527 Modified Files: event.lisp Log Message: Oops! Too few closing parents... --- /project/cl-irc/cvsroot/cl-irc/event.lisp 2006/02/20 06:53:25 1.21 +++ /project/cl-irc/cvsroot/cl-irc/event.lisp 2006/02/20 17:27:57 1.22 @@ -1,4 +1,4 @@ -;;;; $Id: event.lisp,v 1.21 2006/02/20 06:53:25 ehuelsmann Exp $ +;;;; $Id: event.lisp,v 1.22 2006/02/20 17:27:57 ehuelsmann Exp $ ;;;; $Source: /project/cl-irc/cvsroot/cl-irc/event.lisp,v $ ;;;; See LICENSE for licensing information. @@ -332,7 +332,7 @@ (connection message) :notice (source message) (make-ctcp-message - (format nil "PING ~A" (car (last (arguments message))))) + (format nil "PING ~A" (car (last (arguments message))))))) (defmethod irc-message-event (connection (message ctcp-dcc-chat-request-message)) (declare (ignore connection))

1 0

[cl-irc-cvs] CVS cl-irc
by ehuelsmann 20 Feb '06

20 Feb '06

Update of /project/cl-irc/cvsroot/cl-irc In directory common-lisp:/tmp/cvs-serv30492 Modified Files: protocol.lisp event.lisp Log Message: Remove last uses of trailing-argument. --- /project/cl-irc/cvsroot/cl-irc/protocol.lisp 2006/02/15 20:14:21 1.36 +++ /project/cl-irc/cvsroot/cl-irc/protocol.lisp 2006/02/20 06:53:25 1.37 @@ -1,4 +1,4 @@ -;;;; $Id: protocol.lisp,v 1.36 2006/02/15 20:14:21 ehuelsmann Exp $ +;;;; $Id: protocol.lisp,v 1.37 2006/02/20 06:53:25 ehuelsmann Exp $ ;;;; $Source: /project/cl-irc/cvsroot/cl-irc/protocol.lisp,v $ ;;;; See LICENSE for licensing information. @@ -889,8 +889,8 @@ (received-time message) (command message) (source message) - (arguments message) - (trailing-argument message)) + (butlast (arguments message)) + (car (last (arguments message)))) (force-output stream))) (defmethod apply-to-hooks ((message irc-message)) @@ -940,7 +940,7 @@ (command message) (ctcp-command message) (source message) - (arguments message) - (trailing-argument message)) + (butlast (arguments message)) + (car (last (arguments message)))) (force-output stream))) --- /project/cl-irc/cvsroot/cl-irc/event.lisp 2006/02/19 22:47:40 1.20 +++ /project/cl-irc/cvsroot/cl-irc/event.lisp 2006/02/20 06:53:25 1.21 @@ -1,4 +1,4 @@ -;;;; $Id: event.lisp,v 1.20 2006/02/19 22:47:40 ehuelsmann Exp $ +;;;; $Id: event.lisp,v 1.21 2006/02/20 06:53:25 ehuelsmann Exp $ ;;;; $Source: /project/cl-irc/cvsroot/cl-irc/event.lisp,v $ ;;;; See LICENSE for licensing information. @@ -332,7 +332,7 @@ (connection message) :notice (source message) (make-ctcp-message - (format nil "PING ~A" (trailing-argument message))))) + (format nil "PING ~A" (car (last (arguments message))))) (defmethod irc-message-event (connection (message ctcp-dcc-chat-request-message)) (declare (ignore connection))

1 0

[cl-irc-cvs] CVS cl-irc
by ehuelsmann 19 Feb '06

19 Feb '06

Update of /project/cl-irc/cvsroot/cl-irc In directory common-lisp:/tmp/cvs-serv1364 Modified Files: event.lisp Log Message: Fix RPL_ISUPPORT when server sends more than noe response (freenode does). --- /project/cl-irc/cvsroot/cl-irc/event.lisp 2006/02/15 23:47:19 1.19 +++ /project/cl-irc/cvsroot/cl-irc/event.lisp 2006/02/19 22:47:40 1.20 @@ -1,4 +1,4 @@ -;;;; $Id: event.lisp,v 1.19 2006/02/15 23:47:19 ehuelsmann Exp $ +;;;; $Id: event.lisp,v 1.20 2006/02/19 22:47:40 ehuelsmann Exp $ ;;;; $Source: /project/cl-irc/cvsroot/cl-irc/event.lisp,v $ ;;;; See LICENSE for licensing information. @@ -63,26 +63,38 @@ invitelist-in-progress :invite) (defmethod default-hook ((message irc-rpl_isupport-message)) - (let* ((capabilities (cdr (arguments message))) - (connection (connection message)) - (current-case-mapping (case-map-name connection))) - (setf (server-capabilities connection) - (let ((new-values (mapcar #'(lambda (x) - (let ((eq-pos (position #\= x))) - (if eq-pos - (list (subseq x 0 eq-pos) - (subseq x (1+ eq-pos))) - (list x)))) capabilities))) - (merge 'list new-values (copy-seq *default-isupport-values*) - #'string= :key #'first))) - (setf (channel-mode-descriptions connection) - (chanmode-descs-from-isupport (server-capabilities connection)) - (nick-prefixes connection) - (nick-prefixes-from-isupport (server-capabilities connection))) - (when (not (equal current-case-mapping - (case-map-name connection))) - ;; we need to re-normalize nicks and channel names - (re-apply-case-mapping connection)))) + (destructuring-bind + (target &rest capabilities) + ;; the last argument contains only an explanitory text + (butlast (arguments message)) + (declare (ignore target)) + (let* ((connection (connection message)) + (current-case-mapping (case-map-name connection))) + (setf (server-capabilities connection) + (reduce #'(lambda (x y) + ;; O(n^2), but we're talking small lists anyway... + ;; maybe I should have chosen a hash interface + ;; after all... + (if (assoc (first y) x :test #'string=) + x + (cons y x))) + (append + (mapcar #'(lambda (x) + (let ((eq-pos (position #\= x))) + (if eq-pos + (list (subseq x 0 eq-pos) + (subseq x (1+ eq-pos))) + (list x)))) capabilities) + (server-capabilities connection)) + :initial-value '())) + (setf (channel-mode-descriptions connection) + (chanmode-descs-from-isupport (server-capabilities connection)) + (nick-prefixes connection) + (nick-prefixes-from-isupport (server-capabilities connection))) + (when (not (equal current-case-mapping + (case-map-name connection))) + ;; we need to re-normalize nicks and channel names + (re-apply-case-mapping connection))))) (defmethod default-hook ((message irc-rpl_whoisuser-message)) (destructuring-bind

1 0

[cl-irc-cvs] CVS cl-irc
by ehuelsmann 16 Feb '06

16 Feb '06

Update of /project/cl-irc/cvsroot/cl-irc In directory common-lisp:/tmp/cvs-serv20440 Modified Files: event.lisp parse-message.lisp Log Message: Remove debugging print forms. --- /project/cl-irc/cvsroot/cl-irc/event.lisp 2006/02/15 23:24:34 1.18 +++ /project/cl-irc/cvsroot/cl-irc/event.lisp 2006/02/15 23:47:19 1.19 @@ -1,4 +1,4 @@ -;;;; $Id: event.lisp,v 1.18 2006/02/15 23:24:34 ehuelsmann Exp $ +;;;; $Id: event.lisp,v 1.19 2006/02/15 23:47:19 ehuelsmann Exp $ ;;;; $Source: /project/cl-irc/cvsroot/cl-irc/event.lisp,v $ ;;;; See LICENSE for licensing information. @@ -232,8 +232,6 @@ (destructuring-bind (target &rest arguments) (arguments message) - (print (arguments message)) - (print arguments) (let* ((connection (connection message)) (target (or (find-channel connection target) (find-user connection target))) --- /project/cl-irc/cvsroot/cl-irc/parse-message.lisp 2006/02/15 19:14:33 1.8 +++ /project/cl-irc/cvsroot/cl-irc/parse-message.lisp 2006/02/15 23:47:19 1.9 @@ -1,4 +1,4 @@ -;;;; $Id: parse-message.lisp,v 1.8 2006/02/15 19:14:33 ehuelsmann Exp $ +;;;; $Id: parse-message.lisp,v 1.9 2006/02/15 23:47:19 ehuelsmann Exp $ ;;;; $Source: /project/cl-irc/cvsroot/cl-irc/parse-message.lisp,v $ ;;;; See the LICENSE file for licensing information. @@ -64,11 +64,9 @@ (multiple-value-bind (start return-string) (return-arguments string :start start) - (print return-string) (multiple-value-bind (return-index trailing) (return-trailing-argument string :start start) - (print trailing) (values return-index (append return-string (when (and trailing (string/= "" trailing)) (list trailing)))))))

1 0

[cl-irc-cvs] CVS cl-irc
by ehuelsmann 16 Feb '06

16 Feb '06

Update of /project/cl-irc/cvsroot/cl-irc In directory common-lisp:/tmp/cvs-serv16585 Modified Files: event.lisp utility.lisp Log Message: Fix crash on unknown modes.tility.lisp --- /project/cl-irc/cvsroot/cl-irc/event.lisp 2006/02/15 20:42:48 1.17 +++ /project/cl-irc/cvsroot/cl-irc/event.lisp 2006/02/15 23:24:34 1.18 @@ -1,4 +1,4 @@ -;;;; $Id: event.lisp,v 1.17 2006/02/15 20:42:48 ehuelsmann Exp $ +;;;; $Id: event.lisp,v 1.18 2006/02/15 23:24:34 ehuelsmann Exp $ ;;;; $Source: /project/cl-irc/cvsroot/cl-irc/event.lisp,v $ ;;;; See LICENSE for licensing information. @@ -108,9 +108,11 @@ :user-count user-count)))))) (defmethod default-hook ((message irc-rpl_topic-message)) - (setf (topic (find-channel (connection message) - (second (arguments message)))) - (trailing-argument message))) + (destructuring-bind + (target channel topic) + (arguments message) + (declare (ignore target)) + (setf (topic (find-channel (connection message) channel)) topic))) (defmethod default-hook ((message irc-rpl_namreply-message)) (let* ((connection (connection message))) @@ -159,32 +161,43 @@ (apply #'pong (connection message) (arguments message))) (defmethod default-hook ((message irc-join-message)) - (let* ((connection (connection message)) - (user (find-or-make-user - (connection message) - (source message) - :hostname (host message) - :username (user message))) - (channel (or (find-channel connection (trailing-argument message)) - (make-channel connection - :name (trailing-argument message))))) - (when (self-message-p message) - (add-channel connection channel)) - (add-user connection user) - (add-user channel user))) + (with-slots + (connection source host user arguments) + message + (destructuring-bind + (channel) + arguments + (let ((user (find-or-make-user connection source + :hostname host + :username user)) + (channel (or (find-channel connection channel) + (make-channel connection :name channel)))) + (when (self-message-p message) + (add-channel connection channel)) + (add-user connection user) + (add-user channel user))))) (defmethod default-hook ((message irc-topic-message)) - (setf (topic (find-channel (connection message) - (first (arguments message)))) - (trailing-argument message))) + (with-slots + (connection arguments) + message + (destructuring-bind + (channel &optional topic) + arguments + (setf (topic (find-channel connection channel)) topic)))) (defmethod default-hook ((message irc-part-message)) - (let* ((connection (connection message)) - (channel (find-channel connection (first (arguments message)))) - (user (find-user connection (source message)))) - (if (self-message-p message) - (remove-channel user channel) - (remove-user channel user)))) + (with-slots + (connection arguments source) + message + (destructuring-bind + (channel &optional text) + arguments + (let ((channel (find-channel connection channel)) + (user (find-user connection source))) + (if (self-message-p message) + (remove-channel user channel) + (remove-user channel user)))))) (defmethod default-hook ((message irc-quit-message)) (let* ((connection (connection message)) @@ -193,30 +206,34 @@ (remove-user-everywhere connection user)))) (defmethod default-hook ((message irc-rpl_channelmodeis-message)) - (destructuring-bind - (target &rest arguments) - ;; ignore the my own nick which is the first message argument - (rest (arguments message)) - (let* ((connection (connection message)) - (target (find-channel connection target)) + (with-slots + (connection arguments) + message + (destructuring-bind + (target channel &rest mode-arguments) + arguments + (declare (ignore target)) + (let* ((channel (find-channel connection channel)) (mode-changes - (when target - (parse-mode-arguments connection target arguments + (when channel + (parse-mode-arguments connection channel arguments :server-p (user connection))))) (dolist (change mode-changes) (destructuring-bind (op mode-name value) change - (unless (has-mode-p target mode-name) + (unless (has-mode-p channel mode-name) (add-mode target mode-name - (make-mode connection target mode-name))) + (make-mode connection channel mode-name))) (funcall (if (char= #\+ op) #'set-mode #'unset-mode) - target mode-name value)))))) + channel mode-name value))))))) (defmethod default-hook ((message irc-mode-message)) (destructuring-bind (target &rest arguments) (arguments message) + (print (arguments message)) + (print arguments) (let* ((connection (connection message)) (target (or (find-channel connection target) (find-user connection target))) @@ -235,22 +252,35 @@ target mode-name value)))))) (defmethod default-hook ((message irc-nick-message)) - (let* ((con (connection message)) - (user (find-or-make-user con (source message) - :hostname (host message) - :username (user message)))) - (change-nickname con user (trailing-argument message)))) + (with-slots + (connection source host user arguments) + message + (destructuring-bind + (new-nick) + arguments + (let* ((user (find-or-make-user connection source + :hostname host + :username user))) + (change-nickname connection user new-nick))))) (defmethod default-hook ((message irc-kick-message)) - (let* ((connection (connection message)) - (channel (find-channel connection (first (arguments message)))) - (user (find-user connection (second (arguments message))))) - (if (self-message-p message) - (remove-channel user channel) - (remove-user channel user)))) + (with-slots + (connection arguments) + message + (destructuring-bind + (channel nick &optional reason) + arguments + (declare (ignore arguments)) + (let* ((channel (find-channel connection channel)) + (user (find-user connection nick))) + (if (self-message-p message) + (remove-channel user channel) + (remove-user channel user)))))) (defmethod default-hook ((message ctcp-time-message)) - (multiple-value-bind (second minute hour date month year day) (get-decoded-time) + (multiple-value-bind + (second minute hour date month year day) + (get-decoded-time) (send-irc-message (connection message) :notice (source message) --- /project/cl-irc/cvsroot/cl-irc/utility.lisp 2006/02/15 20:14:21 1.10 +++ /project/cl-irc/cvsroot/cl-irc/utility.lisp 2006/02/15 23:24:34 1.11 @@ -1,4 +1,4 @@ -;;;; $Id: utility.lisp,v 1.10 2006/02/15 20:14:21 ehuelsmann Exp $ +;;;; $Id: utility.lisp,v 1.11 2006/02/15 23:24:34 ehuelsmann Exp $ ;;;; $Source: /project/cl-irc/cvsroot/cl-irc/utility.lisp,v $ ;;;; See the LICENSE file for licensing information. @@ -292,9 +292,11 @@ (mode-description connection target (mode-name-from-char connection target (char modes i)))) - (param-p (funcall param-req mode-rec))) - (when (and param-p - (= 0 (length arguments))) + (param-p (when mode-rec + (funcall param-req mode-rec)))) + (when (or (null mode-rec) + (and param-p + (= 0 (length arguments)))) (throw 'illegal-mode-spec nil)) (push (list this-op (mode-desc-symbol mode-rec)

1 0

[cl-irc-cvs] CVS cl-irc
by ehuelsmann 15 Feb '06

15 Feb '06

Update of /project/cl-irc/cvsroot/cl-irc In directory common-lisp:/tmp/cvs-serv27877 Modified Files: event.lisp Log Message: Fix breakage where a quit message is sent before join or namreply (typically with bouncens). Suggested by Andreas Fuchs. --- /project/cl-irc/cvsroot/cl-irc/event.lisp 2006/02/15 20:22:50 1.16 +++ /project/cl-irc/cvsroot/cl-irc/event.lisp 2006/02/15 20:42:48 1.17 @@ -1,4 +1,4 @@ -;;;; $Id: event.lisp,v 1.16 2006/02/15 20:22:50 ehuelsmann Exp $ +;;;; $Id: event.lisp,v 1.17 2006/02/15 20:42:48 ehuelsmann Exp $ ;;;; $Source: /project/cl-irc/cvsroot/cl-irc/event.lisp,v $ ;;;; See LICENSE for licensing information. @@ -187,8 +187,10 @@ (remove-user channel user)))) (defmethod default-hook ((message irc-quit-message)) - (let ((connection (connection message))) - (remove-user-everywhere connection (find-user connection (source message))))) + (let* ((connection (connection message)) + (user (find-user connection (source message)))) + (unless (null user) + (remove-user-everywhere connection user)))) (defmethod default-hook ((message irc-rpl_channelmodeis-message)) (destructuring-bind

1 0

[cl-irc-cvs] CVS cl-irc
by ehuelsmann 15 Feb '06

15 Feb '06

Update of /project/cl-irc/cvsroot/cl-irc In directory common-lisp:/tmp/cvs-serv26079 Modified Files: event.lisp Log Message: Support IRCNet irc-rpl_*list-message replies. Patch by Andreas Fuchs. --- /project/cl-irc/cvsroot/cl-irc/event.lisp 2006/02/15 20:14:21 1.15 +++ /project/cl-irc/cvsroot/cl-irc/event.lisp 2006/02/15 20:22:50 1.16 @@ -1,4 +1,4 @@ -;;;; $Id: event.lisp,v 1.15 2006/02/15 20:14:21 ehuelsmann Exp $ +;;;; $Id: event.lisp,v 1.16 2006/02/15 20:22:50 ehuelsmann Exp $ ;;;; $Source: /project/cl-irc/cvsroot/cl-irc/event.lisp,v $ ;;;; See LICENSE for licensing information. @@ -26,7 +26,7 @@ `(progn (defmethod default-hook ((message ,listmsg-class)) (destructuring-bind - (target channel-name mask set-by time-set) + (target channel-name mask &optional set-by time-set) (arguments message) (declare (ignore target set-by time-set)) ;; note: the structure currently does not allow for logging

1 0

[cl-irc-cvs] CVS cl-irc
by ehuelsmann 15 Feb '06

15 Feb '06

Update of /project/cl-irc/cvsroot/cl-irc In directory common-lisp:/tmp/cvs-serv24527 Modified Files: command.lisp event.lisp protocol.lisp utility.lisp Log Message: Remove the 'trailing argument' notion from send-irc-message: the last argument will now always be 'trailing'. --- /project/cl-irc/cvsroot/cl-irc/command.lisp 2006/02/14 21:51:21 1.15 +++ /project/cl-irc/cvsroot/cl-irc/command.lisp 2006/02/15 20:14:21 1.16 @@ -1,4 +1,4 @@ -;;;; $Id: command.lisp,v 1.15 2006/02/14 21:51:21 ehuelsmann Exp $ +;;;; $Id: command.lisp,v 1.16 2006/02/15 20:14:21 ehuelsmann Exp $ ;;;; $Source: /project/cl-irc/cvsroot/cl-irc/command.lisp,v $ ;;;; See LICENSE for licensing information. @@ -77,62 +77,62 @@ is now registered and known the to the entire IRC network. The reply message MUST contain the full client identifier upon which it was registered." - (send-irc-message connection :pass nil password)) + (send-irc-message connection :pass password)) (defmethod nick ((connection connection) (new-nickname string)) - (send-irc-message connection :nick nil new-nickname)) + (send-irc-message connection :nick new-nickname)) (defmethod user- ((connection connection) (username string) (mode integer) &optional (realname "")) - (send-irc-message connection :user realname username mode "*")) + (send-irc-message connection :user username mode "*" realname)) (defmethod oper ((connection connection) (name string) (password string)) - (send-irc-message connection :oper nil name password)) + (send-irc-message connection :oper name password)) (defmethod mode ((connection connection) (nickname string) (mode string)) - (send-irc-message connection :mode nil nickname mode)) + (send-irc-message connection :mode nickname mode)) ;; utility functions not part of the RFCs (defmethod op ((connection connection) (channel string) (nickname string)) - (send-irc-message connection :mode nil channel "+o" nickname)) + (send-irc-message connection :mode channel "+o" nickname)) (defmethod op ((connection connection) (channel channel) (user user)) (op connection (name channel) (nickname user))) (defmethod deop ((connection connection) (channel string) (nickname string)) - (send-irc-message connection :mode nil channel "-o" nickname)) + (send-irc-message connection :mode channel "-o" nickname)) (defmethod deop ((connection connection) (channel channel) (user user)) (deop connection (name channel) (nickname user))) (defmethod voice ((connection connection) (channel string) (nickname string)) - (send-irc-message connection :mode nil channel "+v" nickname)) + (send-irc-message connection :mode channel "+v" nickname)) (defmethod voice ((connection connection) (channel channel) (user user)) (voice connection (name channel) (nickname user))) (defmethod devoice ((connection connection) (channel string) (nickname string)) - (send-irc-message connection :mode nil channel "-v" nickname)) + (send-irc-message connection :mode channel "-v" nickname)) (defmethod devoice ((connection connection) (channel channel) (user user)) (devoice connection (name channel) (nickname user))) (defmethod ban ((connection connection) (channel string) (mask string)) - (send-irc-message connection :mode nil channel "+b" mask)) + (send-irc-message connection :mode channel "+b" mask)) (defmethod ban ((connection connection) (channel channel) (mask string)) (ban connection (name channel) mask)) ;; unban or deban? (defmethod unban ((connection connection) (channel string) (mask string)) - (send-irc-message connection :mode nil channel "-b" mask)) + (send-irc-message connection :mode channel "-b" mask)) (defmethod unban ((connection connection) (channel channel) (mask string)) (unban connection (name channel) mask)) (defmethod service ((connection connection) (nickname string) (distribution string) (info string)) - (send-irc-message connection :service info nickname "*" distribution 0 0 info)) + (send-irc-message connection :service nickname "*" distribution 0 0 info)) (defmethod quit ((connection connection) &optional (message *default-quit-message*)) (remove-all-channels connection) @@ -145,10 +145,11 @@ (close (network-stream connection)))) (defmethod squit ((connection connection) (server string) (comment string)) - (send-irc-message connection :squit comment server)) + (send-irc-message connection :squit server comment)) (defmethod join ((connection connection) (channel string) &key password) - (apply #'send-irc-message connection :join nil channel (when password (list password)))) + (apply #'send-irc-message + connection :join channel (when password (list password)))) (defmethod join ((connection connection) (channel channel) &key password) (join connection (name channel) :password password)) @@ -159,7 +160,7 @@ (join connection channel))) (defmethod part ((connection connection) (channel string)) - (send-irc-message connection :part nil channel)) + (send-irc-message connection :part channel)) (defmethod part ((connection connection) (channel channel)) (part connection (name channel))) @@ -170,14 +171,14 @@ (part connection (name channel)))) (defmethod topic- ((connection connection) (channel string) (topic string)) - (send-irc-message connection :topic topic channel)) + (send-irc-message connection :topic channel topic)) (defmethod topic- ((connection connection) (channel channel) (topic string)) (topic- connection (name channel) topic)) (defmethod names ((connection connection) (channel string) &optional (target "")) - (send-irc-message connection :names nil channel target)) + (send-irc-message connection :names channel target)) (defmethod names ((connection connection) (channel channel) &optional (target "")) @@ -185,24 +186,24 @@ (defmethod list- ((connection connection) &optional (channel "") (target "")) - (send-irc-message connection :list nil channel target)) + (send-irc-message connection :list channel target)) (defmethod invite ((connection connection) (nickname string) (channel string)) - (send-irc-message connection :invite nil nickname channel)) + (send-irc-message connection :invite nickname channel)) (defmethod invite ((connection connection) (user user) (channel channel)) (invite connection (nickname user) (name channel))) (defmethod kick ((connection connection) (channel string) (user string) &optional (comment "")) - (send-irc-message connection :kick comment channel user)) + (send-irc-message connection :kick channel user comment)) (defmethod kick ((connection connection) (channel channel) (user user) &optional (comment "")) (kick connection (name channel) (nickname user) comment)) (defmethod privmsg ((connection connection) (target string) (message string)) - (send-irc-message connection :privmsg message target)) + (send-irc-message connection :privmsg target message)) (defmethod privmsg ((connection connection) (user user) (message string)) (privmsg connection (nickname user) message)) @@ -211,7 +212,7 @@ (privmsg connection (name channel) message)) (defmethod notice ((connection connection) (target string) (message string)) - (send-irc-message connection :notice message target)) + (send-irc-message connection :notice target message)) (defmethod notice ((connection connection) (user user) (message string)) (notice connection (nickname user) message)) @@ -220,23 +221,23 @@ (notice connection (name channel) message)) (defmethod motd- ((connection connection) &optional (target "")) - (send-irc-message connection :motd nil target)) + (send-irc-message connection :motd target)) (defmethod lusers ((connection connection) &optional (mask "") (target "")) - (send-irc-message connection :lusers nil mask target)) + (send-irc-message connection :lusers mask target)) (defmethod version ((connection connection) &optional (target "")) - (send-irc-message connection :version nil target)) + (send-irc-message connection :version target)) (defmethod stats ((connection connection) &optional (query "") (target "")) - (send-irc-message connection :stats nil query target)) + (send-irc-message connection :stats query target)) (defmethod links ((connection connection) &optional (remote-server "") (server-mask "")) - (send-irc-message connection :links nil remote-server server-mask)) + (send-irc-message connection :links remote-server server-mask)) (defmethod time- ((connection connection) &optional (target "")) - (send-irc-message connection :time nil target)) + (send-irc-message connection :time target)) (defun connect (&key (nickname *default-nickname*) (username nil) @@ -266,29 +267,29 @@ connection)) (defmethod trace- ((connection connection) &optional (target "")) - (send-irc-message connection :trace nil target)) + (send-irc-message connection :trace target)) (defmethod admin ((connection connection) &optional (target "")) - (send-irc-message connection :admin nil target)) + (send-irc-message connection :admin target)) (defmethod info ((connection connection) &optional (target "")) - (send-irc-message connection :info nil target)) + (send-irc-message connection :info target)) (defmethod servlist ((connection connection) &optional (mask "") (type "")) - (send-irc-message connection :servlist nil mask type)) + (send-irc-message connection :servlist mask type)) (defmethod squery ((connection connection) (service-name string) (text string)) (send-irc-message connection :squery text service-name)) (defmethod who ((connection connection) &optional (mask "") (o "")) - (send-irc-message connection :who nil mask o)) + (send-irc-message connection :who mask o)) (defmethod whois ((connection connection) (mask string) &optional (target "")) - (send-irc-message connection :whois nil target mask)) + (send-irc-message connection :whois target mask)) (defmethod whowas ((connection connection) (nickname string) &optional (count "") (target "")) - (send-irc-message connection :whowas nil nickname count target)) + (send-irc-message connection :whowas nickname count target)) (defmethod kill ((connection connection) (nickname string) &optional (comment "")) (send-irc-message connection :kill comment nickname)) @@ -297,10 +298,10 @@ (kill connection (nickname user) comment)) (defmethod ping ((connection connection) (server string)) - (send-irc-message connection :ping nil server)) + (send-irc-message connection :ping server)) (defmethod pong ((connection connection) (server string) &optional (server2 "")) - (send-irc-message connection :pong nil server server2)) + (send-irc-message connection :pong server server2)) (defmethod error- ((connection connection) (message string)) (send-irc-message connection :error message)) @@ -319,29 +320,29 @@ (defmethod summon ((connection connection) (nickname string) &optional (target "") (channel "")) - (send-irc-message connection :summon nil nickname target channel)) + (send-irc-message connection :summon nickname target channel)) (defmethod users- ((connection connection) &optional (target "")) - (send-irc-message connection :users nil target)) + (send-irc-message connection :users target)) (defmethod wallops ((connection connection) (message string)) (send-irc-message connection :wallops message)) (defmethod userhost ((connection connection) (nickname string)) - (send-irc-message connection :userhost nil nickname)) + (send-irc-message connection :userhost nickname)) (defmethod userhost ((connection connection) (user user)) (userhost connection (nickname user))) (defmethod ison ((connection connection) (nickname string)) - (send-irc-message connection :ison nil nickname)) + (send-irc-message connection :ison nickname)) (defmethod ison ((connection connection) (user user)) (ison connection (nickname user))) ;; utility functions not part of the RFC (defmethod ctcp ((connection connection) target message) - (send-irc-message connection :privmsg (make-ctcp-message message) target)) + (send-irc-message connection :privmsg target (make-ctcp-message message))) #| There's too much wrong with this method to fix it now. --- /project/cl-irc/cvsroot/cl-irc/event.lisp 2006/02/15 19:03:53 1.14 +++ /project/cl-irc/cvsroot/cl-irc/event.lisp 2006/02/15 20:14:21 1.15 @@ -1,4 +1,4 @@ -;;;; $Id: event.lisp,v 1.14 2006/02/15 19:03:53 ehuelsmann Exp $ +;;;; $Id: event.lisp,v 1.15 2006/02/15 20:14:21 ehuelsmann Exp $ ;;;; $Source: /project/cl-irc/cvsroot/cl-irc/event.lisp,v $ ;;;; See LICENSE for licensing information. @@ -251,20 +251,21 @@ (multiple-value-bind (second minute hour date month year day) (get-decoded-time) (send-irc-message (connection message) - :notice (make-ctcp-message - (format nil "TIME ~A" - (make-time-message second minute hour date month year day))) - (source message)))) + :notice (source message) + (make-ctcp-message + (format nil "TIME ~A" + (make-time-message second minute hour date month year day)))))) (defmethod default-hook ((message ctcp-source-message)) (send-irc-message (connection message) - :notice (make-ctcp-message - (format nil "SOURCE ~A:~A:~A" - *download-host* - *download-directory* - *download-file*)) - (source message))) + :notice + (source message) + (make-ctcp-message + (format nil "SOURCE ~A:~A:~A" + *download-host* + *download-directory* + *download-file*)))) (defmethod default-hook ((message ctcp-finger-message)) (let* ((user (user (connection message))) @@ -273,23 +274,23 @@ (nickname user)))) (send-irc-message (connection message) - :notice (make-ctcp-message - (format nil "FINGER ~A" finger-info)) - (source message)))) + :notice (source message) + (make-ctcp-message + (format nil "FINGER ~A" finger-info))))) (defmethod default-hook ((message ctcp-version-message)) (send-irc-message (connection message) - :notice (make-ctcp-message - (format nil "VERSION ~A" *ctcp-version*)) - (source message))) + :notice (source message) + (make-ctcp-message + (format nil "VERSION ~A" *ctcp-version*)))) (defmethod default-hook ((message ctcp-ping-message)) (send-irc-message (connection message) - :notice (make-ctcp-message - (format nil "PING ~A" (trailing-argument message))) - (source message))) + :notice (source message) + (make-ctcp-message + (format nil "PING ~A" (trailing-argument message))))) (defmethod irc-message-event (connection (message ctcp-dcc-chat-request-message)) (declare (ignore connection)) --- /project/cl-irc/cvsroot/cl-irc/protocol.lisp 2006/02/15 19:14:33 1.35 +++ /project/cl-irc/cvsroot/cl-irc/protocol.lisp 2006/02/15 20:14:21 1.36 @@ -1,4 +1,4 @@ -;;;; $Id: protocol.lisp,v 1.35 2006/02/15 19:14:33 ehuelsmann Exp $ +;;;; $Id: protocol.lisp,v 1.36 2006/02/15 20:14:21 ehuelsmann Exp $ ;;;; $Source: /project/cl-irc/cvsroot/cl-irc/protocol.lisp,v $ ;;;; See LICENSE for licensing information. @@ -172,8 +172,7 @@ (defgeneric read-message (connection)) (defgeneric start-process (function name)) (defgeneric read-irc-message (connection)) -(defgeneric send-irc-message (connection command - &optional trailing-argument &rest arguments)) +(defgeneric send-irc-message (connection command &rest arguments)) (defgeneric get-hooks (connection class)) (defgeneric add-hook (connection class hook)) (defgeneric remove-hook (connection class hook)) @@ -304,12 +303,10 @@ ;; satisfy read-message-loop assumption of nil when no more messages (defmethod send-irc-message ((connection connection) command - &optional trailing-argument &rest arguments) + &rest arguments) "Turn the arguments into a valid IRC message and send it to the server, via the `connection'." - (let ((raw-message (make-irc-message command - :arguments arguments - :trailing-argument trailing-argument))) + (let ((raw-message (apply #'make-irc-message command arguments))) (write-sequence raw-message (network-stream connection)) (force-output (network-stream connection)) raw-message)) --- /project/cl-irc/cvsroot/cl-irc/utility.lisp 2006/01/24 22:10:58 1.9 +++ /project/cl-irc/cvsroot/cl-irc/utility.lisp 2006/02/15 20:14:21 1.10 @@ -1,4 +1,4 @@ -;;;; $Id: utility.lisp,v 1.9 2006/01/24 22:10:58 ehuelsmann Exp $ +;;;; $Id: utility.lisp,v 1.10 2006/02/15 20:14:21 ehuelsmann Exp $ ;;;; $Source: /project/cl-irc/cvsroot/cl-irc/utility.lisp,v $ ;;;; See the LICENSE file for licensing information. @@ -49,18 +49,14 @@ second year)) -(defun make-irc-message (command &key (arguments nil) - (trailing-argument nil)) +(defun make-irc-message (command &rest arguments) "Return a valid IRC message, as a string, composed of the input parameters." (let ((*print-circle* nil)) - (format nil "~A~{ ~A~}~A~A~A~A" command arguments - (if trailing-argument - " :" - "") - (or trailing-argument "") - #\Return - #\Linefeed))) + (format nil + "~A~{ ~A~}~@[ :~A~]~A~A" + command (butlast arguments) (car (last arguments)) + #\Return #\Linefeed))) (defun make-ctcp-message (string) "Return a valid IRC CTCP message, as a string, composed by

1 0

[cl-irc-cvs] CVS cl-irc
by ehuelsmann 15 Feb '06

15 Feb '06

Update of /project/cl-irc/cvsroot/cl-irc In directory common-lisp:/tmp/cvs-serv18563 Modified Files: variable.lisp Log Message: Make variable.lisp report the real version number we're actually working toward. --- /project/cl-irc/cvsroot/cl-irc/variable.lisp 2005/03/27 19:21:28 1.6 +++ /project/cl-irc/cvsroot/cl-irc/variable.lisp 2006/02/15 19:15:21 1.7 @@ -1,4 +1,4 @@ -;;;; $Id: variable.lisp,v 1.6 2005/03/27 19:21:28 ehuelsmann Exp $ +;;;; $Id: variable.lisp,v 1.7 2006/02/15 19:15:21 ehuelsmann Exp $ ;;;; $Source: /project/cl-irc/cvsroot/cl-irc/variable.lisp,v $ ;;;; See the LICENSE file for licensing information. @@ -10,7 +10,7 @@ (defconstant +soh+ #.(code-char 1)) -(defparameter *version* "0.1.0") +(defparameter *version* "0.8.0-dev") (defparameter *ctcp-version* (format nil "CL IRC library, cl-irc:~A:~A ~A" *version* (machine-type) (machine-version)))

1 0

[cl-irc-cvs] CVS cl-irc
by ehuelsmann 15 Feb '06

15 Feb '06

Update of /project/cl-irc/cvsroot/cl-irc In directory common-lisp:/tmp/cvs-serv17343 Modified Files: parse-message.lisp protocol.lisp Log Message: Silence SBCL compile warnings (one of which being a real bug). --- /project/cl-irc/cvsroot/cl-irc/parse-message.lisp 2006/02/15 19:03:53 1.7 +++ /project/cl-irc/cvsroot/cl-irc/parse-message.lisp 2006/02/15 19:14:33 1.8 @@ -1,4 +1,4 @@ -;;;; $Id: parse-message.lisp,v 1.7 2006/02/15 19:03:53 ehuelsmann Exp $ +;;;; $Id: parse-message.lisp,v 1.8 2006/02/15 19:14:33 ehuelsmann Exp $ ;;;; $Source: /project/cl-irc/cvsroot/cl-irc/parse-message.lisp,v $ ;;;; See the LICENSE file for licensing information. @@ -164,12 +164,12 @@ (ctcp (ctcp-message-type trailing-argument))) (when command (cond - (nil ;(irc-error-reply-p command) + ;;((irc-error-reply-p command) ;; Disable for now, as it prevents adding hooks for some useful ;; error types - (progn - (setf command (find-reply-name (parse-integer command))) - (setf class 'irc-error-reply))) + ;;(progn + ;; (setf command (find-reply-name (parse-integer command))) + ;; (setf class 'irc-error-reply))) ((numeric-reply-p command) (progn (setf command (find-reply-name (parse-integer command))) --- /project/cl-irc/cvsroot/cl-irc/protocol.lisp 2006/02/15 19:03:53 1.34 +++ /project/cl-irc/cvsroot/cl-irc/protocol.lisp 2006/02/15 19:14:33 1.35 @@ -1,4 +1,4 @@ -;;;; $Id: protocol.lisp,v 1.34 2006/02/15 19:03:53 ehuelsmann Exp $ +;;;; $Id: protocol.lisp,v 1.35 2006/02/15 19:14:33 ehuelsmann Exp $ ;;;; $Source: /project/cl-irc/cvsroot/cl-irc/protocol.lisp,v $ ;;;; See LICENSE for licensing information. @@ -261,7 +261,8 @@ (defun start-background-message-handler (connection) "Read messages from the `connection', parse them and dispatch irc-message-event on them. Returns background process ID if available." - (flet ((do-loop () (read-message-loop connection))) + (flet (#-(and sbcl (not sb-thread)) + (do-loop () (read-message-loop connection))) (let ((name (format nil "irc-hander-~D" (incf *process-count*)))) #+(or allegro cmu lispworks sb-thread openmcl armedbear) (start-process #'do-loop name) @@ -426,7 +427,8 @@ ;; 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 (stream connection))) + (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*))

1 0

[cl-irc-cvs] CVS cl-irc
by ehuelsmann 15 Feb '06

15 Feb '06

Update of /project/cl-irc/cvsroot/cl-irc In directory common-lisp:/tmp/cvs-serv16147 Modified Files: event.lisp protocol.lisp parse-message.lisp Log Message: Start eliminating trailing-argument to be RFC compliant. Step 2 should follow in about half a year, removing trailing-argument all together. * event.lisp: - Use destructuring-bind to decompose protocol messages (more often). - Fix relative arguments-use (i.e. (last arugments)) which isn't applicable anymore. [Only the case for irc-rpl_namreply-message.] - Fix PONG message - previously using trailing-argument - to pass all arguments to PING back into PONG (as per the RFC). --- /project/cl-irc/cvsroot/cl-irc/event.lisp 2006/01/27 21:10:02 1.13 +++ /project/cl-irc/cvsroot/cl-irc/event.lisp 2006/02/15 19:03:53 1.14 @@ -1,4 +1,4 @@ -;;;; $Id: event.lisp,v 1.13 2006/01/27 21:10:02 ehuelsmann Exp $ +;;;; $Id: event.lisp,v 1.14 2006/02/15 19:03:53 ehuelsmann Exp $ ;;;; $Source: /project/cl-irc/cvsroot/cl-irc/event.lisp,v $ ;;;; See LICENSE for licensing information. @@ -85,26 +85,27 @@ (re-apply-case-mapping connection)))) (defmethod default-hook ((message irc-rpl_whoisuser-message)) - (let ((user (find-user (connection message) - (second (arguments message)))) - (realname (trailing-argument message)) - (username (third (arguments message))) - (hostname (fourth (arguments message)))) - (when user - (setf (realname user) realname) - (setf (username user) username) - (setf (hostname user) hostname)))) + (destructuring-bind + (target nick username hostname star realname) + (arguments message) + (declare (ignore target star)) + (let ((user (find-user (connection message) nick))) + (when user + (setf (realname user) realname + (username user) username + (hostname user) hostname))))) (defmethod default-hook ((message irc-rpl_list-message)) - (let ((connection (connection message)) - (channel (second (arguments message))) - (user-count (parse-integer (or (third (arguments message)) "0"))) - (topic (trailing-argument message))) - (add-channel connection (or (find-channel connection channel) - (make-channel connection - :name channel - :topic topic - :user-count user-count))))) + (destructuring-bind + (channel count topic) + (arguments message) + (let ((connection (connection message)) + (user-count (parse-integer count))) + (add-channel connection (or (find-channel connection channel) + (make-channel connection + :name channel + :topic topic + :user-count user-count)))))) (defmethod default-hook ((message irc-rpl_topic-message)) (setf (topic (find-channel (connection message) @@ -112,31 +113,34 @@ (trailing-argument message))) (defmethod default-hook ((message irc-rpl_namreply-message)) - (let* ((connection (connection message)) - (channel (find-channel connection (car (last (arguments message)))))) - (unless (has-mode-p channel 'namreply-in-progress) - (add-mode channel 'namreply-in-progress - (make-instance 'list-value-mode :value-type :user))) - (dolist (nickname (tokenize-string (trailing-argument message))) - (let ((user (find-or-make-user connection - (canonicalize-nickname connection - nickname)))) - (unless (equal user (user connection)) - (add-user connection user) - (add-user channel user) - (set-mode channel 'namreply-in-progress user)) - (let* ((mode-char (getf (nick-prefixes connection) - (elt nickname 0))) - (mode-name (when mode-char - (mode-name-from-char connection - channel mode-char)))) - (when mode-name - (if (has-mode-p channel mode-name) - (set-mode channel mode-name user) - (set-mode-value (add-mode channel mode-name - (make-mode connection - channel mode-name)) - user)))))))) + (let* ((connection (connection message))) + (destructuring-bind + (nick chan-mode channel names) + (arguments message) + (let ((channel (find-channel connection channel))) + (unless (has-mode-p channel 'namreply-in-progress) + (add-mode channel 'namreply-in-progress + (make-instance 'list-value-mode :value-type :user))) + (dolist (nickname (tokenize-string names)) + (let ((user (find-or-make-user connection + (canonicalize-nickname connection + nickname)))) + (unless (equal user (user connection)) + (add-user connection user) + (add-user channel user) + (set-mode channel 'namreply-in-progress user)) + (let* ((mode-char (getf (nick-prefixes connection) + (elt nickname 0))) + (mode-name (when mode-char + (mode-name-from-char connection + channel mode-char)))) + (when mode-name + (if (has-mode-p channel mode-name) + (set-mode channel mode-name user) + (set-mode-value (add-mode channel mode-name + (make-mode connection + channel mode-name)) + user)))))))))) (defmethod default-hook ((message irc-rpl_endofnames-message)) (let* ((channel (find-channel (connection message) @@ -152,7 +156,7 @@ (remove-user channel user)))) (defmethod default-hook ((message irc-ping-message)) - (pong (connection message) (trailing-argument message))) + (apply #'pong (connection message) (arguments message))) (defmethod default-hook ((message irc-join-message)) (let* ((connection (connection message)) --- /project/cl-irc/cvsroot/cl-irc/protocol.lisp 2006/02/12 08:08:07 1.33 +++ /project/cl-irc/cvsroot/cl-irc/protocol.lisp 2006/02/15 19:03:53 1.34 @@ -1,4 +1,4 @@ -;;;; $Id: protocol.lisp,v 1.33 2006/02/12 08:08:07 ehuelsmann Exp $ +;;;; $Id: protocol.lisp,v 1.34 2006/02/15 19:03:53 ehuelsmann Exp $ ;;;; $Source: /project/cl-irc/cvsroot/cl-irc/protocol.lisp,v $ ;;;; See LICENSE for licensing information. @@ -817,10 +817,6 @@ :accessor arguments :initarg :arguments :type list) - (trailing-argument - :accessor trailing-argument - :initarg :trailing-argument - :type string) (connection :accessor connection :initarg :connection) @@ -837,6 +833,13 @@ (print-unreadable-object (object stream :type t :identity t) (format stream "~A ~A" (source object) (command object)))) +;;Compat code; remove after 2006-08-01 + +(defgeneric trailing-argument (message)) +(defmethod trailing-argument ((message irc-message)) + (warn "Use of deprecated function irc:trailing-argument") + (car (last (arguments message)))) + (defgeneric self-message-p (message)) (defgeneric find-irc-message-class (type)) (defgeneric client-log (connection message &optional prefix)) --- /project/cl-irc/cvsroot/cl-irc/parse-message.lisp 2005/03/21 18:15:52 1.6 +++ /project/cl-irc/cvsroot/cl-irc/parse-message.lisp 2006/02/15 19:03:53 1.7 @@ -1,4 +1,4 @@ -;;;; $Id: parse-message.lisp,v 1.6 2005/03/21 18:15:52 ehuelsmann Exp $ +;;;; $Id: parse-message.lisp,v 1.7 2006/02/15 19:03:53 ehuelsmann Exp $ ;;;; $Source: /project/cl-irc/cvsroot/cl-irc/parse-message.lisp,v $ ;;;; See the LICENSE file for licensing information. @@ -60,6 +60,19 @@ trailing-argument part is not present." (cut-between string #\: '(#\Return) :start start)) +(defun combine-arguments-and-trailing (string &key (start 0)) + (multiple-value-bind + (start return-string) + (return-arguments string :start start) + (print return-string) + (multiple-value-bind + (return-index trailing) + (return-trailing-argument string :start start) + (print trailing) + (values return-index + (append return-string (when (and trailing (string/= "" trailing)) + (list trailing))))))) + (defun parse-raw-message (string &key (start 0)) "Assuming `string' is a valid IRC message, parse the message and return the values in the following order: @@ -78,8 +91,7 @@ return-user return-host return-command - return-arguments - return-trailing-argument)) + combine-arguments-and-trailing)) (multiple-value-bind (return-index return-string) (funcall function string :start index) (setf index return-index) @@ -145,10 +157,11 @@ "If `string' is a valid IRC message parse it and return an object of the correct type with its slots prefilled according to the information in the message." - (multiple-value-bind (source user host command arguments trailing-argument) + (multiple-value-bind (source user host command arguments) (parse-raw-message string) - (let ((class 'irc-message) - (ctcp (ctcp-message-type trailing-argument))) + (let* ((class 'irc-message) + (trailing-argument (car (last arguments))) + (ctcp (ctcp-message-type trailing-argument))) (when command (cond (nil ;(irc-error-reply-p command) @@ -177,7 +190,6 @@ "") :arguments arguments :connection nil - :trailing-argument (or trailing-argument "") :received-time (get-universal-time) :raw-message-string (or string "")))) (when ctcp

1 0

[cl-irc-cvs] CVS cl-irc/test
by ehuelsmann 15 Feb '06

15 Feb '06

Update of /project/cl-irc/cvsroot/cl-irc/test In directory common-lisp:/tmp/cvs-serv16147/test Modified Files: test-parse-message.lisp Log Message: Start eliminating trailing-argument to be RFC compliant. Step 2 should follow in about half a year, removing trailing-argument all together. * event.lisp: - Use destructuring-bind to decompose protocol messages (more often). - Fix relative arguments-use (i.e. (last arugments)) which isn't applicable anymore. [Only the case for irc-rpl_namreply-message.] - Fix PONG message - previously using trailing-argument - to pass all arguments to PING back into PONG (as per the RFC). --- /project/cl-irc/cvsroot/cl-irc/test/test-parse-message.lisp 2004/01/05 14:18:07 1.2 +++ /project/cl-irc/cvsroot/cl-irc/test/test-parse-message.lisp 2006/02/15 19:03:53 1.3 @@ -1,4 +1,4 @@ -;;;; $Id: test-parse-message.lisp,v 1.2 2004/01/05 14:18:07 eenge Exp $ +;;;; $Id: test-parse-message.lisp,v 1.3 2006/02/15 19:03:53 ehuelsmann Exp $ ;;;; $Source: /project/cl-irc/cvsroot/cl-irc/test/test-parse-message.lisp,v $ ;;;; See the LICENSE file for licensing information. @@ -10,6 +10,8 @@ (defvar *msg3* (format nil "NOTICE AUTH :*** Your forward and reverse DNS don't match~A" #\Return)) (defvar *msg4* (format nil ":kire_!~~eenge@adsl-156-35-240.asm.bellsouth.net MODE #lisppaste +k key~A" #\Return)) (defvar *msg5* (format nil ":kire_!~~eenge@adsl-156-35-240.asm.bellsouth.net MODE #lisppaste +bbb *!*(a)somewhere.com *!*(a)somewhereles.com *!*(a)youdontwannaknow.org~A" #\Return)) +(defvar *msg6* (format nil ":kire!~~eenge@216.248.178.227 PRIVMSG cl-irc heyhey!~A" #\Return)) + (deftest find-reply-name.1 (irc:find-reply-name 1) :rpl_welcome) (deftest find-reply-name.2 @@ -59,4 +61,8 @@ (deftest parse-raw-message.1 (irc::parse-raw-message cl-irc-test::*msg1*) - "kire" "~eenge" "216.248.178.227" "PRIVMSG" ("cl-irc") "heyhey!") + "kire" "~eenge" "216.248.178.227" "PRIVMSG" ("cl-irc" "heyhey!")) + +(deftest no-trailing.1 + (irc::parse-raw-message *msg6*) + "kire" "~eenge" "216.248.178.227" "PRIVMSG" ("cl-irc" "heyhey!"))

1 0

[cl-irc-cvs] CVS cl-irc/test
by ehuelsmann 14 Feb '06

14 Feb '06

Update of /project/cl-irc/cvsroot/cl-irc/test In directory common-lisp:/tmp/cvs-serv27481/test Modified Files: test-protocol.lisp Log Message: Comment out non-applicable tests. --- /project/cl-irc/cvsroot/cl-irc/test/test-protocol.lisp 2004/01/05 14:18:07 1.2 +++ /project/cl-irc/cvsroot/cl-irc/test/test-protocol.lisp 2006/02/14 22:56:17 1.3 @@ -1,4 +1,4 @@ -;;;; $Id: test-protocol.lisp,v 1.2 2004/01/05 14:18:07 eenge Exp $ +;;;; $Id: test-protocol.lisp,v 1.3 2006/02/14 22:56:17 ehuelsmann Exp $ ;;;; $Source: /project/cl-irc/cvsroot/cl-irc/test/test-protocol.lisp,v $ ;;;; See the LICENSE file for licensing information. @@ -10,8 +10,9 @@ (defvar *nick3* "k^{]re") (defvar *chan1* "#liSP") -(deftest normalize-nickname.1 (irc:normalize-nickname *nick1*) "kire") -(deftest normalize-nickname.2 (irc:normalize-nickname *nick2*) "k\\[]re") -(deftest normalize-nickname.3 (irc:normalize-nickname *nick3*) "k~[]re") +;;normalize tests are broken because they need a connection these days +;;(deftest normalize-nickname.1 (irc:normalize-nickname *nick1*) "kire") +;;(deftest normalize-nickname.2 (irc:normalize-nickname *nick2*) "k\\[]re") +;;(deftest normalize-nickname.3 (irc:normalize-nickname *nick3*) "k~[]re") -(deftest normalize-channel-name.1 (irc:normalize-channel-name *chan1*) "#lisp") +;;(deftest normalize-channel-name.1 (irc:normalize-channel-name *chan1*) "#lisp")

1 0

[cl-irc-cvs] CVS cl-irc
by ehuelsmann 14 Feb '06

14 Feb '06

Update of /project/cl-irc/cvsroot/cl-irc In directory common-lisp:/tmp/cvs-serv19293 Modified Files: command.lisp Log Message: Add support for joining password-protected channels. Patch by Andreas Fuchs. --- /project/cl-irc/cvsroot/cl-irc/command.lisp 2006/01/25 20:03:27 1.14 +++ /project/cl-irc/cvsroot/cl-irc/command.lisp 2006/02/14 21:51:21 1.15 @@ -1,4 +1,4 @@ -;;;; $Id: command.lisp,v 1.14 2006/01/25 20:03:27 ehuelsmann Exp $ +;;;; $Id: command.lisp,v 1.15 2006/02/14 21:51:21 ehuelsmann Exp $ ;;;; $Source: /project/cl-irc/cvsroot/cl-irc/command.lisp,v $ ;;;; See LICENSE for licensing information. @@ -19,7 +19,7 @@ (defgeneric service (connection nickname distribution info)) (defgeneric quit (connection &optional message)) (defgeneric squit (connection server comment)) -(defgeneric join (connection channel)) +(defgeneric join (connection channel &key password)) (defgeneric multi-join (connection channels)) (defgeneric part (connection channel)) (defgeneric part-all (connection)) @@ -147,11 +147,11 @@ (defmethod squit ((connection connection) (server string) (comment string)) (send-irc-message connection :squit comment server)) -(defmethod join ((connection connection) (channel string)) - (send-irc-message connection :join nil channel)) +(defmethod join ((connection connection) (channel string) &key password) + (apply #'send-irc-message connection :join nil channel (when password (list password)))) -(defmethod join ((connection connection) (channel channel)) - (join connection (name channel))) +(defmethod join ((connection connection) (channel channel) &key password) + (join connection (name channel) :password password)) ;; utility function not part of the RFC (defmethod multi-join ((connection connection) (channels list))

1 0

[cl-irc-cvs] CVS cl-irc
by ehuelsmann 12 Feb '06

12 Feb '06

Update of /project/cl-irc/cvsroot/cl-irc In directory common-lisp:/tmp/cvs-serv26640 Modified Files: protocol.lisp Log Message: Fix syntax error. --- /project/cl-irc/cvsroot/cl-irc/protocol.lisp 2006/01/30 19:51:12 1.32 +++ /project/cl-irc/cvsroot/cl-irc/protocol.lisp 2006/02/12 08:08:07 1.33 @@ -1,4 +1,4 @@ -;;;; $Id: protocol.lisp,v 1.32 2006/01/30 19:51:12 ehuelsmann Exp $ +;;;; $Id: protocol.lisp,v 1.33 2006/02/12 08:08:07 ehuelsmann Exp $ ;;;; $Source: /project/cl-irc/cvsroot/cl-irc/protocol.lisp,v $ ;;;; See LICENSE for licensing information. @@ -299,7 +299,7 @@ (read-line (network-stream connection) t)))) (setf (connection message) connection) message) - (end-of-file))) + (end-of-file ()))) ;; satisfy read-message-loop assumption of nil when no more messages (defmethod send-irc-message ((connection connection) command

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 February 2006