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