| 1 | ;;;; $Id: utility.lisp 165 2007-01-04 22:48:22Z ehuelsmann $ |
|---|
| 2 | ;;;; $URL: tags/0.8.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, |
|---|
| 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 read-byte-no-hang (stream &optional eof-error-p eof-value) |
|---|
| 110 | (declare (optimize (speed 3) (debug 0) (safety 0))) |
|---|
| 111 | (when (listen stream) |
|---|
| 112 | (read-byte stream eof-error-p eof-value))) |
|---|
| 113 | |
|---|
| 114 | (defun read-sequence-until (stream target limit &key non-blocking) |
|---|
| 115 | "Reads data from `stream' into `target' until the subsequence |
|---|
| 116 | `limit' is reached or `target' is not large enough to hold the data." |
|---|
| 117 | (let ((read-fun (if (subtypep (stream-element-type stream) 'integer) |
|---|
| 118 | (if non-blocking #'read-byte-no-hang #'read-byte) |
|---|
| 119 | (if non-blocking #'read-char-no-hang #'read-char))) |
|---|
| 120 | (limit-vector (coerce limit '(vector t *))) |
|---|
| 121 | (targ-max (1- (length target))) |
|---|
| 122 | (limit-max (length limit)) |
|---|
| 123 | (limit-cur 0) |
|---|
| 124 | (targ-cur -1)) |
|---|
| 125 | (declare (optimize (speed 3) (debug 0)) |
|---|
| 126 | (type fixnum targ-cur)) |
|---|
| 127 | ;; In SBCL read-char is a buffered operations (depending on |
|---|
| 128 | ;; stream creation parameters), so this loop should be quite efficient |
|---|
| 129 | ;; For others, if this becomes an efficiency problem, please report... |
|---|
| 130 | (loop for next-elt = (funcall read-fun stream nil nil) |
|---|
| 131 | if (null next-elt) |
|---|
| 132 | do (return (values target targ-cur t)) |
|---|
| 133 | else do |
|---|
| 134 | (setf (elt target (incf targ-cur)) next-elt) |
|---|
| 135 | (if (eql next-elt (aref limit-vector limit-cur)) |
|---|
| 136 | (incf limit-cur) |
|---|
| 137 | (setf limit-cur 0)) |
|---|
| 138 | |
|---|
| 139 | if (or (= targ-cur targ-max) |
|---|
| 140 | (= limit-cur limit-max)) |
|---|
| 141 | do (return (values target (1+ targ-cur) nil))))) |
|---|
| 142 | |
|---|
| 143 | (defun substring (string start &optional end) |
|---|
| 144 | (let* ((end-index (if end end (length string))) |
|---|
| 145 | (seq-len (- end-index start))) |
|---|
| 146 | (make-array seq-len |
|---|
| 147 | :element-type (array-element-type string) |
|---|
| 148 | :displaced-to string |
|---|
| 149 | :displaced-index-offset start))) |
|---|
| 150 | |
|---|
| 151 | |
|---|
| 152 | (defun cut-between (string start-char end-chars |
|---|
| 153 | &key (start 0) (cut-extra t) (cut-to-end nil)) |
|---|
| 154 | "If `start-char' is not nil, cut string between `start-char' and any |
|---|
| 155 | of the `end-chars', from `start'. If `start-char' is nil, cut from |
|---|
| 156 | `start' until any of the `end-chars' (or sting-end when `cut-to-end' is true). |
|---|
| 157 | |
|---|
| 158 | If `cut-extra' is t, we will cut from start + 1 instead of just |
|---|
| 159 | `start'. |
|---|
| 160 | |
|---|
| 161 | When there is no string matching the input parameters `start' and nil |
|---|
| 162 | will be returned, otherwise `end-position' and the string are |
|---|
| 163 | returned." |
|---|
| 164 | (let ((end-position (or (position-if #'(lambda (char) |
|---|
| 165 | (member char end-chars)) |
|---|
| 166 | string :start (1+ start)) |
|---|
| 167 | (when cut-to-end (length string)))) |
|---|
| 168 | (cut-from (if cut-extra |
|---|
| 169 | (1+ start) |
|---|
| 170 | start))) |
|---|
| 171 | (if (and end-position start-char) |
|---|
| 172 | (if (eql (char string start) start-char) |
|---|
| 173 | (values end-position |
|---|
| 174 | (substring string cut-from end-position)) |
|---|
| 175 | (values start nil)) |
|---|
| 176 | (if end-position |
|---|
| 177 | (values end-position |
|---|
| 178 | (substring string cut-from end-position)) |
|---|
| 179 | (values start nil))))) |
|---|
| 180 | |
|---|
| 181 | (defun cut-before (string substring end-chars |
|---|
| 182 | &key (start 0) (cut-extra t) (cut-to-end nil)) |
|---|
| 183 | "Cut `string' before `substring' or any of the `end-chars', from `start', |
|---|
| 184 | if none of substring or end-chars are found, until the end of the string |
|---|
| 185 | when `cut-to-end' is true. |
|---|
| 186 | |
|---|
| 187 | If `cut-extra' is t, we will cut from start + 1 instead of just |
|---|
| 188 | `start'. |
|---|
| 189 | |
|---|
| 190 | When there is no string matching the input parameters `start' and nil |
|---|
| 191 | will be returned, otherwise `end-position' and the string are |
|---|
| 192 | returned." |
|---|
| 193 | (let ((end-position (search substring string :start2 start))) |
|---|
| 194 | (if end-position |
|---|
| 195 | (values (+ end-position (1- (length substring))) |
|---|
| 196 | (substring string (if (and cut-extra |
|---|
| 197 | (< start end-position)) |
|---|
| 198 | (1+ start) start) end-position)) |
|---|
| 199 | (let ((end-position (or (position-if #'(lambda (x) |
|---|
| 200 | (member x end-chars)) |
|---|
| 201 | string :start (1+ start)) |
|---|
| 202 | (when cut-to-end (length string)))) |
|---|
| 203 | (cut-from (if cut-extra (1+ start) start))) |
|---|
| 204 | (if end-position |
|---|
| 205 | (values end-position |
|---|
| 206 | (substring string cut-from end-position)) |
|---|
| 207 | (values start nil)))))) |
|---|
| 208 | |
|---|
| 209 | |
|---|
| 210 | ;; |
|---|
| 211 | ;; Message arguments binding macro |
|---|
| 212 | ;; |
|---|
| 213 | |
|---|
| 214 | (defmacro destructuring-arguments (lambda-list message &body body) |
|---|
| 215 | "Destructures the `arguments' slot in `message' according |
|---|
| 216 | to `lambda-list' and binds them in `body'. |
|---|
| 217 | |
|---|
| 218 | The lambda list syntax is as follows: |
|---|
| 219 | |
|---|
| 220 | wholevar::= &whole var |
|---|
| 221 | reqvars::= var* |
|---|
| 222 | optvars::= [&optional {var | (var [init-form [supplied-p-parameter]])}* ] |
|---|
| 223 | restvar::= [&rest var] |
|---|
| 224 | reqtrailingvars::= [&req var*] |
|---|
| 225 | lambda-list::= (wholevar reqvars optvars restvar reqtrailingvars) |
|---|
| 226 | |
|---|
| 227 | With the exception of &req (which is new) and &rest, all lambda list |
|---|
| 228 | keywords are analogous to a destructuring lambda list (see clhs 3.4.5). |
|---|
| 229 | |
|---|
| 230 | If &req is specified, these values are consumed off the end of the list |
|---|
| 231 | before processing any preceeding &optional or &rest keywords. |
|---|
| 232 | |
|---|
| 233 | For any variable, the `:ignored' keyword can be passed instead, |
|---|
| 234 | indicating the binding should be ignored in the `body'." |
|---|
| 235 | (let ((%message (gensym)) |
|---|
| 236 | (%args (gensym)) |
|---|
| 237 | (%arg-count (gensym)) |
|---|
| 238 | (valid-keywords '(&whole &optional &rest &req))) |
|---|
| 239 | (labels ((lambda-key-p (x) |
|---|
| 240 | (member x valid-keywords)) |
|---|
| 241 | (ignored-p (x) |
|---|
| 242 | (eq x :ignored)) |
|---|
| 243 | (count-valid-keys (lambda-list) |
|---|
| 244 | (count-if #'lambda-key-p lambda-list)) |
|---|
| 245 | (replace-ignored (lambda-list) |
|---|
| 246 | (let ((ignores)) |
|---|
| 247 | (values (mapcar #'(lambda (x) |
|---|
| 248 | (if (ignored-p x) |
|---|
| 249 | (let ((y (gensym))) |
|---|
| 250 | (push y ignores) |
|---|
| 251 | y) |
|---|
| 252 | x)) |
|---|
| 253 | lambda-list) |
|---|
| 254 | ignores))) |
|---|
| 255 | (bind-req-trail (req-trail args body) |
|---|
| 256 | (let ((req-syms (cdr req-trail))) |
|---|
| 257 | (if (and req-trail |
|---|
| 258 | (notevery #'ignored-p req-syms)) |
|---|
| 259 | (multiple-value-bind |
|---|
| 260 | (ll ignores) (replace-ignored req-syms) |
|---|
| 261 | `(destructuring-bind |
|---|
| 262 | ,ll ,args |
|---|
| 263 | ,(if ignores |
|---|
| 264 | `(declare (ignore ,@ignores)) |
|---|
| 265 | (values)) |
|---|
| 266 | ,body)) |
|---|
| 267 | body)))) |
|---|
| 268 | |
|---|
| 269 | (let* ((whole-var (when (eq (car lambda-list) '&whole) |
|---|
| 270 | (second lambda-list))) |
|---|
| 271 | (lambda-list (if whole-var (nthcdr 2 lambda-list) lambda-list)) |
|---|
| 272 | (opt-entries (member '&optional lambda-list)) |
|---|
| 273 | (rest-entries (member '&rest lambda-list)) |
|---|
| 274 | (req-trail (member '&req lambda-list)) |
|---|
| 275 | (destructuring-ll (butlast lambda-list (length req-trail))) |
|---|
| 276 | (longest-sublist (cond |
|---|
| 277 | (opt-entries opt-entries) |
|---|
| 278 | (rest-entries rest-entries) |
|---|
| 279 | (req-trail req-trail) |
|---|
| 280 | (t nil))) |
|---|
| 281 | (min-entries (+ (if req-trail (1- (length req-trail)) 0) |
|---|
| 282 | ;; required start && end |
|---|
| 283 | (- (- (length lambda-list) |
|---|
| 284 | (count-valid-keys lambda-list)) |
|---|
| 285 | (- (length longest-sublist) |
|---|
| 286 | (count-valid-keys longest-sublist))))) |
|---|
| 287 | (max-entries (when (null rest-entries) |
|---|
| 288 | ;; required start && end && optionals |
|---|
| 289 | (+ min-entries |
|---|
| 290 | (if opt-entries |
|---|
| 291 | (- (1- (length opt-entries)) |
|---|
| 292 | (length req-trail)) |
|---|
| 293 | 0))))) |
|---|
| 294 | |
|---|
| 295 | `(let* ((,%message ,message) |
|---|
| 296 | (,%args (arguments ,%message)) |
|---|
| 297 | (,%arg-count (length ,%args)) |
|---|
| 298 | ,@(if (and whole-var |
|---|
| 299 | (not (ignored-p whole-var))) |
|---|
| 300 | `((,whole-var ,%args)) |
|---|
| 301 | (values))) |
|---|
| 302 | (when ,(if max-entries |
|---|
| 303 | `(not (and (<= ,min-entries ,%arg-count) |
|---|
| 304 | (<= ,%arg-count ,max-entries))) |
|---|
| 305 | `(> ,min-entries ,%arg-count)) |
|---|
| 306 | ;; we want to raise a cl-irc condition here! |
|---|
| 307 | (error (format nil "Unexpected protocol input; provided arguments ~ |
|---|
| 308 | ~S don't match with expected arguments ~S" ',lambda-list ,%args))) |
|---|
| 309 | ,(bind-req-trail |
|---|
| 310 | req-trail |
|---|
| 311 | `(last ,%args ,(1- (length req-trail))) |
|---|
| 312 | (multiple-value-bind |
|---|
| 313 | (ll ignores) (replace-ignored destructuring-ll) |
|---|
| 314 | `(destructuring-bind |
|---|
| 315 | ,ll |
|---|
| 316 | ,(if req-trail |
|---|
| 317 | `(butlast ,%args ,(1- (length req-trail))) |
|---|
| 318 | %args) |
|---|
| 319 | ,(if ignores |
|---|
| 320 | `(declare (ignore ,@ignores)) |
|---|
| 321 | (values)) |
|---|
| 322 | ,@body)))))))) |
|---|
| 323 | |
|---|
| 324 | |
|---|
| 325 | ;; |
|---|
| 326 | ;; RPL_ISUPPORT support routines |
|---|
| 327 | ;; |
|---|
| 328 | |
|---|
| 329 | (defun parse-isupport-prefix-argument (prefix) |
|---|
| 330 | (declare (type string prefix)) |
|---|
| 331 | (let ((closing-paren-pos (position #\) prefix))) |
|---|
| 332 | (when (and (eq (elt prefix 0) #\( ) |
|---|
| 333 | closing-paren-pos) |
|---|
| 334 | (let ((prefixes (substring prefix (1+ closing-paren-pos))) |
|---|
| 335 | (modes (substring prefix 1 closing-paren-pos))) |
|---|
| 336 | (when (= (length prefixes) |
|---|
| 337 | (length modes)) |
|---|
| 338 | (values prefixes modes)))))) |
|---|
| 339 | |
|---|
| 340 | (defun nick-prefixes-from-isupport (isupport-arguments) |
|---|
| 341 | "Returns an assoc list associating prefix characters with mode characters." |
|---|
| 342 | (multiple-value-bind |
|---|
| 343 | (prefixes modes) |
|---|
| 344 | (parse-isupport-prefix-argument (second (assoc "PREFIX" |
|---|
| 345 | isupport-arguments |
|---|
| 346 | :test #'string=))) |
|---|
| 347 | (let ((rv)) |
|---|
| 348 | (dotimes (i (length modes) |
|---|
| 349 | rv) |
|---|
| 350 | (setf (getf rv (char prefixes i)) |
|---|
| 351 | (char modes i)))))) |
|---|
| 352 | |
|---|
| 353 | (defun chanmode-descs-from-isupport (isupport-arguments |
|---|
| 354 | &optional |
|---|
| 355 | (mode-symbols |
|---|
| 356 | *default-char-to-channel-modes-map*)) |
|---|
| 357 | "Parses a string describing channel modes conforming to |
|---|
| 358 | http://www.irc.org/tech_docs/draft-brocklesby-irc-isupport-03.txt |
|---|
| 359 | paragraph 3.3. |
|---|
| 360 | |
|---|
| 361 | It returns a list of mode-description records." |
|---|
| 362 | (let* ((mode-desc-recs) |
|---|
| 363 | (pref (second (assoc "PREFIX" isupport-arguments :test #'string=))) |
|---|
| 364 | (chanmodes (second (assoc "CHANMODES" isupport-arguments |
|---|
| 365 | :test #'string=))) |
|---|
| 366 | (modes-list |
|---|
| 367 | (cons (second (multiple-value-list |
|---|
| 368 | (parse-isupport-prefix-argument pref))) |
|---|
| 369 | (split-sequence:split-sequence #\, chanmodes))) |
|---|
| 370 | (mode-descs '(;; B type mode from PREFIX with nick argument |
|---|
| 371 | (t t t list-value-mode) |
|---|
| 372 | ;; A type mode |
|---|
| 373 | (:optional-for-server |
|---|
| 374 | :optional-for-server nil list-value-mode) |
|---|
| 375 | ;; B type mode from CHANMODES |
|---|
| 376 | (t t nil single-value-mode) |
|---|
| 377 | ;; C type mode from CHANMODES |
|---|
| 378 | (t nil nil single-value-mode) |
|---|
| 379 | ;; D type mode from CHANMODES |
|---|
| 380 | (nil nil nil boolean-value-mode)))) |
|---|
| 381 | (do ((mode (pop modes-list) (pop modes-list)) |
|---|
| 382 | (mode-desc (pop mode-descs) (pop mode-descs))) |
|---|
| 383 | ((null mode-desc) mode-desc-recs) |
|---|
| 384 | (when (< 0 (length mode)) |
|---|
| 385 | (let ((mode-struct |
|---|
| 386 | (make-mode-description :param-on-set-p (first mode-desc) |
|---|
| 387 | :param-on-unset-p (second mode-desc) |
|---|
| 388 | :nick-param-p (third mode-desc) |
|---|
| 389 | :class (fourth mode-desc)))) |
|---|
| 390 | (dotimes (j (length mode)) |
|---|
| 391 | (let ((mode-rec (copy-structure mode-struct)) |
|---|
| 392 | (mode-char (elt mode j))) |
|---|
| 393 | (setf (mode-desc-char mode-rec) mode-char |
|---|
| 394 | (mode-desc-symbol mode-rec) (cdr (assoc mode-char |
|---|
| 395 | mode-symbols))) |
|---|
| 396 | (push mode-rec mode-desc-recs)))))))) |
|---|
| 397 | |
|---|
| 398 | (defmacro do-property-list ((prop val list) &body body) |
|---|
| 399 | (let ((lsym (gensym))) |
|---|
| 400 | `(let ((,lsym ,list)) |
|---|
| 401 | (do* ((,prop (pop ,lsym) (pop ,lsym)) |
|---|
| 402 | (,val (pop ,lsym) (pop ,lsym))) |
|---|
| 403 | ((and (null ,lsym) |
|---|
| 404 | (null ,prop) |
|---|
| 405 | (null ,val))) |
|---|
| 406 | ,@body)))) |
|---|
| 407 | |
|---|
| 408 | (defgeneric irc-string-downcase (map-name string &key start end)) |
|---|
| 409 | |
|---|
| 410 | (defmethod irc-string-downcase (map-name |
|---|
| 411 | string &key (start 0) end) |
|---|
| 412 | (declare (ignore map-name)) |
|---|
| 413 | (let* ((new-string (substitute #\[ #\{ string :start start :end end)) |
|---|
| 414 | (new-string (substitute #\] #\} new-string :start start :end end)) |
|---|
| 415 | (new-string (substitute #\\ #\| new-string :start start :end end)) |
|---|
| 416 | (new-string (substitute #\~ #\^ new-string :start start :end end))) |
|---|
| 417 | (string-downcase new-string :start start :end end))) |
|---|
| 418 | |
|---|
| 419 | (defmethod irc-string-downcase ((map-name (eql :ascii)) |
|---|
| 420 | string &key (start 0) end) |
|---|
| 421 | (declare (ignore map-name)) |
|---|
| 422 | (string-downcase string :start start :end end)) |
|---|
| 423 | |
|---|
| 424 | (defun parse-isupport-multivalue-argument (argument) |
|---|
| 425 | (declare (type string argument)) |
|---|
| 426 | (mapcar #'(lambda (x) |
|---|
| 427 | (split-sequence:split-sequence #\: x)) |
|---|
| 428 | (split-sequence:split-sequence #\, argument))) |
|---|
| 429 | |
|---|
| 430 | (defun parse-mode-arguments (connection target arguments &key server-p) |
|---|
| 431 | "Create a list of mode changes with their arguments for `target' |
|---|
| 432 | from `mode-string' and `arguments'. |
|---|
| 433 | |
|---|
| 434 | Throw nil to the UNKNOWN-MODE symbol if any of the mode chars are unknown." |
|---|
| 435 | (catch 'illegal-mode-spec |
|---|
| 436 | (if (and (= 1 (length arguments)) |
|---|
| 437 | (null (position (char (first arguments) 0) "+-"))) |
|---|
| 438 | ;; type 1 mode specification; only allowed on servers |
|---|
| 439 | (when server-p |
|---|
| 440 | (let ((ops) |
|---|
| 441 | (arg (car arguments))) |
|---|
| 442 | (dotimes (i (length arg) (reverse ops)) |
|---|
| 443 | (push (char arg i) ops)))) |
|---|
| 444 | ;; type 2 mode specification; clients and servers |
|---|
| 445 | (let ((ops)) |
|---|
| 446 | (do ((changes (pop arguments) (pop arguments))) |
|---|
| 447 | ((null changes) (values ops nil)) |
|---|
| 448 | (let* ((this-op (char changes 0)) |
|---|
| 449 | (modes (substring changes 1)) |
|---|
| 450 | (param-req (if (char= this-op #\+) |
|---|
| 451 | #'mode-desc-param-on-set-p |
|---|
| 452 | #'mode-desc-param-on-unset-p))) |
|---|
| 453 | (unless (position this-op "+-") |
|---|
| 454 | (throw 'illegal-mode-spec nil)) |
|---|
| 455 | (dotimes (i (length modes)) |
|---|
| 456 | (case (char modes i) |
|---|
| 457 | ((#\+ #\-) (setf this-op (char modes i))) |
|---|
| 458 | (t |
|---|
| 459 | (let* ((mode-rec |
|---|
| 460 | (mode-description connection target |
|---|
| 461 | (mode-name-from-char connection target |
|---|
| 462 | (char modes i)))) |
|---|
| 463 | (param-p (when mode-rec |
|---|
| 464 | (funcall param-req mode-rec)))) |
|---|
| 465 | (when (or (null mode-rec) |
|---|
| 466 | (and param-p |
|---|
| 467 | (= 0 (length arguments)))) |
|---|
| 468 | (throw 'illegal-mode-spec nil)) |
|---|
| 469 | (push (list this-op |
|---|
| 470 | (mode-desc-symbol mode-rec) |
|---|
| 471 | (when param-p |
|---|
| 472 | (if (mode-desc-nick-param-p mode-rec) |
|---|
| 473 | (find-user connection (pop arguments)) |
|---|
| 474 | (pop arguments)))) ops))))))))))) |
|---|
| 475 | |
|---|
