| 1 | ;;;; $Id: utility.lisp 239 2013-01-13 18:59:49Z ehuelsmann $ |
|---|
| 2 | ;;;; $URL: trunk/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)) |
|---|
