[beirc-cvs] CVS update: beirc/beirc.lisp beirc/message-display.lisp
Andreas Fuchs
afuchs at common-lisp.net
Sat Sep 24 22:30:27 UTC 2005
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+)
- , at preamble-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)))))))))))
+ `(invoke-formatting-message ,stream ,message ,receiver
+ (lambda ()
+ , at preamble-column-body)
+ (lambda ()
+ , at message-body-column-body)))
(defun strip-punctuation (word)
(if (= (length word) 0)
More information about the Beirc-cvs
mailing list