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