/[beirc]/beirc/message-display.lisp
ViewVC logotype

Contents of /beirc/message-display.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.51 - (show annotations)
Sat Feb 24 10:58:16 2007 UTC (7 years, 1 month ago) by dlichteblau
Branch: MAIN
CVS Tags: HEAD
Changes since 1.50: +1 -1 lines
use McCLIM's built-in tab layout
1 (in-package :beirc)
2
3 (declaim (optimize (debug 2) (speed 0)
4 (space 0)))
5
6 (defvar *max-preamble-length* 0)
7
8 (defvar *current-message*)
9
10 (defparameter *colors* `((0 . (:ink ,+white+))
11 (1 . (:ink ,+black+))
12 (2 . (:ink ,+blue+))
13 (3 . (:ink ,+green+))
14 (4 . (:ink ,+red+))
15 (5 . (:ink ,+brown+))
16 (6 . (:ink ,+purple+))
17 (7 . (:ink ,+orange+))
18 (8 . (:ink ,+yellow+))
19 (9 . (:ink ,+light-green+))
20 (10 . (:ink ,+dark-cyan+))
21 (11 . (:ink ,+cyan+))
22 (12 . (:ink ,+royal-blue+))
23 (13 . (:ink ,+pink+))
24 (14 . (:ink ,+grey+))
25 (15 . (:ink ,+light-grey+))
26 ("" . (normal))
27 ("" . (underline))
28 ("" . (inverse))
29 ("" . (bold))))
30
31 (defparameter *color-scanner* (cl-ppcre:create-scanner "[0-9]{1,2}(,[0-9]{1,2}){0,1}||||"))
32
33 (define-presentation-type url ()
34 :inherit-from 'string)
35
36 (define-presentation-type meme-url ()
37 :inherit-from 'url)
38
39
40 (defun present-url (url)
41 (let* ((clhs-base "http://www.lispworks.com/reference/HyperSpec/")
42 (start (search clhs-base url)))
43 (cond (start
44 (let* ((clhs-page (subseq url (+ start (length clhs-base))))
45 (new-url (concatenate 'string *hyperspec-base-url* clhs-page)))
46 (write-string (subseq url 0 start))
47 (with-output-as-presentation (t new-url 'url)
48 (format t "clhs://~A" clhs-page))))
49 ((> (length url) *default-fill-column*)
50 (let ((new-url
51 (concatenate 'string
52 (subseq url 0 (floor *default-fill-column* 2))
53 "..."
54 (subseq url (- (length url)
55 (- (floor *default-fill-column* 2) 3))))))
56 (with-output-as-presentation (t url 'url)
57 (write-string new-url))))
58 (t (present url 'url)))))
59
60 (defun message-from-focused-nick-p (message receiver)
61 (member (irc:source message) (focused-nicks receiver) :test #'string=))
62
63 (defun message-from-ignored-nick-p (message receiver)
64 (declare (ignore receiver))
65 (member (irc:source message) (slot-value *application-frame* 'ignored-nicks)
66 :test #'string=))
67
68 (defun +boolean (initial-value &rest booleans)
69 (loop for value = initial-value then (+ (ash value 1)
70 (if boolean 1 0))
71 for boolean in booleans
72 finally (return value)))
73
74 (defun invoke-formatting-message (stream message receiver preamble-writer message-body-writer)
75 (let* ((*current-message* message)
76 (stream* (if (eql stream t) *standard-output* stream))
77 (width (- (floor (bounding-rectangle-width (sheet-parent stream*))
78 (clim:stream-string-width stream* "X"))
79 2)))
80 (labels ((make-meme-url (message)
81 (format nil "http://meme.b9.com/cview.html?channel=~A&utime=~A#utime_requested"
82 (string-trim '(#\#) (channel receiver))
83 (irc:received-time message)))
84 (format-timestamp (message)
85 (format stream* "[~2,'0D:~2,'0D]"
86 (nth-value 2 (decode-universal-time (irc:received-time message)))
87 (nth-value 1 (decode-universal-time (irc:received-time message)))))
88 (output-timestamp-column (position)
89 (when (eql position *timestamp-column-orientation*)
90 (formatting-cell (stream* :align-x :left)
91 (with-drawing-options (stream* :ink +gray+)
92 (if (and *meme-log-bot-nick*
93 (irc:find-user (connection receiver) *meme-log-bot-nick*)
94 (member (title receiver)
95 (irc:channels (irc:find-user (connection receiver) *meme-log-bot-nick*))
96 :test #'equal
97 :key #'irc:name))
98 (with-output-as-presentation (stream* (make-meme-url message) 'meme-url)
99 (format-timestamp message))
100 (format-timestamp message)))))))
101 (updating-output (stream*
102 :cache-value
103 (+boolean (sxhash (list message
104 width
105 *max-preamble-length*
106 *default-fill-column*))
107 (message-from-focused-nick-p message receiver)
108 (message-from-ignored-nick-p message receiver)
109 (eql *timestamp-column-orientation* :left))
110 :cache-test #'eql)
111 (formatting-row (stream*)
112 (output-timestamp-column :left)
113 (formatting-cell (stream* :align-x :right :min-width '(3 :character))
114 (with-drawing-options (stream* :ink +dark-red+)
115 (funcall preamble-writer)))
116 (formatting-cell (stream* :align-x :left
117 :min-width `(,*default-fill-column* :character))
118 (funcall message-body-writer))
119 (output-timestamp-column :right))))))
120
121 (defmacro formatting-message ((stream message receiver)
122 (&body preamble-column-body)
123 (&body message-body-column-body))
124 ;; Fix me: This usage of UPDATING-OUTPUT is sub-optimal and ugly!
125 ;; (asf 2005-09-17: is it still?)
126 `(invoke-formatting-message ,stream ,message ,receiver
127 (lambda ()
128 ,@preamble-column-body)
129 (lambda ()
130 ,@message-body-column-body)))
131
132 ;;; for optimal indentation, use (put 'formatting-message 'common-lisp-indent-function 1)
133
134 (defun strip-punctuation (word)
135 (if (= (length word) 0)
136 (values word "")
137 (let ((last-char (char word (1- (length word)))))
138 (case last-char
139 ((#\: #\, #\. #\; #\) #\] #\} #\> #\? #\! #\" #\')
140 (values (subseq word 0 (1- (length word)))
141 (string last-char)))
142 (otherwise (values word ""))))))
143
144 (defun strip-preceding-punctuation (word)
145 (if (= (length word) 0)
146 (values word "")
147 (let ((first-char (char word 0)))
148 (case first-char
149 ((#\@ #\+ #\< #\()
150 (values (subseq word 1)
151 (string first-char)))
152 (otherwise (values word ""))))))
153
154 (defun extract-color (string)
155 (multiple-value-bind (start end)
156 (cl-ppcre:scan *color-scanner*
157 string)
158 (if start
159 (let* ((message (subseq string end))
160 (color-code (subseq string start end))
161 (color-code (or (cl-ppcre:all-matches-as-strings "[0-9]{1,2}"
162 color-code)
163 (list (cl-ppcre:scan-to-strings "|||"
164 color-code))))
165 (foreground (or (parse-integer (car color-code)
166 :junk-allowed t)
167 (car color-code)))
168 (background (when (cadr color-code)
169 (parse-integer (cadr color-code)
170 :junk-allowed t)))
171 (foreground (cdr (assoc foreground
172 *colors*
173 :test #'equal)))
174 (background (cdr (assoc background
175 *colors*
176 :test #'equal))))
177 (values message
178 foreground
179 background
180 ))
181 string)))
182
183 (defun split-before (delimiter string)
184 (let ((matches (cl-ppcre:all-matches delimiter string)))
185 (if matches
186 (loop for (a b c) on matches by #'cddr
187 collecting (subseq string a c) into strings
188 finally (return (if (zerop (car matches))
189 strings
190 (cons (subseq string
191 0
192 (car matches))
193 strings))))
194 (list string))))
195
196 (defmacro do-colored-string ((string-var str) &body body)
197 `(dolist (part (split-before *color-scanner* ,str))
198 (multiple-value-bind (message foreground background)
199 (extract-color part)
200 (cond (*filter-colors* nil)
201 ((equal (car foreground)
202 'normal)
203 (setf foreground-color +black+
204 background-color +white+))
205 ((equal (car foreground)
206 :ink)
207 (setf foreground-color
208 (cadr foreground))
209 (when background
210 (setf background-color (cadr background))))
211 ((equal (car foreground)
212 'bold)
213 (setf bold (if bold nil :bold)))
214 ((equal (car foreground)
215 'underline)
216 (setf underline (not underline)))
217 ((equal (car foreground)
218 'inverse)
219 (setf inverse (not inverse))))
220 (with-drawing-options (t :text-face bold)
221 (let ((,string-var message))
222 (if inverse
223 (with-irc-colors (background-color foreground-color underline)
224 ,@body)
225 (with-irc-colors (foreground-color background-color underline)
226 ,@body)))))))
227
228 (defmacro with-irc-colors ((foreground background underlinep) &body body)
229 `(with-sheet-medium (medium *standard-output*)
230 (let ((record (with-new-output-record (t)
231 (with-drawing-options (t :ink ,foreground)
232 ,@body))))
233 (with-bounding-rectangle* (left top right bottom)
234 record
235 (unless (equal left right)
236 (unless (equal ,background +white+)
237 (with-identity-transformation (medium)
238 (draw-rectangle* *standard-output*
239 left
240 top
241 right
242 bottom
243 :filled t
244 :ink ,background)
245 (replay-output-record record *standard-output*)
246 (setf (stream-cursor-position *standard-output*)
247 (values right top))))
248 (when ,underlinep
249 (draw-line* *standard-output* left (- bottom 1)
250 (- right 1) (- bottom 1)
251 :ink ,foreground)))
252 record))))
253
254 (defun format-message* (mumble &key (limit *default-fill-column*) (start-length 0))
255 (let ((foreground-color (medium-ink *standard-output*))
256 (background-color (medium-background *standard-output*))
257 (bold nil)
258 (underline nil)
259 (inverse nil))
260 (let ((column start-length))
261 (loop for (word . rest) on (split-sequence:split-sequence #\Space mumble)
262 do (do-colored-string (word word)
263 (incf column (length word))
264 (when (> column limit)
265 (setf column (length word))
266 (terpri))
267 (multiple-value-bind (%word stripped-preceding-punctuation) (strip-preceding-punctuation word)
268 (multiple-value-bind (word% stripped-punctuation) (strip-punctuation %word)
269 (write-string stripped-preceding-punctuation)
270 (cond
271 ((or (search "http://" word%) (search "https://" word%))
272 (present-url word%))
273 ((or
274 (nick-equals-my-nick-p word% (irc:connection *current-message*))
275 (and (current-connection *application-frame*)
276 (irc:find-user (current-connection *application-frame*) word%)))
277 (present word% 'nickname))
278 ((channelp word%) (present word% 'channel))
279 (t (write-string word%)))
280 (write-string stripped-punctuation))))
281 do (unless (or (null rest) (>= column limit))
282 (do-colored-string (s " ")
283 (write-string s)
284 (incf column))))
285 (terpri))))
286
287 ;;; privmsg-like messages
288
289 (defmethod trailing-argument* (message)
290 (car (last (irc:arguments message))))
291
292 (defmethod trailing-argument* ((message cl-irc:ctcp-action-message))
293 (or
294 (ignore-errors ;###
295 (let ((p1 (position #\space (car (last (irc:arguments message))))))
296 (subseq (car (last (irc:arguments message)))
297 (1+ p1)
298 (1- (length (car (last (irc:arguments message))))))))
299 "#Garbage parsing message#"))
300
301 (defun print-privmsg-like-message (message receiver start-string end-string)
302 (with-drawing-options
303 (*standard-output*
304 :ink (if (string-equal "localhost" (irc:host message))
305 +blue4+
306 +black+))
307 (unless (message-from-ignored-nick-p message receiver)
308 (with-text-face
309 (*standard-output*
310 (if (message-from-focused-nick-p message receiver) :bold :roman))
311 (irc:destructuring-arguments (&rest :ignored &req body) message
312 (formatting-message (t message receiver)
313 ((write-string start-string *standard-output*)
314 (present (irc:source message) 'unhighlighted-nickname)
315 (write-string end-string *standard-output*))
316 ((format-message* body))))))))
317
318 (defmethod print-message ((message irc:IRC-PRIVMSG-MESSAGE) receiver)
319 (print-privmsg-like-message message receiver "<" ">"))
320
321 (defmethod print-message ((message irc:IRC-NOTICE-MESSAGE) receiver)
322 (print-privmsg-like-message message receiver "-" "-"))
323
324 (defmethod print-message ((message irc:ctcp-action-message) receiver)
325 (let ((source (cl-irc:source message)))
326 (formatting-message (t message receiver)
327 ((format t "*"))
328 ((present source 'unhighlighted-nickname)
329 (format t " ")
330 (format-message* (trailing-argument* message)
331 :start-length (+ 2 (length source)))))))
332
333 (defmethod print-message ((message irc:ctcp-version-message) receiver)
334 (let ((source (cl-irc:source message)))
335 (formatting-message (t message receiver)
336 ((format t " "))
337 ((with-drawing-options (*standard-output* :ink +gray33+ :text-size :small)
338 (present source 'unhighlighted-nickname)
339 (format t " ")
340 (format-message* "asked for your IRC client version" :start-length (+ 2 (length source))))))))
341
342 ;;; server messages
343
344 (macrolet ((define-server-message-printer ((&rest message-specs))
345 `(progn
346 ,@(loop for (message-type . message-name) in message-specs
347 collect
348 `(defmethod print-message ((message ,message-type) receiver)
349 (irc:destructuring-arguments (:ignored &rest arguments &req body) message
350 (formatting-message (t message receiver)
351 ((format t "~A" (irc:source message)))
352 ((with-drawing-options (*standard-output* :ink +gray33+ :text-size :small)
353 (format-message*
354 (format nil "~@[~A: ~]~{~A ~}~A" ,message-name (butlast arguments) body)))))))))))
355 (define-server-message-printer ((irc:irc-rpl_motd-message . "MODT")
356 (irc:irc-rpl_motdstart-message . "MOTD")
357 (irc:irc-rpl_isupport-message)
358 (irc:irc-rpl_yourid-message . "Your id")
359 (irc:irc-rpl_luserop-message)
360 (irc:irc-rpl_luserclient-message)
361 (irc:irc-rpl_luserme-message)
362 (irc:irc-rpl_luserchannels-message)
363 (irc:irc-rpl_luserunknown-message)
364 (irc:irc-rpl_globalusers-message)
365 (irc:irc-rpl_localusers-message)
366 (irc:irc-rpl_created-message)
367 (irc:irc-rpl_welcome-message)
368 (irc:irc-rpl_yourhost-message)
369 (irc:irc-rpl_myinfo-message)
370 (irc:irc-rpl_hello-message)
371 (irc:irc-rpl_statsdline-message)
372 (irc:irc-rpl_statskline-message)
373 (irc:irc-rpl_statshline-message)
374 (irc:irc-rpl_statsvline-message)
375 (irc:irc-rpl_noaway-message)
376 (irc:irc-rpl_unaway-message))))
377
378 (defmethod print-message (message receiver)
379 ;; default message if we don't know how to render a message.
380 #+(or) (break "~S" message) ; uncomment to debug
381 (irc:destructuring-arguments (&whole args &rest :ignored &req body) message
382 (formatting-message (t message receiver)
383 ((format t "!!! ~A" (irc:source message)))
384 ((with-drawing-options (*standard-output* :ink +red+ :text-size :small)
385 (format t "~A ~A :~A" (irc:command message) (butlast args) body))))))
386
387 ;;; user-related messages
388
389 (defmethod print-message ((message irc:irc-quit-message) receiver)
390 (irc:destructuring-arguments (&optional body) message
391 (formatting-message (t message receiver)
392 ((format t " "))
393 ((with-drawing-options (*standard-output* :ink +gray33+ :text-size :small)
394 (format t "Quit: ")
395 (present (irc:source message) 'nickname)
396 (unless (null body)
397 (format t ": ")
398 (format-message* body :start-length (+ 8 (length (irc:source message))))
399 (when (string= (title receiver)
400 (irc:normalize-nickname (connection receiver) (irc:source message)))
401 (offer-close receiver))))))))
402
403 (defun present-as-hostmask (user host)
404 (write-char #\()
405 (with-output-as-presentation (t (format nil "*!*@~A" host) 'hostmask)
406 (format t "~A@~A" user host))
407 (write-char #\)))
408
409 (defmethod print-message ((message irc:irc-nick-message) receiver)
410 (irc:destructuring-arguments (&rest :ignored &req body) message
411 (formatting-message (t message receiver)
412 ((format t " "))
413 ((with-drawing-options (*standard-output* :ink +gray33+ :text-size :small)
414 (format t "Nick change: ")
415 (present (irc:source message) 'nickname)
416 (write-string " ")
417 (present-as-hostmask (irc:user message) (irc:host message))
418 (write-string " is now known as ")
419 (present body 'nickname))))))
420
421 (defmethod print-message ((message irc:irc-rpl_whoisuser-message) receiver)
422 (formatting-message (t message receiver)
423 ((format t " "))
424 ((with-drawing-options (*standard-output* :ink +gray33+ :text-size :small)
425 (irc:destructuring-arguments (:ignored nickname user host &rest :ignored &req ircname) message
426 (present nickname 'nickname)
427 (format t " is ")
428 (present-as-hostmask user host)
429 (format t " (~A)" ircname))))))
430
431 (defmethod print-message ((message irc:irc-rpl_whoischannels-message) receiver)
432 (irc:destructuring-arguments (:ignored nickname &rest :ignored &req body) message
433 (formatting-message (t message receiver)
434 ((format t " "))
435 ((with-drawing-options (*standard-output* :ink +gray33+ :text-size :small)
436 (present nickname 'nickname)
437 (format-message* (format nil " is in ~A" body) :start-length (length nickname)))))))
438
439 (defmethod print-message ((message irc:irc-rpl_whoisserver-message) receiver)
440 (irc:destructuring-arguments (:ignored nickname server &rest :ignored &req server-callout) message
441 (formatting-message (t message receiver)
442 ((format t " "))
443 ((with-drawing-options (*standard-output* :ink +gray33+ :text-size :small)
444 (present nickname 'nickname)
445 (format-message* (format nil " is on ~A: ~A" server server-callout)
446 :start-length (length nickname)))))))
447
448 (defmethod print-message ((message irc:irc-rpl_away-message) receiver)
449 (irc:destructuring-arguments (:ignored nickname &rest :ignored &req away-msg) message
450 (formatting-message (t message receiver)
451 ((format t " "))
452 ((with-drawing-options (*standard-output* :ink +gray33+ :text-size :small)
453 (present nickname 'nickname)
454 (format-message* (format nil " is away: ~A" away-msg)
455 :start-length (length nickname)))))))
456
457 (defmethod print-message ((message irc:irc-rpl_whoisidentified-message) receiver)
458 (irc:destructuring-arguments (:ignored nickname body) message
459 (formatting-message (t message receiver)
460 ((format t " "))
461 ((with-drawing-options (*standard-output* :ink +gray33+ :text-size :small)
462 (present nickname 'nickname)
463 (write-char #\Space)
464 (format-message* body :start-length (length nickname)))))))
465
466 (defun unix-epoch-to-universal-time (epoch-time)
467 (+ epoch-time 2208988800 ; seconds between 1970-01-01 0:00 and 1900-01-01 0:00
468 ))
469
470 (defun format-unix-epoch (unix-epoch)
471 (multiple-value-bind (second minute hour date month year)
472 (decode-universal-time (unix-epoch-to-universal-time unix-epoch))
473 (format nil "~4,1,0,'0@A-~2,1,0,'0@A-~2,1,0,'0@A, ~2,1,0,'0@A:~2,1,0,'0@A:~2,1,0,'0@A"
474 year month date hour minute second)))
475
476 (defmethod print-message ((message irc:irc-rpl_whoisidle-message) receiver)
477 (irc:destructuring-arguments (:ignored nickname idle signon &rest :ignored) message
478 (formatting-message (t message receiver)
479 ((format t " "))
480 ((with-drawing-options (*standard-output* :ink +gray33+ :text-size :small)
481 (present nickname 'nickname)
482 (write-char #\Space)
483 (format-message* (format nil "was idle ~A seconds, signed on: ~A"
484 idle (format-unix-epoch (parse-integer signon)))
485 :start-length (length nickname)))))))
486
487 ;;; channel management messages
488
489 (defun offer-close (receiver)
490 (with-output-as-presentation (t `(com-close (,receiver)) 'command)
491 (with-drawing-options (*standard-output* :ink +grey12+ :text-size :small)
492 (format-message* "Click here to close this tab."))))
493
494 (defun offer-reconnect (receiver)
495 (let* ((conn (connection receiver))
496 (server (irc:server-name conn))
497 (nickname (irc:nickname (irc:user conn)))
498 (realname (irc:realname (irc:user conn))))
499 (with-output-as-presentation (t `(com-connect ,server :nick ,nickname :realname ,realname) 'command)
500 (with-drawing-options (*standard-output* :ink +grey12+ :text-size :small)
501 (format-message* (format nil "Click here to reconnect to ~A as ~A" server nickname))))))
502
503 (defmethod print-message ((message irc:irc-err_nosuchnick-message) receiver)
504 (formatting-message (t message receiver)
505 ((format t " "))
506 ((irc:destructuring-arguments (:ignored target &rest :ignored) message
507 (with-drawing-options (*standard-output* :ink +red3+ :text-size :small)
508 (format-message* (format nil "No such nick or channel \"~A\". "
509 target)))
510 (when (string= (title receiver)
511 (irc:normalize-nickname (connection receiver) target))
512 (offer-close receiver))))))
513
514 (defmethod print-message ((message irc:irc-err_blocking_notid-message) receiver)
515 (formatting-message (t message receiver)
516 ((format t " "))
517 ((with-drawing-options (*standard-output* :ink +red3+ :text-size :small)
518 (irc:destructuring-arguments (:ignored msg) message
519 (format-message* msg)
520 (with-drawing-options (*standard-output* :ink +grey12+ :text-size :small)
521 (with-output-as-presentation (t `(com-identify) 'command)
522 (format-message* "Click here to identify yourself."))))))))
523
524 (defmethod print-message ((message irc:irc-err_chanoprivsneeded-message) receiver)
525 (irc:destructuring-arguments (:ignored body) message
526 (formatting-message (t message receiver)
527 ((format t " "))
528 ((with-drawing-options (*standard-output* :ink +red3+ :text-size :small)
529 (format-message* (format nil "Not permitted: ~A" body)))))))
530
531 (defun print-topic (receiver message sender channel topic)
532 (formatting-message (t message receiver)
533 ((format t " "))
534 ((with-drawing-options (*standard-output* :ink +gray33+ :text-size :small)
535 (cond
536 ((and (null sender) (null topic))
537 (format-message* (format nil "No topic for ~A" channel)))
538 ((null sender)
539 (format-message* (format nil "Topic for ~A: ~A" channel topic)))
540 ((null topic)
541 (present sender 'nickname)
542 (format-message* (format nil " cleared the topic of ~A" channel)))
543 (t
544 (present sender 'nickname)
545 (format-message* (format nil " set the topic for ~A to ~A" channel topic))))))))
546
547 (defmethod print-message ((message irc:irc-topic-message) receiver)
548 (irc:destructuring-arguments (channel &rest :ignored &req topic) message
549 (print-topic receiver message (irc:source message) channel topic)))
550
551 (defmethod print-message ((message irc:irc-rpl_topic-message) receiver)
552 (irc:destructuring-arguments (:ignored channel &optional topic) message
553 (print-topic receiver message nil channel topic)))
554
555 (defmethod print-message ((message irc:irc-rpl_topicwhotime-message) receiver)
556 (formatting-message (t message receiver)
557 ((format t " "))
558 ((with-drawing-options (*standard-output* :ink +gray33+ :text-size :small)
559 (irc:destructuring-arguments (:ignored channel who time) message
560 (format-message* (format nil "~A topic set by ~A on ~A" channel who
561 (format-unix-epoch (parse-integer time)))))))))
562
563 (defmethod print-message ((message irc:irc-rpl_namreply-message) receiver)
564 (irc:destructuring-arguments (:ignored ; me
565 :ignored ; privacy
566 channel &rest :ignored &req nicks) message
567 (formatting-message (t message receiver)
568 ((format t " "))
569 ((with-drawing-options (*standard-output* :ink +gray33+ :text-size :small)
570 (format-message* (format nil "~A Names: ~A" channel nicks)))))))
571
572 (defmethod print-message ((message irc:irc-part-message) receiver)
573 (irc:destructuring-arguments (channel &optional part-msg) message
574 (formatting-message (t message receiver)
575 ((format t " "))
576 ((with-drawing-options (*standard-output* :ink +gray33+ :text-size :small)
577 (format t "Part: ")
578 (present (irc:source message) 'nickname)
579 (format t " left ~A" channel)
580 (unless (null part-msg)
581 (format-message* (format nil ": ~A" part-msg))))))))
582
583 (defmethod print-message ((message irc:irc-join-message) receiver)
584 (formatting-message (t message receiver)
585 ((format t " "))
586 ((with-drawing-options (*standard-output* :ink +gray33+ :text-size :small)
587 (format t "Join: ")
588 (present (irc:source message) 'nickname)
589 (write-char #\Space)
590 (present-as-hostmask (irc:user message) (irc:host message))))))
591
592 (defmethod print-message ((message irc:irc-kick-message) receiver)
593 (irc:destructuring-arguments (:ignored victim &optional kick-msg) message
594 (formatting-message (t message receiver)
595 ((format t " "))
596 ((with-drawing-options (*standard-output* :ink +gray33+ :text-size :small)
597 (present (irc:source message) 'nickname)
598 (write-string " kicked ")
599 (present victim 'nickname)
600 (unless (null kick-msg)
601 (format-message* (format nil ": ~A" kick-msg)
602 :start-length (+ 9 (length victim) (length (irc:source message))))))))))
603
604 ;;; XXX: uses unexported symbols from cl-irc, but I think their
605 ;;; unexportedness is accidental.
606 (defun mode-symbol-to-char (target mode)
607 (irc::mode-desc-char
608 (irc::mode-description (current-connection *application-frame*)
609 target mode)))
610
611 (defmethod print-mode-change (target op mode (user irc:user))
612 (format t "~A~A:" op (mode-symbol-to-char target mode))
613 (present (irc:nickname user) 'nickname))
614
615 (defmethod print-mode-change (target op (mode (eql :limit)) arg)
616 (format t "~A~A" op (mode-symbol-to-char target mode))
617 (when (not (null arg))
618 (write-char #\:)
619 (present arg 'number)))
620
621 (macrolet ((define-mode-change-with-hostmask-printer (&rest modes)
622 `(progn
623 ,@(loop for mode in modes
624 collect `(defmethod print-mode-change (target op (mode (eql ,mode)) mask)
625 (format t "~A~A:" op (mode-symbol-to-char target mode))
626 (present mask 'hostmask))))))
627 (define-mode-change-with-hostmask-printer :ban :invite :except))
628
629 (defmethod print-mode-change (target op mode arg)
630 (format t "~A~A~:[~;:~A~]" op (mode-symbol-to-char target mode) arg arg))
631
632 (defmethod print-message ((message irc:irc-mode-message) receiver)
633 (case (length (irc:arguments message))
634 (2 (formatting-message (t message receiver)
635 ((format t " "))
636 ((irc:destructuring-arguments (channel 1c-mode) message
637 (with-drawing-options (*standard-output* :ink +gray33+ :text-size :small)
638 (format-message* (format nil "~A set mode ~A ~A" (irc:source message)
639 channel 1c-mode)))))))
640 (t
641 (irc:destructuring-arguments (target &rest args) message
642 (let* ((connection (irc:connection message))
643 (target (or (irc:find-user connection target)
644 (irc:find-channel connection target)))
645 (mode-changes (irc:parse-mode-arguments connection target args
646 :server-p (irc:user connection))))
647 (formatting-message (t message receiver)
648 ((format t " "))
649 ((with-drawing-options (*standard-output* :ink +gray33+ :text-size :small)
650 (present (irc:source message) 'nickname)
651 (write-string " changes channel mode: ")
652 (loop for (change . rest) on mode-changes
653 do (destructuring-bind (op mode &optional arg) change
654 (print-mode-change target op mode arg))
655 if (not (null rest))
656 do (write-string ", "))))))))))
657
658 (macrolet ((define-*list-printer (&rest message-types)
659 `(progn
660 ,@(loop for (message-type prefix) in message-types
661 collect
662 `(defmethod print-message ((message ,message-type) receiver)
663 (formatting-message (t message receiver)
664 ((format t " "))
665 ((with-drawing-options (*standard-output* :ink +gray33+ :text-size :small)
666 (write-string ,prefix)
667 (present (nth 2 (irc:arguments message)) 'hostmask)
668 (when (find #\! (nth 3 (irc:arguments message)))
669 (write-string " by ")
670 (present (first (split-sequence:split-sequence #\! (nth 3 (irc:arguments message))))
671 'nickname))))))))))
672 (define-*list-printer
673 (irc:irc-rpl_banlist-message "BANNED: ")
674 (irc:irc-rpl_invitelist-message "INVITED: ")
675 (irc:irc-rpl_exceptlist-message "UNBANNED: ")))
676
677 (defmethod print-message ((message irc-connection-closed-message) receiver)
678 (formatting-message (t message receiver)
679 ((format t " "))
680 ((with-drawing-options (*standard-output* :ink +red3+)
681 (format-message* "Connection to server closed.")
682 (offer-reconnect receiver)))))
683
684 ;;; the display function (& utilities)
685
686 (defgeneric preamble-length (message)
687 (:method ((message irc:irc-privmsg-message))
688 (+ 2 (length (irc:source message))))
689 (:method ((message irc:ctcp-action-message))
690 1)
691 (:method ((message irc:irc-message))
692 3))
693
694 (defun beirc-app-display (*application-frame* *standard-output* receiver)
695 (let* ((messages (and receiver (messages receiver)))
696 (*max-preamble-length* (loop for message in messages
697 maximize (preamble-length message))))
698 (formatting-table (t)
699 (loop for message in messages
700 do (print-message message receiver)))))

  ViewVC Help
Powered by ViewVC 1.1.5