Update of /project/beirc/cvsroot/beirc In directory common-lisp.net:/tmp/cvs-serv32347

Modified Files: beirc.lisp message-display.lisp Log Message: add a customizable variable for timestamp orientation, and fix redisplay on focus/ignore/etc. command

* new variable *timestamp-column-orientation* (this is for you, mgr) * new command /Switch Timestamp Orientation * /S-T-O, /{,un}ignore, /{,un}focus now redraw the panes they affect. * comment out the nickname to hostmask ptype translator. for some reason it was always activated.

Date: Sun Sep 25 00:30:25 2005 Author: afuchs

Index: beirc/beirc.lisp diff -u beirc/beirc.lisp:1.28 beirc/beirc.lisp:1.29 --- beirc/beirc.lisp:1.28 Sat Sep 24 21:13:54 2005 +++ beirc/beirc.lisp Sun Sep 25 00:30:23 2005 @@ -389,6 +389,17 @@ (scroll-extent pane 0 (max 0 (- (bounding-rectangle-height pane) (bounding-rectangle-height (sheet-parent pane))))))

+(defun redraw-receiver (receiver) + (let ((pane (actual-application-pane (pane receiver)))) + (setf (pane-needs-redisplay pane) t) + (redisplay-frame-pane *application-frame* pane))) + +(defun redraw-all-receivers () + (maphash (lambda (name receiver) + (declare (ignore name)) + (redraw-receiver receiver)) + (receivers *application-frame*))) + (defmethod handle-event ((frame beirc) (event foo-event)) ;; Hack: ;; Figure out if we are scrolled to the bottom. @@ -478,6 +489,8 @@ (receiver-from-tab-pane (find-in-tab-panes-list object 'tab-layout-pane)))

+;;; XXX: for some reason, this translator is activated when accepting NICKNAME. +#+(or) (define-presentation-translator nickname-to-hostmask-translator (nickname hostmask beirc) (object) @@ -533,18 +546,22 @@ (title (current-receiver *application-frame*))))

(define-beirc-command (com-focus :name t) ((who 'nickname :prompt "who")) - (pushnew who (current-focused-nicks) :test #'string=)) + (pushnew who (current-focused-nicks) :test #'string=) + (redraw-receiver (current-receiver *application-frame*)))

(define-beirc-command (com-ignore :name t) ((who 'nickname :prompt "who")) - (pushnew who (slot-value *application-frame* 'ignored-nicks) :test #'string=)) + (pushnew who (slot-value *application-frame* 'ignored-nicks) :test #'string=) + (redraw-all-receivers))

(define-beirc-command (com-unignore :name t) ((who 'ignored-nickname :prompt "who")) (setf (slot-value *application-frame* 'ignored-nicks) - (remove who (slot-value *application-frame* 'ignored-nicks) :test #'string=))) + (remove who (slot-value *application-frame* 'ignored-nicks) :test #'string=)) + (redraw-all-receivers))

(define-beirc-command (com-unfocus :name t) ((who 'nickname :prompt "who")) (setf (current-focused-nicks) - (remove who (current-focused-nicks) :test #'string=))) + (remove who (current-focused-nicks) :test #'string=)) + (redraw-receiver (current-receiver *application-frame*)))

(define-beirc-command (com-eval :name t) ((command 'string :prompt "command") (args '(sequence string) :prompt "arguments")) @@ -604,6 +621,12 @@ (when (current-connection *application-frame*) (quit *application-frame* reason)))

+(define-beirc-command (com-switch-timestamp-orientation :name t) () + (setf *timestamp-column-orientation* (if (eql *timestamp-column-orientation* :left) + :right + :left)) + (redraw-all-receivers)) + (defun target (&optional (*application-frame* *application-frame*)) (or (current-query) (current-channel))) @@ -714,7 +737,7 @@ (clim-sys:make-process #'(lambda () (unwind-protect (irc-event-loop frame connection) - (quit frame "IRC event loop terminated."))) + (disconnect frame))) :name "IRC Message Muffling Loop")))))))

(defun disconnect (frame)

Index: beirc/message-display.lisp diff -u beirc/message-display.lisp:1.12 beirc/message-display.lisp:1.13 --- beirc/message-display.lisp:1.12 Sat Sep 24 21:03:15 2005 +++ beirc/message-display.lisp Sun Sep 25 00:30:24 2005 @@ -2,6 +2,7 @@

(defparameter *hyperspec-base-url* "file://localhost/Users/dmurray/lisp/HyperSpec/") (defparameter *default-fill-column* 80) +(defparameter *timestamp-column-orientation* :right)

(defvar *max-preamble-length* 0)

@@ -34,39 +35,47 @@ (member (irc:source message) (slot-value *application-frame* 'ignored-nicks) :test #'string=))

+(defun invoke-formatting-message (stream message receiver preamble-writer message-body-writer) + (let* ((stream* (if (eql stream t) *standard-output* stream)) + (width (- (floor (bounding-rectangle-width (sheet-parent stream*)) + (clim:stream-string-width stream* "X")) + 2))) + (labels ((output-timestamp-column (position) + (when (eql position *timestamp-column-orientation*) + (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))))))))) + (updating-output (stream* + :cache-value + (list message + (focused-nicks receiver) + (slot-value *application-frame* 'ignored-nicks) + width + *max-preamble-length* + *timestamp-column-orientation*) + :cache-test #'equal) + (formatting-row (stream*) + (output-timestamp-column :left) + (formatting-cell (stream* :align-x :right :min-width '(16 :character)) + (with-drawing-options (stream* :ink +dark-red+) + (funcall preamble-writer))) + (formatting-cell (stream* :align-x :left + :min-width '(80 :character)) + (funcall message-body-writer)) + (output-timestamp-column :right)))))) + (defmacro formatting-message ((stream message receiver) (&body preamble-column-body) (&body message-body-column-body)) ;; Fix me: This usage of UPDATING-OUTPUT is sub-optimal and ugly! ;; (asf 2005-09-17: is it still?) - (let ((width (gensym)) - (%stream% (gensym)) - (stream* (gensym))) - `(let* ((,%stream% ,stream) - (,stream* (if (eql ,%stream% t) *standard-output* ,%stream%)) - (,width (- (floor (bounding-rectangle-width (sheet-parent ,stream*)) - (clim:stream-string-width ,stream* "X")) - 2))) - (updating-output (,stream* - :cache-value - (list ,message - (focused-nicks ,receiver) - (slot-value *application-frame* 'ignored-nicks) - ,width - *max-preamble-length*) - :cache-test #'equal) - (formatting-row (,stream*) - (formatting-cell (,stream* :align-x :right :min-width '(16 :character)) - (with-drawing-options (,stream* :ink +dark-red+) - ,@preamble-column-body)) - (formatting-cell (,stream* :align-x :left - :min-width '(80 :character)) - ,@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))))))))))) + `(invoke-formatting-message ,stream ,message ,receiver + (lambda () + ,@preamble-column-body) + (lambda () + ,@message-body-column-body)))

(defun strip-punctuation (word) (if (= (length word) 0)