[beirc-cvs] CVS update: beirc/message-display.lisp beirc/beirc.asd beirc/beirc.lisp
Andreas Fuchs
afuchs at common-lisp.net
Sat Sep 17 19:23:16 UTC 2005
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)
More information about the Beirc-cvs
mailing list