[beirc-cvs] CVS update: beirc/message-display.lisp beirc/beirc.lisp
Dave Murray
dmurray at common-lisp.net
Fri Sep 23 09:52:42 UTC 2005
Update of /project/beirc/cvsroot/beirc
In directory common-lisp.net:/tmp/cvs-serv9434
Modified Files:
message-display.lisp beirc.lisp
Log Message:
Switched time-stamps to right-hand column. Better wrapping of message column.
Date: Fri Sep 23 11:52:41 2005
Author: dmurray
Index: beirc/message-display.lisp
diff -u beirc/message-display.lisp:1.3 beirc/message-display.lisp:1.4
--- beirc/message-display.lisp:1.3 Sun Sep 18 00:34:00 2005
+++ beirc/message-display.lisp Fri Sep 23 11:52:40 2005
@@ -1,7 +1,7 @@
(in-package :beirc)
(defparameter *hyperspec-base-url* "file://localhost/Users/dmurray/lisp/HyperSpec/")
-(defparameter *default-fill-column* 100)
+(defparameter *default-fill-column* 80)
(defvar *max-preamble-length* 0)
@@ -16,6 +16,15 @@
*hyperspec-base-url*
(subseq url (+ 45 start)))
'url))
+ ((> (length url) *default-fill-column*)
+ (let ((new-url
+ (concatenate 'string
+ (subseq url 0 (floor *default-fill-column* 2))
+ "..."
+ (subseq url (- (length url)
+ (- (floor *default-fill-column* 2) 3))))))
+ (with-output-as-presentation (t url 'url)
+ (write-string new-url))))
(t (present url 'url)))))
(defun message-from-focused-nick-p (message receiver)
@@ -47,48 +56,49 @@
*max-preamble-length*)
:cache-test #'equal)
(formatting-row (,stream*)
- (formatting-cell (,stream* :align-x :left)
- (format ,stream* "~&[~2,'0D:~2,'0D] "
- (nth-value 2 (decode-universal-time (irc:received-time message)))
- (nth-value 1 (decode-universal-time (irc:received-time message)))))
- (formatting-cell (,stream* :align-x :right)
- (with-drawing-options (*standard-output* :ink +dark-red+)
+ (formatting-cell (,stream* :align-x :right :min-width '(16 :character))
+ (with-drawing-options (,stream* :ink +dark-red+)
, at preamble-column-body))
- (formatting-cell (,stream* :align-x :left)
- , at message-body-column-body))))))
+ (formatting-cell (,stream* :align-x :left
+ :min-width '(80 :character))
+ , at message-body-column-body)
+ (formatting-cell (,stream* :align-x :left)
+ (with-drawing-options (,stream* :ink +gray+)
+ (format ,stream* "[~2,'0D:~2,'0D]"
+ (nth-value 2 (decode-universal-time (irc:received-time message)))
+ (nth-value 1 (decode-universal-time (irc:received-time message)))))))))))
(defun strip-punctuation (word)
(if (= (length word) 0)
(values word "")
(let ((last-char (char word (1- (length word)))))
(case last-char
- ((#\: #\, #\. #\;)
+ ((#\: #\, #\. #\; #\) #\] #\} #\> #\? #\! #\" #\')
(values (subseq word 0 (1- (length word)))
(string last-char)))
(otherwise (values word ""))))))
-(defun format-message* (mumble &key (limit *default-fill-column*))
+(defun format-message* (mumble &key (limit *default-fill-column*) (start-length 0))
(loop for (word . rest) on (split-sequence:split-sequence #\Space mumble)
- with column = 0
- with column-limit = limit
- do (multiple-value-bind (word* stripped-punctuation) (strip-punctuation word)
- (cond
- ((search "http://" word*)
- (present-url word*))
- ((or
- (nick-equals-my-nick-p word*)
- (irc:find-user (current-connection *application-frame*) word*))
- (present word* 'nickname))
- (t (write-string word*)))
- (write-string stripped-punctuation))
- ;; TODO: nick highlighting via presentations
- (incf column (length word))
- when (> column column-limit)
- do (setf column 0)
- (terpri)
- else unless (null rest)
- do (write-char #\Space)
- (incf column))
+ with column = start-length
+ do (incf column (length word))
+ when (> column limit)
+ do (setf column (length word))
+ (terpri)
+ do (multiple-value-bind (word* stripped-punctuation) (strip-punctuation word)
+ (cond
+ ((search "http://" word*)
+ (present-url word*))
+ ((or
+ (nick-equals-my-nick-p word*)
+ (irc:find-user (current-connection *application-frame*) word*))
+ (present word* 'nickname))
+ (t (write-string word*)))
+ (write-string stripped-punctuation))
+ ;; TODO: more highlighting
+ unless (or (null rest) (>= column limit))
+ do (write-char #\Space)
+ (incf column))
(terpri))
(defmethod print-message ((message irc:IRC-PRIVMSG-MESSAGE) receiver)
@@ -114,20 +124,21 @@
((format t "*"))
((present source 'nickname)
(format t " ")
- (format-message* matter)))))
+ (format-message* matter :start-length (+ 2 (length source)))))))
(defmethod print-message ((message irc:irc-quit-message) receiver)
(formatting-message (t message receiver)
- ((format t "***"))
+ ((format t " "))
((with-drawing-options (*standard-output* :ink +gray33+ :text-size :small)
(format t "Quit: ")
(present (irc:source message) 'nickname)
(format t ": ")
- (format-message* (irc:trailing-argument message))))))
+ (format-message* (irc:trailing-argument message)
+ :start-length (+ 8 (length (irc:source message))))))))
(defmethod print-message ((message irc:irc-join-message) receiver)
(formatting-message (t message receiver)
- ((format t "***"))
+ ((format t " "))
((with-drawing-options (*standard-output* :ink +gray33+ :text-size :small)
(format t "Join: ")
(present (irc:source message) 'nickname)
@@ -135,7 +146,7 @@
(defmethod print-message ((message irc:irc-nick-message) receiver)
(formatting-message (t message receiver)
- ((format t "***"))
+ ((format t " "))
((with-drawing-options (*standard-output* :ink +gray33+ :text-size :small)
(format t "Nick change: ")
(present (irc:source message) 'nickname)
@@ -144,7 +155,7 @@
(defmethod print-message ((message irc:irc-part-message) receiver)
(formatting-message (t message receiver)
- ((format t "***"))
+ ((format t " "))
((with-drawing-options (*standard-output* :ink +gray33+ :text-size :small)
(format t "Part: ")
(present (irc:source message) 'nickname)
Index: beirc/beirc.lisp
diff -u beirc/beirc.lisp:1.12 beirc/beirc.lisp:1.13
--- beirc/beirc.lisp:1.12 Sun Sep 18 00:34:00 2005
+++ beirc/beirc.lisp Fri Sep 23 11:52:40 2005
@@ -407,7 +407,7 @@
(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-drawing-options (t :ink +darkgreen+)
(with-text-face (t :bold)
(format t "~A" o)))
(format t "~A" o)))
More information about the Beirc-cvs
mailing list