[beirc-cvs] CVS beirc

[afuchs]

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)))