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

[Andreas Fuchs]

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

Modified Files:
	beirc.lisp 
Log Message:
Make server buffer display messages & delete previous KLUDGE.

* Also, try and dtrt on /quit.

Date: Sat Sep 24 00:06:00 2005
Author: afuchs

Index: beirc/beirc.lisp
diff -u beirc/beirc.lisp:1.15 beirc/beirc.lisp:1.16
--- beirc/beirc.lisp:1.15	Fri Sep 23 23:31:27 2005
+++ beirc/beirc.lisp	Sat Sep 24 00:05:54 2005
@@ -80,24 +80,6 @@
             for found-pane = (actual-application-pane child)
             if found-pane do (return found-pane))))
 
-;;; another KLUDGE: define-application-frame-defined panes (as
-;;; find-pane-named returns them) /don't/ come wrapped - they are
-;;; stored as the application pane itself. Of course, tab-layout
-;;; /expects/ them wrapped, so we recurse through the parents to find
-;;; the granddaughter of a tab-layout-pane.
-(defun direct-tab-pane-child-from (pane)
-  "Given a pane, find the parent pane that is the direct child of
-a tab-layout-pane's radio-layout-pane."
-  (labels ((has-parent-p (pane) (and (typep pane 'clim:sheet-parent-mixin)
-                                     (not (null (sheet-parent pane)))))
-           (grandparent (pane)
-             (if (and (has-parent-p pane) (has-parent-p (sheet-parent pane)))
-                 (sheet-parent (sheet-parent pane)))))
-    (cond
-      ((typep (grandparent pane) 'tab-layout-pane) pane)
-      ((has-parent-p pane) (direct-tab-pane-child-from (sheet-parent pane)))
-      (t nil))))
-
 (defun make-paneless-receiver (name &rest initargs)
   (apply 'make-instance 'receiver :title name initargs))
 
@@ -105,7 +87,7 @@
   (setf (slot-value receiver 'pane) pane)
   (if (not add-pane-p)
       (setf (slot-value receiver 'tab-pane)
-            (find-in-tab-panes-list (direct-tab-pane-child-from pane)
+            (find-in-tab-panes-list pane
                                     'tab-layout-pane))
       (progn
         (setf (slot-value receiver 'tab-pane)
@@ -184,7 +166,7 @@
   (define-delegate current-focused-nicks focused-nicks t))
 
 (defun update-drawing-options (receiver)
-  (set-drawing-options-for-pane-in-tab-layout (direct-tab-pane-child-from (pane receiver))
+  (set-drawing-options-for-pane-in-tab-layout (pane receiver)
                                               `(:ink ,(cond ((> (messages-directed-to-me receiver) 0) +green+)
                                                             ((> (unseen-messages receiver) 0) +red+)
                                                             (t +black+)))))
@@ -202,7 +184,7 @@
 (defun raise-receiver (receiver)
   (setf (unseen-messages receiver) 0)
   (setf (messages-directed-to-me receiver) 0)
-  (switch-to-pane (direct-tab-pane-child-from (pane receiver)) 'tab-layout-pane))
+  (switch-to-pane (pane receiver) 'tab-layout-pane))
 
 ;;; KLUDGE: workaround for mcclim bug "Application pane vertical
 ;;; scrolling does not work with table formatting"
@@ -238,13 +220,13 @@
     :background +black+
     :foreground +white+)
    (server
-    :application
-    :display (lambda (frame pane)
-               (beirc-app-display frame pane (server-receiver *application-frame*)))
-    :display-time :command-loop
-    :width 400
-    :height 600
-    :incremental-redisplay t))
+    (make-clim-application-pane
+     :display-function
+     (lambda (frame pane)
+       (beirc-app-display frame pane (server-receiver *application-frame*)))
+     :display-time nil
+     :width 400 :height 600
+     :incremental-redisplay t)))
   (:geometry :width 800 :height 600)
   (:top-level (clim:default-frame-top-level :prompt 'beirc-prompt))
   (:layouts
@@ -448,7 +430,7 @@
   (setf (current-focused-nicks)
         (remove who (current-focused-nicks) :test #'string=)))
 
-(define-beirc-command (com-quit :name t) ((reason 'string :prompt "reason"))
+(define-beirc-command (com-quit :name t) ((reason 'mumble :prompt "reason"))
   (irc:quit (current-connection *application-frame*) reason))
 
 (defun target (&optional (*application-frame* *application-frame*))