[beirc-cvs] CVS beirc
dlichteblau
dlichteblau at common-lisp.net
Sat Feb 24 10:58:16 UTC 2007
Update of /project/beirc/cvsroot/beirc
In directory clnet:/tmp/cvs-serv1658
Modified Files:
application.lisp beirc.asd message-display.lisp package.lisp
receivers.lisp
Log Message:
use McCLIM's built-in tab layout
--- /project/beirc/cvsroot/beirc/application.lisp 2006/05/31 19:35:39 1.84
+++ /project/beirc/cvsroot/beirc/application.lisp 2007/02/24 10:58:16 1.85
@@ -79,7 +79,7 @@
(ignored-nicks :initform nil)
(receivers :initform (make-hash-table :test #'equal) :accessor receivers)
(server-receivers :initform nil :reader server-receivers)
- (tab-panes-to-receivers :initform (make-hash-table :test #'equal) :accessor tab-panes-to-receivers)
+ (tab-pages-to-receivers :initform (make-hash-table :test #'equal) :accessor tab-pages-to-receivers)
(presence :initform (make-hash-table :test #'equal) :reader presence))
(:panes
(io
@@ -115,7 +115,7 @@
(default
(vertically ()
(with-tab-layout ('receiver-pane :name 'query)
- ("*Not Connected*" server 'receiver-pane))
+ ("*Not Connected*" server :presentation-type 'receiver-pane))
(make-pane 'clim-extensions:box-adjuster-gadget)
io
(20 pointer-doc)
@@ -123,8 +123,8 @@
status-bar)))))
;;; addition of optional argument allows debugging from outside the frame process. [2006/03/16:rpg]
-(defun receiver-from-tab-pane (tab-pane &optional (frame *application-frame*))
- (gethash tab-pane (tab-panes-to-receivers frame)))
+(defun receiver-from-tab-page (page &optional (frame *application-frame*))
+ (gethash page (tab-pages-to-receivers frame)))
(defvar *current-receiver-override*)
@@ -136,7 +136,7 @@
(defmethod current-receiver ((frame beirc))
(let ((receiver (if (boundp '*current-receiver-override*)
*current-receiver-override*
- (receiver-from-tab-pane (enabled-pane (find-pane-named frame 'query)) frame))))
+ (receiver-from-tab-page (tab-layout-enabled-page (find-pane-named frame 'query)) frame))))
(if (typep receiver 'receiver)
receiver
nil)))
@@ -417,8 +417,8 @@
(macrolet ((define-window-switcher (name keystroke direction predicate)
`(define-beirc-command (,name :name t :keystroke ,keystroke)
()
- (let* ((current-pane (tab-layout::tab-pane-pane
- (enabled-pane (find-pane-named *application-frame* 'query))))
+ (let* ((current-pane (tab-page-pane
+ (tab-layout-enabled-page (find-pane-named *application-frame* 'query))))
(list-of-panes (sheet-children (sheet-parent current-pane)))
(n-panes (length list-of-panes))
(current-pane-position (position current-pane list-of-panes))
@@ -433,11 +433,9 @@
until (or (= i end-position)
(funcall predicate (nth (mod (+ n-panes i) n-panes) list-of-panes)))
finally (return i)))
- (switch-to-pane (nth (mod (+ n-panes position) n-panes) list-of-panes)
- 'tab-layout-pane))))))
+ (switch-to-page (sheet-to-page (nth (mod (+ n-panes position) n-panes) list-of-panes))))))))
(labels ((pane-interesting-p (pane)
- (let ((receiver (receiver-from-tab-pane
- (find-in-tab-panes-list pane 'tab-layout-pane))))
+ (let ((receiver (receiver-from-tab-page (sheet-to-page pane))))
(or (> (messages-directed-to-me receiver) 0)
(> (unseen-messages receiver) 0)))))
(define-window-switcher com-interesting-window-next (#\Tab :control) 1 #'pane-interesting-p)
@@ -870,24 +868,20 @@
(receiver-pane receiver beirc
:documentation ((object stream)
(format stream "Reiceiver: ~A"
- (title (receiver-from-tab-pane
- (find-in-tab-panes-list object 'tab-layout-pane))))))
+ (title (receiver-from-tab-page
+ (sheet-to-page object))))))
(object)
- (receiver-from-tab-pane
- (find-in-tab-panes-list object 'tab-layout-pane)))
+ (receiver-from-tab-page (sheet-to-page object)))
(define-presentation-translator receiver-pane-to-channel-translator
(receiver-pane channel beirc
:documentation ((object stream)
(format stream "Channel: ~A"
- (channel (receiver-from-tab-pane
- (find-in-tab-panes-list object 'tab-layout-pane)))))
+ (channel (sheet-to-page object))))
:tester ((object)
- (channel (receiver-from-tab-pane
- (find-in-tab-panes-list object 'tab-layout-pane)))))
+ (channel (receiver-from-tab-page (sheet-to-page object)))))
(object)
- (channel (receiver-from-tab-pane
- (find-in-tab-panes-list object 'tab-layout-pane))))
+ (channel (sheet-to-page object)))
(define-presentation-translator receiver-to-channel-translator
(receiver channel beirc
@@ -950,10 +944,8 @@
(unwind-protect
(progn
(setf (irc:client-stream connection) (make-broadcast-stream))
- (when (tab-layout:find-in-tab-panes-list (find-pane-named frame 'server)
- (find-pane-named frame 'query))
- (tab-layout:remove-pane (find-pane-named frame 'server)
- (find-pane-named frame 'query)))
+ (when (sheet-to-page (find-pane-named frame 'server))
+ (remove-page (sheet-to-page (find-pane-named frame 'server))))
(setf (server-receiver frame connection) server-receiver)
(setf (ui-process *application-frame*) (current-process))
(if (processes-supported-p)
@@ -1138,4 +1130,4 @@
(defmethod frame-exit :after ((frame beirc))
"Shut off the sound server process, if necessary."
- (stop-sound-server))
\ No newline at end of file
+ (stop-sound-server))
--- /project/beirc/cvsroot/beirc/beirc.asd 2006/04/19 21:22:47 1.11
+++ /project/beirc/cvsroot/beirc/beirc.asd 2007/02/24 10:58:16 1.12
@@ -6,7 +6,7 @@
(cl:in-package :beirc.system)
(defsystem :beirc
- :depends-on (:mcclim :cl-irc :split-sequence :tab-layout :cl-ppcre :cl-fad)
+ :depends-on (:mcclim :cl-irc :split-sequence :cl-ppcre :cl-fad)
:components ((:file "package")
(:file "variables" :depends-on ("package"))
(:file "events" :depends-on ("package"))
@@ -20,4 +20,4 @@
;; probably wrong, and the dependency should be
;; removed. [2006/04/06:rpg]
(:file "sound-player" :depends-on ("package" "variables"))
- ))
\ No newline at end of file
+ ))
--- /project/beirc/cvsroot/beirc/message-display.lisp 2006/05/29 20:05:42 1.50
+++ /project/beirc/cvsroot/beirc/message-display.lisp 2007/02/24 10:58:16 1.51
@@ -697,4 +697,4 @@
maximize (preamble-length message))))
(formatting-table (t)
(loop for message in messages
- do (print-message message receiver)))))
\ No newline at end of file
+ do (print-message message receiver)))))
--- /project/beirc/cvsroot/beirc/package.lisp 2006/05/29 20:05:42 1.5
+++ /project/beirc/cvsroot/beirc/package.lisp 2007/02/24 10:58:16 1.6
@@ -1,5 +1,5 @@
(cl:defpackage :beirc
- (:use :clim :clim-lisp :clim-sys :tab-layout)
+ (:use :clim :clim-lisp :clim-sys :clim-tab-layout)
(:export #:beirc
#:*beirc-user-init-file*
#:*hyperspec-base-url* #:*default-fill-column* #:*timestamp-column-orientation*
--- /project/beirc/cvsroot/beirc/receivers.lisp 2006/04/12 18:42:30 1.28
+++ /project/beirc/cvsroot/beirc/receivers.lisp 2007/02/24 10:58:16 1.29
@@ -17,7 +17,7 @@
(incomplete-input :accessor incomplete-input :initform "")
(positions-mentioning-user :accessor positions-mentioning-user :initform nil)
(pane :reader pane)
- (tab-pane :accessor tab-pane)))
+ (tab-page :accessor tab-page)))
(defclass irc-connection-closed-message (irc:irc-message) ())
@@ -56,16 +56,18 @@
(defun initialize-receiver-with-pane (receiver frame pane &key (add-pane-p t))
(setf (slot-value receiver 'pane) pane)
(if (not add-pane-p)
- (setf (slot-value receiver 'tab-pane)
- (find-in-tab-panes-list pane
- 'tab-layout-pane))
+ (setf (slot-value receiver 'tab-page) (sheet-to-page pane))
(progn
- (setf (slot-value receiver 'tab-pane)
- (make-tab-pane-from-list (title receiver) (pane receiver) 'receiver-pane))
- (add-pane (tab-pane receiver) (find-pane-named frame 'query))
+ (setf (slot-value receiver 'tab-page)
+ (make-instance 'tab-page
+ :title (title receiver)
+ :pane (pane receiver)
+ :enabled-callback 'receiver-page-enabled-callback
+ :presentation-type 'receiver-pane))
+ (add-page (tab-page receiver) (find-pane-named frame 'query))
;; resize the pane to fit the tab container
(change-space-requirements pane)))
- (setf (gethash (tab-pane receiver) (tab-panes-to-receivers frame)) receiver))
+ (setf (gethash (tab-page receiver) (tab-pages-to-receivers frame)) receiver))
(defun rename-query-receiver (receiver new-name)
(let ((old-title (irc:normalize-nickname (connection receiver)
@@ -75,7 +77,7 @@
(with-slots (title query) receiver
(setf title new-name
query new-name
- (tab-layout::tab-pane-title (tab-pane receiver)) new-name)
+ (tab-page-title (tab-page receiver)) new-name)
(remhash (list (connection receiver) old-title) (receivers *application-frame*))
(setf (gethash (list (connection receiver) normalized-name) (receivers *application-frame*))
receiver))))
@@ -127,8 +129,7 @@
(defun remove-receiver (receiver frame)
- (tab-layout:remove-pane (tab-pane receiver)
- (find-pane-named frame 'query))
+ (remove-page (tab-page receiver))
(remhash (list (connection receiver) (title receiver)) (receivers frame)))
(defparameter *network-service-sources* '("nickserv" "memoserv" "chanserv" "")
@@ -299,29 +300,24 @@
(defun update-drawing-options (receiver)
(when (and (slot-boundp receiver 'pane) (sheetp (pane receiver))
- (find-in-tab-panes-list (pane receiver) 'tab-layout-pane))
- (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+))))))
-
-(defmethod switch-to-pane :after ((pane sheet) (parent (eql 'tab-layout-pane)))
- (let ((my-tab-layout-pane (find-pane-named *application-frame* 'query)))
- (when (eq (sheet-parent (sheet-parent pane)) ;; Is this the desired tab-layout?
- my-tab-layout-pane)
-
- (let ((receiver (receiver-from-tab-pane
- (find-in-tab-panes-list pane my-tab-layout-pane))))
- (unless (null receiver)
- (setf (unseen-messages receiver) 0)
- (setf (all-unseen-messages receiver) 0)
- (setf (messages-directed-to-me receiver) 0)
- (setf (last-visited receiver) (get-universal-time))
- (update-drawing-options receiver))))))
+ (sheet-to-page (pane receiver)))
+ (setf (tab-page-drawing-options (sheet-to-page (pane receiver)))
+ `(:ink ,(cond ((> (messages-directed-to-me receiver) 0) +green+)
+ ((> (unseen-messages receiver) 0) +red+)
+ (t +black+))))))
+
+(defun receiver-page-enabled-callback (page)
+ (let ((receiver (receiver-from-tab-page page)))
+ (unless (null receiver)
+ (setf (unseen-messages receiver) 0)
+ (setf (all-unseen-messages receiver) 0)
+ (setf (messages-directed-to-me receiver) 0)
+ (setf (last-visited receiver) (get-universal-time))
+ (update-drawing-options receiver))))
(defun raise-receiver (receiver)
(setf (unseen-messages receiver) 0)
(setf (all-unseen-messages receiver) 0)
(setf (messages-directed-to-me receiver) 0)
(setf (last-visited receiver) (get-universal-time))
- (switch-to-pane (pane receiver) 'tab-layout-pane))
+ (switch-to-page (sheet-to-page (pane receiver))))
More information about the Beirc-cvs
mailing list