Update of /project/beirc/cvsroot/beirc In directory common-lisp.net:/tmp/cvs-serv23141 Modified Files: beirc.asd beirc.lisp Added Files: message-display.lisp Log Message: Factor out displaying of messages to message-display.lisp and add table-formatting. * move beirc-app-display and print-message methods into message-display.lisp * make print-message methods display messages inside a table to make their "interesting part" all start in the same column. (similar to XChat's message display or ERC's fill-static behavior) * PRESENT nicknames if we can identify them (currently, only by irc:source or if it's our own) * strip punctuation from URL and nickname presentation (but display them anyway) Date: Sat Sep 17 21:23:14 2005 Author: afuchs Index: beirc/beirc.asd diff -u beirc/beirc.asd:1.1 beirc/beirc.asd:1.2 --- beirc/beirc.asd:1.1 Wed Sep 14 22:31:44 2005 +++ beirc/beirc.asd Sat Sep 17 21:23:14 2005 @@ -8,4 +8,5 @@ (defsystem :beirc :depends-on (:mcclim :cl-irc :split-sequence) :components ((:file "package") - (:file "beirc" :depends-on ("package")))) \ No newline at end of file + (:file "beirc" :depends-on ("package")) + (:file "message-display" :depends-on ("package" "beirc")))) \ No newline at end of file Index: beirc/beirc.lisp diff -u beirc/beirc.lisp:1.7 beirc/beirc.lisp:1.8 --- beirc/beirc.lisp:1.7 Sat Sep 17 18:51:21 2005 +++ beirc/beirc.lisp Sat Sep 17 21:23:14 2005 @@ -277,91 +277,6 @@ ;; "~:@>") ;; prefix))) -(defun present-url (url) - (let ((start (search "http://www.lispworks.com/reference/HyperSpec/" url))) - (cond (start - (write-string (subseq url 0 start)) - (present (concatenate 'string - "file://localhost/Users/dmurray/lisp/HyperSpec/" - (subseq url (+ 45 start))) - 'url)) - (t (present url 'url))))) - -(defun format-message* (preamble mumble - &key (prefix " ") - (limit 100)) - (loop for word in (split-sequence:split-sequence #\Space mumble) - with line-prefix = prefix - with column = (+ (length line-prefix) (length preamble)) - with column-limit = limit - initially (with-drawing-options (*standard-output* :ink +dark-red+) - (write-string preamble)) - when (> (+ column (length word)) column-limit) - do (terpri) - (write-string line-prefix) - (setf column (length line-prefix)) - else do (write-char #\Space) - (incf column) - do - (if (search "http://" word) - (present-url word) - (write-string word)) - (incf column (length word))) - (terpri)) - -(define-presentation-type url () - :inherit-from 'string) - -(defmethod print-message ((message irc:IRC-PRIVMSG-MESSAGE) receiver) - (with-drawing-options - (*standard-output* - :ink (if (string-equal "localhost" (irc:host message)) - +blue4+ - +black+)) - (unless (member (irc:source message) (slot-value *application-frame* 'ignored-nicks) - :test #'string=) - (with-text-face - (*standard-output* - (if (member (irc:source message) (current-focused-nicks) - :test #'string=) - :bold - :roman)) - (format t "~&[~2,'0D:~2,'0D] " - (nth-value 2 (decode-universal-time (irc:received-time message))) - (nth-value 1 (decode-universal-time (irc:received-time message)))) - (let ((preamble - (cond ((string-equal "localhost" (irc:host message)) - (if (char= (char (first (irc:arguments message)) 0) #\#) - (format nil ">") - (format nil "-> *~A*" (first (irc:arguments message))))) - (t - (if (char= (char (first (irc:arguments message)) 0) #\#) - (format nil "<~A>" (irc:source message)) - (format nil "*~A*" (irc:source message))))))) - (format-message* preamble (irc:trailing-argument message))))))) - -(defmethod print-message ((message irc:ctcp-action-message) receiver) - (let ((source (cl-irc:source message)) - (matter (trailing-argument* message)) - (dest (car (cl-irc:arguments message)))) - (format-message* (format nil " *~A ~A" - (if (char= (char (first (irc:arguments message)) 0) #\#) "" ">") - source) - matter))) - -(defmethod print-message ((message irc:irc-quit-message) receiver) - (with-drawing-options (*standard-output* :ink +gray33+ :text-size :small) - (format-message* (format nil "~10T Quit: ~A;" - (irc:source message)) - (irc:trailing-argument message)))) - -(defmethod print-message ((message irc:irc-join-message) receiver) - (with-drawing-options (*standard-output* :ink +gray33+ :text-size :small) - (format *standard-output* "~10T Join: ~A (~A@~A)" - (irc:source message) - (irc:user message) - (irc:host message)) - (terpri) )) ;;; Here comes the trick: @@ -466,6 +381,17 @@ (completing-from-suggestions (*standard-input* :partial-completers '(#\Space)) (maphash #'suggest (receivers *application-frame*)))) +(defun nick-equals-my-nick-p (nickname) + (and *application-frame* + (string= nickname (slot-value *application-frame* 'nick)))) + +(define-presentation-method present (o (type nickname) *standard-output* (view textual-view) &key) + (if (nick-equals-my-nick-p o) + (with-drawing-options (t :ink +green+) + (with-text-face (t :bold) + (format t "~A" o))) + (format t "~A" o))) + (define-presentation-method present (o (type receiver) *standard-output* (view textual-view) &key) (with-drawing-options (t :ink (cond ((> (messages-directed-to-me o) 0) +green+) ((> (unseen-messages o) 0) +red+) @@ -613,6 +539,10 @@ (progn (irc:add-hook connection 'irc:irc-privmsg-message (lambda (m) (post-message frame m))) + (irc:add-hook connection 'irc:irc-nick-message + (lambda (m) (post-message frame m))) + (irc:add-hook connection 'irc:irc-part-message + (lambda (m) (post-message frame m))) (irc:add-hook connection 'irc:irc-quit-message (lambda (m) (post-message frame m))) (irc:add-hook connection 'irc:irc-join-message @@ -624,35 +554,6 @@ (irc:read-message-loop connection) ) (irc:remove-all-hooks connection))) -(defun beirc-app-display (*application-frame* *standard-output* receiver) - ;; Fix me: This usage of UPDATING-OUTPUT is sub-optimal and ugly! - ;; Fix me: as is all that *standard-output* stuff - (let ((w (- (floor (bounding-rectangle-width (sheet-parent *standard-output*)) - (clim:stream-string-width *standard-output* "X")) - 2)) - (messages (and receiver (messages receiver)))) - (let ((k 100) - (n (length messages))) - (loop for i below (* k (ceiling n k)) by k do - (updating-output (*standard-output* - :unique-id i - :cache-value - (list (min n (+ i k)) - (focused-nicks receiver) - (slot-value *application-frame* 'ignored-nicks) - w) - :cache-test #'equal) - (loop for j from i below (min n (+ i k)) do - (let ((m (elt messages j))) - (updating-output (*standard-output* - :unique-id j - :cache-value - (list m - (focused-nicks receiver) - (slot-value *application-frame* 'ignored-nicks) - w) - :cache-test #'equal) - (print-message m receiver))))))))) ;;; Hack: (defmethod allocate-space :after ((pane climi::viewport-pane) w h)