[cl-irc-cvs] r159 - trunk

[ehuelsmann at common-lisp.net]

Author: ehuelsmann
Date: Mon May 22 16:01:09 2006
New Revision: 159

Modified:
   trunk/event.lisp
Log:
Mostly resolve issue #17: decode RPL_ISUPPORT encoded characters.

Modified: trunk/event.lisp
==============================================================================
--- trunk/event.lisp	(original)
+++ trunk/event.lisp	Mon May 22 16:01:09 2006
@@ -70,31 +70,55 @@
     (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 (substring x 0 eq-pos)
-                                             (substring 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)))))
+      (flet ((split-arg (x)
+                (let ((eq-pos (position #\= x)))
+                  (if eq-pos
+                      (list (substring x 0 eq-pos)
+                            (substring x (1+ eq-pos)))
+                    (list x))))
+             (decode-arg (text)
+                ;; decode \xHH into (char-code HH)
+                ;; btw: how should that work with multibyte utf8?
+                (format nil "~{~A~}"
+                        (do* ((start 0 (+ 4 pos))
+                              (pos (search "\\x" text)
+                                   (search "\\x" text :start2 (1+ pos)))
+                              (points))
+                            ((null pos)
+                             (reverse (push (substring text start) points)))
+                          (push (substring text start pos) points)
+                          (push (code-char (parse-integer text
+                                                          :start (+ 2 pos)
+                                                          :end (+ 4 pos)
+                                                          :junk-allowed nil
+                                                          :radix 16))
+                                points))))
+             (negate-param (param)
+                 (if (eq #\- (char (first param) 0))
+                     (assoc (substring (first param) 1)
+                            *default-isupport-values*
+                            :test #'string=)
+                   param)))
+
+        (setf (server-capabilities connection)
+              (reduce #'(lambda (x y)
+                          (adjoin y x :key #'first :test #'string=))
+                      (append
+                       (remove nil (mapcar #'negate-param
+                                           (mapcar #'(lambda (x)
+                                                       (mapcar #'decode-arg x))
+                                                   (mapcar #'split-arg
+                                                           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