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

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