utility.lisp 1 ;;;; $Id: utility.lisp 239 2013-01-13 18:59:49Z ehuelsmann $
2 ;;;; $URL: file:///project/cl-irc/svn/tags/0.9.2/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,
10 abbrevated, 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
42 represents 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
54 parameters."
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
68 empty 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
75 parse-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
83 3232235777."
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
163 character 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
221 of 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
224 If `cut-extra' is t, we will cut from start + 1 instead of just
225 `start'.
226
227 When there is no string matching the input parameters `start' and nil
228 will be returned, otherwise `end-position' and the string are
229 returned."
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',
250 if none of substring or end-chars are found, until the end of the string
251 when `cut-to-end' is true.
252
253 If `cut-extra' is t, we will cut from start + 1 instead of just
254 `start'.
255
256 When there is no string matching the input parameters `start' and nil
257 will be returned, otherwise `end-position' and the string are
258 returned."
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
282 to `lambda-list' and binds them in `body'.
283
284 The lambda list syntax is as follows:
285
286 wholevar::= &whole var
287 reqvars::= var*
288 optvars::= [&optional {var | (var [init-form [supplied-p-parameter]])}* ]
289 restvar::= [&rest var]
290 reqtrailingvars::= [&req var*]
291 lambda-list::= (wholevar reqvars optvars restvar reqtrailingvars)
292
293 With the exception of &req (which is new) and &rest, all lambda list
294 keywords are analogous to a destructuring lambda list (see clhs 3.4.5).
295
296 If &req is specified, these values are consumed off the end of the list
297 before processing any preceeding &optional or &rest keywords.
298
299 For any variable, the `:ignored' keyword can be passed instead,
300 indicating 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
424 http://www.irc.org/tech_docs/draft-brocklesby-irc-isupport-03.txt
425 paragraph 3.3.
426
427 It 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 apply-mode-changes (connection target mode-arguments server-p)
497 (dolist (change (parse-mode-arguments connection target mode-arguments
498 :server-p server-p))
499 (apply-mode-change connection target change)))
500
501 (defun apply-mode-change (connection target change)
502 (destructuring-bind
503 (op mode-name value)
504 change
505 (unless (has-mode-p target mode-name)
506 (add-mode target mode-name
507 (make-mode connection target mode-name)))
508 (funcall (if (char= #\+ op) #'set-mode #'unset-mode)
509 target mode-name value)))
510
511 (defun parse-mode-arguments (connection target arguments &key server-p)
512 "Create a list of mode changes with their arguments for `target'
513 from `mode-string' and `arguments'.
514
515 Throw nil to the UNKNOWN-MODE symbol if any of the mode chars are unknown."
516 (catch 'illegal-mode-spec
517 (if (and (= 1 (length arguments))
518 (null (position (char (first arguments) 0) "+-")))
519 ;; type 1 mode specification; only allowed on servers
520 (when server-p
521 (let ((ops)
522 (arg (car arguments)))
523 (dotimes (i (length arg) (reverse ops))
524 (push (char arg i) ops))))
525 ;; type 2 mode specification; clients and servers
526 (let ((ops))
527 (do ((changes (pop arguments) (pop arguments)))
528 ((null changes) (values ops nil))
529 (let* ((this-op (char changes 0))
530 (modes (substring changes 1))
531 (param-req (if (char= this-op #\+)
532 #'mode-desc-param-on-set-p
533 #'mode-desc-param-on-unset-p)))
534 (unless (position this-op "+-")
535 (throw 'illegal-mode-spec nil))
536 (dotimes (i (length modes))
537 (case (char modes i)
538 ((#\+ #\-) (setf this-op (char modes i)))
539 (t
540 (let* ((mode-rec
541 (mode-description connection target
542 (mode-name-from-char connection target
543 (char modes i))))
544 (param-p (when mode-rec
545 (funcall param-req mode-rec))))
546 (when (or (null mode-rec)
547 (and param-p
548 (= 0 (length arguments))))
549 (throw 'illegal-mode-spec nil))
550 (push (list this-op
551 (mode-desc-symbol mode-rec)
552 (when param-p
553 (if (mode-desc-nick-param-p mode-rec)
554 (find-user connection (pop arguments))
555 (pop arguments)))) ops)))))))))))
556
557
558 ;;;
559 ;;; Hostmask matcher
560 ;;;
561
562 (defun do-mask-match (mask hostname mask-consumed host-consumed)
563 (if (= (length mask) (1+ mask-consumed))
564 ;; we're out of mask to match, hopefully, we're out of hostname too
565 (= (length hostname) (1+ host-consumed))
566 (let ((mask-char (char mask (1+ mask-consumed))))
567 (cond
568 ((eq mask-char #\?)
569 ;; match any character, if there is one
570 (do-mask-match mask hostname (1+ mask-consumed) (1+ host-consumed)))
571 ((eq mask-char #\*)
572 ;; match any number of characters (including zero)
573 (do ((match (do-mask-match mask hostname
574 (incf mask-consumed)
575 host-consumed)
576 (do-mask-match mask hostname
577 mask-consumed
578 (incf host-consumed))))
579 ((or (= (length hostname) (1+ host-consumed))
580 match)
581 match)))
582 ((= (1+ host-consumed) (length hostname))
583 ;; we're out of hostname...
584 nil)
585 (t
586 ;; match other characters by exact matches
587 (when (eq mask-char (char hostname (1+ host-consumed)))
588 (do-mask-match mask hostname
589 (1+ mask-consumed) (1+ host-consumed))))))))
590
591 (defun mask-matches-p (mask hostname)
592 "Wildcard matching.
593
594 Uses `*' to match any number of characters and `?' to match exactly any
595 one character. The routine does not enforce hostmask matching patterns,
596 but can be used for the purpose."
597 (do-mask-match mask hostname -1 -1))