[beirc-cvs] CVS beirc
afuchs
afuchs at common-lisp.net
Mon Mar 27 13:46:47 UTC 2006
Update of /project/beirc/cvsroot/beirc
In directory clnet:/tmp/cvs-serv15257
Modified Files:
application.lisp message-display.lisp message-processing.lisp
variables.lisp
Log Message:
Fix ignore. Make timestamps mouse-sensitive. Fix updating-output.
* Ignore and unignore would remove the messages, but not set the
scroll state. Make them use the new
with-pane-kept-scrolled-to-bottom macro.
* Timestamps are now pointers to meme.b9.com on channels that have a
user "cmeme" on them. The nickname of the log bot is configurable
via *meme-log-bot-nick*.
* Updating-output's new SXHASH function would ignore the non-booleans
on the list. Ugh.
--- /project/beirc/cvsroot/beirc/application.lisp 2006/03/24 21:19:43 1.69
+++ /project/beirc/cvsroot/beirc/application.lisp 2006/03/27 13:46:47 1.70
@@ -254,21 +254,35 @@
(defmethod handle-event ((frame beirc) (event new-sheet-event))
(funcall (sheet-creation-closure event) frame))
+(defmacro with-pane-kept-scrolled-to-bottom ((pane-form) &body body)
+ "Ensure that the pane in PANE-FORM has the same scroll state
+after BODY terminates as it had before:
+
+If the pane is scrolled to some position before the end, it is
+kept there. If the pane is at the bottom of the pane, the
+viewport is reset to the then-current bottom after BODY is
+finished."
+ (let ((pane (gensym))
+ (bottom-p (gensym)))
+ `(let* ((,pane ,pane-form)
+ (,bottom-p (pane-scrolled-to-bottom-p ,pane)))
+ (multiple-value-prog1 (progn , at body)
+ (when ,bottom-p (scroll-pane-to-bottom ,pane))))))
+
(defmethod handle-event ((frame beirc) (event foo-event))
;; Hack:
;; Figure out if we are scrolled to the bottom.
(let* ((receiver (receiver event))
(pane (actual-application-pane (pane receiver)))
(next-event (event-peek (frame-top-level-sheet frame))))
- (let ((btmp (pane-scrolled-to-bottom-p pane)))
+ (with-pane-kept-scrolled-to-bottom (pane)
(update-drawing-options receiver)
;; delay redisplay until this is the last event in the queue
;; (for this event's receiver).
(unless (and (typep next-event 'foo-event)
(eql (receiver next-event) receiver))
(setf (pane-needs-redisplay pane) t)
- (redisplay-frame-panes frame))
- (when btmp (scroll-pane-to-bottom pane)))
+ (redisplay-frame-panes frame)))
(medium-force-output (sheet-medium pane)) ;###
))
@@ -496,13 +510,17 @@
(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=)
- (redraw-all-receivers))
+ (with-pane-kept-scrolled-to-bottom ((actual-application-pane
+ (pane (current-receiver *application-frame*))))
+ (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=))
- (redraw-all-receivers))
+ (with-pane-kept-scrolled-to-bottom ((actual-application-pane
+ (pane (current-receiver *application-frame*))))
+ (setf (slot-value *application-frame* 'ignored-nicks)
+ (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)
@@ -950,7 +968,7 @@
x y)
(declare (ignore object options))
(when (and ptype (presentation-subtypep ptype 'command)
- (boundp '*current-input-stream*) *current-input-stream*)
+ (boundp 'climi::*current-input-stream*) climi::*current-input-stream*)
(restart-case (signal 'invoked-command-by-clicking)
(acknowledged ()))))))))
(call-next-method))
--- /project/beirc/cvsroot/beirc/message-display.lisp 2006/03/24 21:07:20 1.40
+++ /project/beirc/cvsroot/beirc/message-display.lisp 2006/03/27 13:46:47 1.41
@@ -38,28 +38,48 @@
(member (irc:source message) (slot-value *application-frame* 'ignored-nicks)
:test #'string=))
+(defun +boolean (initial-value &rest booleans)
+ (loop for value = initial-value then (+ (ash value 1)
+ (if boolean 1 0))
+ for boolean in booleans
+ finally (return value)))
+
(defun invoke-formatting-message (stream message receiver preamble-writer message-body-writer)
(let* ((*current-message* message)
(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)
+ (labels ((make-meme-url (message)
+ (format nil "http://meme.b9.com/cview.html?channel=~A&utime=~A#utime_requested"
+ (string-trim '(#\#) (channel receiver))
+ (irc:received-time message)))
+ (format-timestamp (message)
+ (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)))))
+ (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)))))))))
+ (if (and *meme-log-bot-nick*
+ (irc:find-user (connection receiver) *meme-log-bot-nick*)
+ (member (title receiver)
+ (irc:channels (irc:find-user (connection receiver) *meme-log-bot-nick*))
+ :test #'equal
+ :key #'irc:name))
+ (with-output-as-presentation (stream* (make-meme-url message) 'url)
+ (format-timestamp message))
+ (format-timestamp message)))))))
(updating-output (stream*
:cache-value
- (sxhash (list message
- (message-from-focused-nick-p message receiver)
- (message-from-ignored-nick-p message receiver)
- width
- *max-preamble-length*
- *timestamp-column-orientation*
- *default-fill-column*))
+ (+boolean (sxhash (list message
+ width
+ *max-preamble-length*
+ *default-fill-column*))
+ (message-from-focused-nick-p message receiver)
+ (message-from-ignored-nick-p message receiver)
+ (eql *timestamp-column-orientation* :left))
:cache-test #'eql)
(formatting-row (stream*)
(output-timestamp-column :left)
--- /project/beirc/cvsroot/beirc/message-processing.lisp 2006/03/16 20:32:05 1.5
+++ /project/beirc/cvsroot/beirc/message-processing.lisp 2006/03/27 13:46:47 1.6
@@ -69,8 +69,13 @@
(typep message 'irc:irc-rpl_noaway-message)))
(define-beirc-hook autojoin-hoook ((message cl-irc:irc-rpl_welcome-message))
- "When you establish a connection, check the list of channels for autojoin
+ "When a connection is established, check the list of channels for autojoin
and set them up accordingly."
(declare (ignore message))
(join-missing-channels *application-frame*))
+(define-beirc-hook meme-whois-hook ((message irc:irc-rpl_welcome-message))
+ "When a connection is established, look up the channels on
+which the meme log bot is listening."
+ (when (not (null *meme-log-bot-nick*))
+ (irc:whois (irc:connection message) *meme-log-bot-nick*)))
\ No newline at end of file
--- /project/beirc/cvsroot/beirc/variables.lisp 2006/03/24 21:19:44 1.12
+++ /project/beirc/cvsroot/beirc/variables.lisp 2006/03/27 13:46:47 1.13
@@ -47,3 +47,6 @@
the command /Close Inactive Queries and the automatic query
window closing mechanism (see
*auto-close-inactive-query-windows-p*).")
+
+(defvar *meme-log-bot-nick* "cmeme"
+ "The name of the meme channel log bot")
\ No newline at end of file
More information about the Beirc-cvs
mailing list