Update of /project/beirc/cvsroot/beirc In directory clnet:/tmp/cvs-serv17189
Modified Files: application.lisp receivers.lisp Log Message: Add /{Previous,Next} Highlighted Message commands
* commands are bound to shift-prior and shift-next respectively. * also fix the nick->hostmask translator to generate hostmask only when the user has a known hostname, otherwise generate a nickname mask
--- /project/beirc/cvsroot/beirc/application.lisp 2006/03/12 09:48:57 1.53 +++ /project/beirc/cvsroot/beirc/application.lisp 2006/03/16 00:01:46 1.54 @@ -294,6 +294,14 @@ (when (message-directed-to-me-p message) (incf (messages-directed-to-me receiver))) (incf (all-unseen-messages receiver))) + (when (and (slot-boundp receiver 'pane) (pane receiver)) + (let* ((pane (actual-application-pane (pane receiver))) + (current-insert-position (bounding-rectangle-height pane))) + (when (and (not (eql current-insert-position + (first (positions-mentioning-user receiver)))) + (message-directed-to-me-p message)) + (push current-insert-position + (positions-mentioning-user receiver))))) (queue-event (frame-top-level-sheet frame) (make-instance 'foo-event :sheet frame :receiver receiver)) nil) @@ -392,6 +400,30 @@ (irc:part connection channel)))) (remove-receiver receiver *application-frame*))
+(macrolet ((define-highlighted-message-jumper (com-name keystroke next-pos-form fallback-position) + `(define-beirc-command (,com-name :name t :keystroke ,keystroke) () + (let* ((pane (actual-application-pane (pane (current-receiver *application-frame*)))) + (next-y-position ,next-pos-form) + (bottom (max 0 (- (bounding-rectangle-height pane) + (bounding-rectangle-height (sheet-parent pane))))) + (top 0)) + (scroll-extent pane 0 (if next-y-position + (min next-y-position bottom) + (progn + (beep) + (funcall ,fallback-position bottom top)))))))) + (define-highlighted-message-jumper com-previous-highlighted-message (:prior :shift) + (find-if (lambda (position) + (< position (bounding-rectangle-min-y (pane-viewport-region pane)))) + (positions-mentioning-user (current-receiver *application-frame*))) + (lambda (bottom top) (declare (ignore bottom)) top)) + (define-highlighted-message-jumper com-next-highlighted-message (:next :shift) + (loop for (this prev . rest) on (positions-mentioning-user (current-receiver *application-frame*)) + until (null prev) + if (<= prev (bounding-rectangle-min-y (pane-viewport-region pane)) this) + do (return this)) + (lambda (bottom top) (declare (ignore top)) bottom))) + (define-beirc-command (com-remove-inactive-queries :name t) () (let ((receivers-to-close nil)) (maphash (lambda (name receiver) @@ -734,7 +766,10 @@ (declare (ignore object)) (presentation-subtypep context-type 'hostmask))) (object) - (format nil "*!*@~A" (irc:hostname (irc:find-user (current-connection *application-frame*) object)))) + (let ((hostname (irc:hostname (irc:find-user (current-connection *application-frame*) object)))) + (if (zerop (length hostname)) + (format nil "~A!*@*" object) + (format nil "*!*@~A" hostname))))
(define-beirc-command (com-join :name t) ((channel 'channel :prompt "channel")) (raise-receiver (intern-receiver channel (current-connection *application-frame*) --- /project/beirc/cvsroot/beirc/receivers.lisp 2006/03/12 09:48:57 1.22 +++ /project/beirc/cvsroot/beirc/receivers.lisp 2006/03/16 00:01:46 1.23 @@ -14,6 +14,7 @@ (title :reader title :initarg :title) (last-visited :accessor last-visited :initform 0) (incomplete-input :accessor incomplete-input :initform "") + (positions-mentioning-user :accessor positions-mentioning-user :initform nil) (pane :reader pane) (tab-pane :accessor tab-pane)))