[beirc-cvs] CVS update: beirc/application.lisp

[Max-Gerd Retzlaff]

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

Modified Files:
	application.lisp 
Log Message:
Beirc's prompt is changed: After the the word "Beirc" now the
current receiver's title is shown, and it will be presented as
the current receiver (with the presentation-type RECEIVER).

The presentation-translator RECEIVER-TO-CHANNEL-TRANSLATOR is added
(with :tester and :documentation).

A :tester is added to RECEIVER-PANE-TO-CHANNEL-TRANSLATOR. (Sadly,
CLIM's presentation-translators seem not to be transitive, otherwise
we could get rid of this presentation-translator.)

Date: Wed Oct  5 05:39:14 2005
Author: mretzlaff

Index: beirc/application.lisp
diff -u beirc/application.lisp:1.30 beirc/application.lisp:1.31
--- beirc/application.lisp:1.30	Mon Oct  3 01:47:51 2005
+++ beirc/application.lisp	Wed Oct  5 05:39:14 2005
@@ -136,9 +136,13 @@
               (length (current-messages))))))
 
 (defun beirc-prompt (*standard-output* *application-frame*)
-  (format *standard-output* "Beirc ~A => "
-          (or (current-query)
-              (current-channel))))
+  (write-string "Beirc" *standard-output*)
+  (let ((receiver (current-receiver *application-frame*)))
+    (when receiver
+      (write-string " " *standard-output*)
+      (with-output-as-presentation (*standard-output* receiver 'receiver)
+        (write-string (title receiver) *standard-output*))))
+  (write-string " => " *standard-output*))
 
 ;; (defun format-message (prefix mumble)
 ;;   (write-line
@@ -599,10 +603,23 @@
        :documentation ((object stream)
                        (format stream "Channel: ~A"
                                (channel (receiver-from-tab-pane
-                                         (find-in-tab-panes-list object 'tab-layout-pane))))))
+                                         (find-in-tab-panes-list object 'tab-layout-pane)))))
+       :tester ((object)
+                (channel (receiver-from-tab-pane
+                          (find-in-tab-panes-list object 'tab-layout-pane)))))
     (object)
   (channel (receiver-from-tab-pane
             (find-in-tab-panes-list object 'tab-layout-pane))))
+
+(define-presentation-translator receiver-to-channel-translator
+    (receiver channel beirc
+       :documentation ((object stream)
+                       (format stream "Channel: ~A"
+                               (channel object)))
+       :tester ((object)
+                (channel object)))
+    (object)
+  (channel object))
 
 (define-presentation-translator nickname-to-hostmask-translator
     (nickname hostmask beirc