source: tags/0.9.0/utility.lisp

Last change on this file was 209, checked in by Erik Huelsmann, 16 years ago

Update for flexi-streams 1.0(.3?).

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision URL
File size: 23.7 KB
Line 
1;;;; $Id: utility.lisp 209 2008-06-29 22:31:22Z ehuelsmann $
2;;;; $URL: tags/0.9.0/utility.lisp $
3
4;;;; See the LICENSE file for licensing information.
5
6(in-package :irc)
7
8(defun get-day-name (day-number)
9  "Given a number, such as 1, return the appropriate day name,
10abbrevated, such as \"Tue\".  Index 0 is Monday."
11  (case day-number
12    (0 "Mon")
13    (1 "Tue")
14    (2 "Wed")
15    (3 "Thu")
16    (4 "Fri")
17    (5 "Sat")
18    (6 "Sun")
19    (otherwise
20     (error "Unknown day ~A." day-number))))
21
22(defun get-month-name (month-number)
23  "Index 1 is January."
24  (case month-number
25    (1 "Jan")
26    (2 "Feb")
27    (3 "Mar")
28    (4 "Apr")
29    (5 "May")
30    (6 "Jun")
31    (7 "Jul")
32    (8 "Aug")
33    (9 "Sep")
34    (10 "Oct")
35    (11 "Nov")
36    (12 "Dec")
37    (otherwise
38     (error "Unknown month ~A." month-number))))
39
40(defun make-time-message (second minute hour date month year day)
41  "Returns a string composed of the input parameters so that it
42represents a time message as by the IRC protocol."
43  (format nil "~A ~A ~2D ~2,'0D:~2,'0D:~2,'0D ~D"
44          (get-day-name day)
45          (get-month-name month)
46          date
47          hour
48          minute
49          second
50          year))
51
52(defun make-irc-message (command &rest arguments)
53  "Return a valid IRC message, as a string, composed of the input
54parameters."
55  (let ((*print-circle* nil))
56    (format nil
57            "~A~{ ~A~}~@[ :~A~]~%"
58            command (butlast arguments) (car (last arguments)))))
59
60(defun make-ctcp-message (string)
61  "Return a valid IRC CTCP message, as a string, composed by
62`string'."
63  (format nil "~A~A~A" +soh+ string +soh+))
64
65(defun tokenize-string (string &key
66                               (delimiters '(#\Space #\Return #\Linefeed #\Newline)))
67  "Split string into a list, splitting on `delimiters' and removing any
68empty subsequences."
69  (split-sequence:split-sequence-if #'(lambda (character)
70                                        (member character delimiters))
71                                    string :remove-empty-subseqs t))
72
73(defun list-of-strings-to-integers (list)
74  "Take a list of strings and return a new list of integers (from
75parse-integer) on each of the string elements."
76  (let ((new-list nil))
77    (dolist (element (reverse list))
78      (push (parse-integer element) new-list))
79    new-list))
80
81(defun host-byte-order (string)
82  "Convert a string, such as 192.168.1.1, to host-byte-order, such as
833232235777."
84  (let ((list (list-of-strings-to-integers (split-sequence:split-sequence #\. string))))
85    (+ (* (first list) 256 256 256) (* (second list) 256 256)
86       (* (third list) 256) (fourth list))))
87
88(defun hbo-to-dotted-quad (integer)
89  "Host-byte-order integer to dotted-quad string conversion utility."
90  (let ((first (ldb (byte 8 24) integer))
91        (second (ldb (byte 8 16) integer))
92        (third (ldb (byte 8 8) integer))
93        (fourth (ldb (byte 8 0) integer)))
94    (format nil "~A.~A.~A.~A" first second third fourth)))
95
96(defun hbo-to-vector-quad (integer)
97  "Host-byte-order integer to dotted-quad string conversion utility."
98  (let ((first (ldb (byte 8 24) integer))
99        (second (ldb (byte 8 16) integer))
100        (third (ldb (byte 8 8) integer))
101        (fourth (ldb (byte 8 0) integer)))
102    (vector first second third fourth)))
103
104(defun external-format-fixup (format)
105  (let ((new-format (copy-list format)))
106    (setf (getf (cdr new-format) :eol-style) :crlf)
107    new-format))
108
109(defun try-decode-line (line external-formats)
110  (loop for external-format in external-formats
111        for decoded = nil
112        for error = nil
113        do (multiple-value-setq (decoded error)
114             (handler-case
115              (flexi-streams:with-input-from-sequence (in line)
116                (let* ((ex-fmt (external-format-fixup external-format))
117                       (flexi (flexi-streams:make-flexi-stream
118                               in
119                               ;; :element-type 'character
120                               :external-format ex-fmt)))
121                  (read-line flexi nil nil)))
122              (flexi-streams:external-format-encoding-error ()
123                  nil)))
124        if decoded
125        do (return decoded)))
126
127(defun read-byte-no-hang (stream &optional eof-error-p eof-value)
128  (declare (optimize (speed 3) (debug 0) (safety 0)))
129  (when (listen stream)
130    (read-byte stream eof-error-p eof-value)))
131
132(defun read-sequence-until (stream target limit &key non-blocking)
133  "Reads data from `stream' into `target' until the subsequence
134`limit' is reached or `target' is not large enough to hold the data."
135  (let ((read-fun (if (subtypep (stream-element-type stream) 'integer)
136                      (if non-blocking #'read-byte-no-hang #'read-byte)
137                    (if non-blocking #'read-char-no-hang #'read-char)))
138        (limit-vector (coerce limit '(vector t *)))
139        (targ-max (1- (length target)))
140        (limit-max (length limit))
141        (limit-cur 0)
142        (targ-cur -1))
143    (declare (optimize (speed 3) (debug 0))
144             (type fixnum targ-cur))
145    ;; In SBCL read-char is a buffered operations (depending on
146    ;; stream creation parameters), so this loop should be quite efficient
147    ;; For others, if this becomes an efficiency problem, please report...
148    (loop for next-elt = (funcall read-fun stream nil nil)
149          if (null next-elt)
150          do (return (values target (1+ targ-cur) t))
151          else do
152          (setf (elt target (incf targ-cur)) next-elt)
153          (if (eql next-elt (aref limit-vector limit-cur))
154              (incf limit-cur)
155            (setf limit-cur 0))
156
157          if (or (= targ-cur targ-max)
158                 (= limit-cur limit-max))
159          do (return (values target (1+ targ-cur) nil)))))
160
161(defun read-protocol-line (connection)
162  "Reads a line from the input network stream, returning a
163character array with the input read."
164  (multiple-value-bind
165      (buf buf-len)
166      ;; Note: we cannot use read-line here (or any other
167      ;; character based functions), since they may cause
168      ;; (at this time unwanted) character conversion
169      (read-sequence-until (network-stream connection)
170                           (make-array 1024
171                                       :element-type '(unsigned-byte 8)
172                                       :fill-pointer t)
173                           '(10))
174    (when (< 0 buf-len)
175      (setf (fill-pointer buf)
176            ;; remove all trailing CR and LF characters
177            ;; (This allows non-conforming clients to send CRCRLF
178            ;;  as a line separator too).
179            (or (position-if #'(lambda (x) (member x '(10 13)))
180                             buf :from-end t :end buf-len)
181                buf-len))
182      (try-decode-line buf *default-incoming-external-formats*))))
183
184(defmacro dynfound-funcall ((symbol-name &optional package) &rest parameters)
185  (let ((package-sym (gensym))
186        (symbol-sym (gensym))
187        (fun-sym (gensym)))
188    `(let* ((,package-sym ,(if package package *package*))
189            (,symbol-sym ,(if (symbolp symbol-name)
190                              `',symbol-name
191                            symbol-name))
192            (,symbol-sym (find-symbol
193                          ,(if (symbolp symbol-name)
194                               `(symbol-name ,symbol-sym)
195                             `(if (symbolp ,symbol-sym)
196                                  (symbol-name ,symbol-sym)
197                                ,symbol-sym))
198                          ,package-sym))
199            (,fun-sym (when (and ,symbol-sym (fboundp ,symbol-sym))
200                        (symbol-function ,symbol-sym))))
201       (unless ,symbol-sym
202         (error "Can't resolve symbol ~A in package ~A"
203                ,symbol-sym ,package-sym))
204       (if ,fun-sym
205           (funcall ,fun-sym ,@parameters)
206         (error "Symbol ~A in package ~A isn't fbound"
207                ,symbol-sym ,package-sym)))))
208
209(defun substring (string start &optional end)
210  (let* ((end-index (if end end (length string)))
211         (seq-len (- end-index start)))
212    (make-array seq-len
213                :element-type (array-element-type string)
214                :displaced-to string
215                :displaced-index-offset start)))
216
217
218(defun cut-between (string start-char end-chars
219                           &key (start 0) (cut-extra t) (cut-to-end nil))
220  "If `start-char' is not nil, cut string between `start-char' and any
221of the `end-chars', from `start'.  If `start-char' is nil, cut from
222`start' until any of the `end-chars' (or sting-end when `cut-to-end' is true).
223
224If `cut-extra' is t, we will cut from start + 1 instead of just
225`start'.
226
227When there is no string matching the input parameters `start' and nil
228will be returned, otherwise `end-position' and the string are
229returned."
230  (let ((end-position (or (position-if #'(lambda (char)
231                                           (member char end-chars))
232                                       string :start (1+ start))
233                          (when cut-to-end (length string))))
234        (cut-from (if cut-extra
235                      (1+ start)
236                      start)))
237    (if (and end-position start-char)
238        (if (eql (char string start) start-char)
239            (values end-position
240                    (substring string cut-from end-position))
241            (values start nil))
242        (if end-position
243            (values end-position
244                    (substring string cut-from end-position))
245            (values start nil)))))
246
247(defun cut-before (string substring end-chars
248                          &key (start 0) (cut-extra t) (cut-to-end nil))
249  "Cut `string' before `substring' or any of the `end-chars', from `start',
250if none of substring or end-chars are found, until the end of the string
251when `cut-to-end' is true.
252
253If `cut-extra' is t, we will cut from start + 1 instead of just
254`start'.
255
256When there is no string matching the input parameters `start' and nil
257will be returned, otherwise `end-position' and the string are
258returned."
259  (let ((end-position (search substring string :start2 start)))
260    (if end-position
261        (values (+ end-position (1- (length substring)))
262                (substring string (if (and cut-extra
263                                        (< start end-position))
264                                   (1+ start) start) end-position))
265      (let ((end-position (or (position-if #'(lambda (x)
266                                               (member x end-chars))
267                                           string :start (1+ start))
268                              (when cut-to-end (length string))))
269            (cut-from (if cut-extra (1+ start) start)))
270        (if end-position
271            (values end-position
272                    (substring string cut-from end-position))
273          (values start nil))))))
274
275
276;;
277;; Message arguments binding macro
278;;
279
280(defmacro destructuring-arguments (lambda-list message &body body)
281  "Destructures the `arguments' slot in `message' according
282to `lambda-list' and binds them in `body'.
283
284The lambda list syntax is as follows:
285
286wholevar::= &whole var
287reqvars::= var*
288optvars::= [&optional {var | (var [init-form [supplied-p-parameter]])}* ]
289restvar::= [&rest var]
290reqtrailingvars::= [&req var*]
291lambda-list::= (wholevar reqvars optvars restvar reqtrailingvars)
292
293With the exception of &req (which is new) and &rest, all lambda list
294keywords are analogous to a destructuring lambda list (see clhs 3.4.5).
295
296If &req is specified, these values are consumed off the end of the list
297before processing any preceeding &optional or &rest keywords.
298
299For any variable, the `:ignored' keyword can be passed instead,
300indicating the binding should be ignored in the `body'."
301  (let ((%message (gensym))
302        (%args (gensym))
303        (%arg-count (gensym))
304        (valid-keywords '(&whole &optional &rest &req)))
305    (labels ((lambda-key-p (x)
306                (member x valid-keywords))
307             (ignored-p (x)
308                (eq x :ignored))
309             (count-valid-keys (lambda-list)
310                (count-if #'lambda-key-p lambda-list))
311             (replace-ignored (lambda-list)
312                (let ((ignores))
313                  (values (mapcar #'(lambda (x)
314                                      (if (ignored-p x)
315                                          (let ((y (gensym)))
316                                            (push y ignores)
317                                            y)
318                                        x))
319                                  lambda-list)
320                          ignores)))
321             (bind-req-trail (req-trail args body)
322                (let ((req-syms (cdr req-trail)))
323                  (if (and req-trail
324                           (notevery #'ignored-p req-syms))
325                      (multiple-value-bind
326                          (ll ignores) (replace-ignored req-syms)
327                        `(destructuring-bind
328                             ,ll ,args
329                           ,(if ignores
330                                `(declare (ignore ,@ignores))
331                              (values))
332                           ,body))
333                    body))))
334
335      (let* ((whole-var (when (eq (car lambda-list) '&whole)
336                          (second lambda-list)))
337             (lambda-list (if whole-var (nthcdr 2 lambda-list) lambda-list))
338             (opt-entries (member '&optional lambda-list))
339             (rest-entries (member '&rest lambda-list))
340             (req-trail (member '&req lambda-list))
341             (destructuring-ll (butlast lambda-list (length req-trail)))
342             (longest-sublist (cond
343                               (opt-entries opt-entries)
344                               (rest-entries rest-entries)
345                               (req-trail req-trail)
346                               (t nil)))
347             (min-entries (+ (if req-trail (1- (length req-trail)) 0)
348                             ;; required start && end
349                             (- (- (length lambda-list)
350                                   (count-valid-keys lambda-list))
351                                (- (length longest-sublist)
352                                   (count-valid-keys longest-sublist)))))
353             (max-entries (when (null rest-entries)
354                            ;; required start && end && optionals
355                            (+ min-entries
356                               (if opt-entries
357                                   (- (1- (length opt-entries))
358                                      (length req-trail))
359                                 0)))))
360
361        `(let* ((,%message ,message)
362                (,%args (arguments ,%message))
363                (,%arg-count (length ,%args))
364                ,@(if (and whole-var
365                           (not (ignored-p whole-var)))
366                      `((,whole-var ,%args))
367                    (values)))
368           (when ,(if max-entries
369                       `(not (and (<= ,min-entries ,%arg-count)
370                                  (<= ,%arg-count ,max-entries)))
371                     `(> ,min-entries ,%arg-count))
372             ;; we want to raise a cl-irc condition here!
373             (error (format nil "Unexpected protocol input; provided arguments ~
374~S don't match with expected arguments ~S" ',lambda-list ,%args)))
375           ,(bind-req-trail
376              req-trail
377              `(last ,%args ,(1- (length req-trail)))
378              (multiple-value-bind
379                  (ll ignores) (replace-ignored destructuring-ll)
380                `(destructuring-bind
381                     ,ll
382                     ,(if req-trail
383                          `(butlast ,%args ,(1- (length req-trail)))
384                        %args)
385                   ,(if ignores
386                        `(declare (ignore ,@ignores))
387                      (values))
388                   ,@body))))))))
389
390
391;;
392;; RPL_ISUPPORT support routines
393;;
394
395(defun parse-isupport-prefix-argument (prefix)
396  (declare (type string prefix))
397  (let ((closing-paren-pos (position #\) prefix)))
398    (when (and (eq (elt prefix 0) #\( )
399               closing-paren-pos)
400      (let ((prefixes (substring prefix (1+ closing-paren-pos)))
401            (modes (substring prefix 1 closing-paren-pos)))
402        (when (= (length prefixes)
403                 (length modes))
404          (values prefixes modes))))))
405
406(defun nick-prefixes-from-isupport (isupport-arguments)
407  "Returns an assoc list associating prefix characters with mode characters."
408  (multiple-value-bind
409      (prefixes modes)
410      (parse-isupport-prefix-argument (second (assoc "PREFIX"
411                                                     isupport-arguments
412                                                     :test #'string=)))
413    (let ((rv))
414      (dotimes (i (length modes)
415                  rv)
416        (setf (getf rv (char prefixes i))
417              (char modes i))))))
418
419(defun chanmode-descs-from-isupport (isupport-arguments
420                                     &optional
421                                     (mode-symbols
422                                      *default-char-to-channel-modes-map*))
423  "Parses a string describing channel modes conforming to
424http://www.irc.org/tech_docs/draft-brocklesby-irc-isupport-03.txt
425paragraph 3.3.
426
427It returns a list of mode-description records."
428  (let* ((mode-desc-recs)
429         (pref (second (assoc "PREFIX" isupport-arguments :test #'string=)))
430         (chanmodes (second (assoc "CHANMODES" isupport-arguments
431                                   :test #'string=)))
432         (modes-list
433          (cons (second (multiple-value-list
434                         (parse-isupport-prefix-argument pref)))
435                (split-sequence:split-sequence #\, chanmodes)))
436         (mode-descs '(;; B type mode from PREFIX with nick argument
437                       (t t t list-value-mode)
438                       ;; A type mode
439                       (:optional-for-server
440                        :optional-for-server nil list-value-mode)
441                       ;; B type mode from CHANMODES
442                       (t   t   nil single-value-mode)
443                       ;; C type mode from CHANMODES
444                       (t   nil nil single-value-mode)
445                       ;; D type mode from CHANMODES
446                       (nil nil nil boolean-value-mode))))
447    (do ((mode (pop modes-list) (pop modes-list))
448         (mode-desc (pop mode-descs) (pop mode-descs)))
449        ((null mode-desc) mode-desc-recs)
450      (when (< 0 (length mode))
451        (let ((mode-struct
452               (make-mode-description :param-on-set-p (first mode-desc)
453                                      :param-on-unset-p (second mode-desc)
454                                      :nick-param-p (third mode-desc)
455                                      :class (fourth mode-desc))))
456          (dotimes (j (length mode))
457            (let ((mode-rec (copy-structure mode-struct))
458                  (mode-char (elt mode j)))
459              (setf (mode-desc-char mode-rec) mode-char
460                    (mode-desc-symbol mode-rec) (cdr (assoc mode-char
461                                                            mode-symbols)))
462              (push mode-rec mode-desc-recs))))))))
463
464(defmacro do-property-list ((prop val list) &body body)
465  (let ((lsym (gensym)))
466    `(let ((,lsym ,list))
467       (do* ((,prop (pop ,lsym) (pop ,lsym))
468             (,val (pop ,lsym) (pop ,lsym)))
469           ((and (null ,lsym)
470                 (null ,prop)
471                 (null ,val)))
472         ,@body))))
473
474(defgeneric irc-string-downcase (map-name string &key start end))
475
476(defmethod irc-string-downcase (map-name
477                                string &key (start 0) end)
478  (declare (ignore map-name))
479  (let* ((new-string (substitute #\[ #\{ string :start start :end end))
480         (new-string (substitute #\] #\} new-string :start start :end end))
481         (new-string (substitute #\\ #\| new-string :start start :end end))
482         (new-string (substitute #\~ #\^ new-string :start start :end end)))
483    (string-downcase new-string :start start :end end)))
484
485(defmethod irc-string-downcase ((map-name (eql :ascii))
486                                string &key (start 0) end)
487  (declare (ignore map-name))
488  (string-downcase string :start start :end end))
489
490(defun parse-isupport-multivalue-argument (argument)
491  (declare (type string argument))
492  (mapcar #'(lambda (x)
493              (split-sequence:split-sequence #\: x))
494          (split-sequence:split-sequence #\, argument)))
495
496(defun parse-mode-arguments (connection target arguments &key server-p)
497  "Create a list of mode changes with their arguments for `target'
498   from `mode-string' and `arguments'.
499
500   Throw nil to the UNKNOWN-MODE symbol if any of the mode chars are unknown."
501  (catch 'illegal-mode-spec
502    (if (and (= 1 (length arguments))
503             (null (position (char (first arguments) 0) "+-")))
504        ;; type 1 mode specification; only allowed on servers
505        (when server-p
506          (let ((ops)
507                (arg (car arguments)))
508            (dotimes (i (length arg) (reverse ops))
509              (push (char arg i) ops))))
510      ;; type 2 mode specification; clients and servers
511      (let ((ops))
512        (do ((changes (pop arguments) (pop arguments)))
513            ((null changes) (values ops nil))
514          (let* ((this-op (char changes 0))
515                 (modes (substring changes 1))
516                 (param-req (if (char= this-op #\+)
517                                #'mode-desc-param-on-set-p
518                              #'mode-desc-param-on-unset-p)))
519            (unless (position this-op "+-")
520              (throw 'illegal-mode-spec nil))
521            (dotimes (i (length modes))
522              (case (char modes i)
523                ((#\+ #\-) (setf this-op (char modes i)))
524                (t 
525                 (let* ((mode-rec
526                         (mode-description connection target
527                                           (mode-name-from-char connection target
528                                                                (char modes i))))
529                        (param-p (when mode-rec
530                                   (funcall param-req mode-rec))))
531                   (when (or (null mode-rec)
532                             (and param-p
533                                  (= 0 (length arguments))))
534                     (throw 'illegal-mode-spec nil))
535                   (push (list this-op
536                               (mode-desc-symbol mode-rec)
537                               (when param-p
538                                 (if (mode-desc-nick-param-p mode-rec)
539                                     (find-user connection (pop arguments))
540                                     (pop arguments)))) ops)))))))))))
541
542
543;;;
544;;; Hostmask matcher
545;;;
546
547(defun do-mask-match (mask hostname mask-consumed host-consumed)
548  (if (= (length mask) (1+ mask-consumed))
549      ;; we're out of mask to match, hopefully, we're out of hostname too
550      (= (length hostname) (1+ host-consumed))
551    (let ((mask-char (char mask (1+ mask-consumed))))
552      (cond
553       ((eq mask-char #\?)
554        ;; match any character, if there is one
555        (do-mask-match mask hostname (1+ mask-consumed) (1+ host-consumed)))
556       ((eq mask-char #\*)
557        ;; match any number of characters (including zero)
558        (do ((match (do-mask-match mask hostname
559                                   (incf mask-consumed)
560                                   host-consumed)
561                    (do-mask-match mask hostname
562                                   mask-consumed
563                                   (incf host-consumed))))
564            ((or (= (length hostname) (1+ host-consumed))
565                 match)
566             match)))
567       ((= (1+ host-consumed) (length hostname))
568        ;; we're out of hostname...
569        nil)
570       (t
571        ;; match other characters by exact matches
572        (when (eq mask-char (char hostname (1+ host-consumed)))
573          (do-mask-match mask hostname
574                         (1+ mask-consumed) (1+ host-consumed))))))))
575
576  (defun mask-matches-p (mask hostname)
577    "Wildcard matching.
578
579Uses `*' to match any number of characters and `?' to match exactly any
580one character.  The routine does not enforce hostmask matching patterns,
581but can be used for the purpose."
582    (do-mask-match mask hostname -1 -1))
Note: See TracBrowser for help on using the repository browser.