Update of /project/beirc/cvsroot/beirc In directory common-lisp.net:/tmp/cvs-serv15507
Modified Files: beirc.asd beirc.lisp package.lisp Log Message: Integrate Max-Gerd Retzlaff's tab-layout extension.
Also, add a few p-to-command-translators for nicknames (focus, query, ignore)
Date: Fri Sep 23 21:05:16 2005 Author: afuchs
Index: beirc/beirc.asd diff -u beirc/beirc.asd:1.2 beirc/beirc.asd:1.3 --- beirc/beirc.asd:1.2 Sat Sep 17 21:23:14 2005 +++ beirc/beirc.asd Fri Sep 23 21:05:15 2005 @@ -6,7 +6,7 @@ (cl:in-package :beirc.system)
(defsystem :beirc - :depends-on (:mcclim :cl-irc :split-sequence) + :depends-on (:mcclim :cl-irc :split-sequence :tab-layout) :components ((:file "package") (:file "beirc" :depends-on ("package")) (:file "message-display" :depends-on ("package" "beirc"))))
Index: beirc/beirc.lisp diff -u beirc/beirc.lisp:1.13 beirc/beirc.lisp:1.14 --- beirc/beirc.lisp:1.13 Fri Sep 23 11:52:40 2005 +++ beirc/beirc.lisp Fri Sep 23 21:05:15 2005 @@ -57,14 +57,15 @@ ;; <nickname> is a nickname of someone, with completion
(defclass receiver () - ((name :reader receiver-name :initarg :name) - (messages :accessor messages :initform nil) + ((messages :accessor messages :initform nil) (unseen-messages :accessor unseen-messages :initform 0) (messages-directed-to-me :accessor messages-directed-to-me :initform 0) (channel :reader channel :initform nil :initarg :channel) (query :reader query :initform nil :initarg :query) ;; <- XXX: remove this. - (pane :reader pane :initform nil) - (focused-nicks :accessor focused-nicks :initform nil))) + (focused-nicks :accessor focused-nicks :initform nil) + (title :reader title :initarg :title) + (pane :reader pane) + (tab-pane :accessor tab-pane)))
;;; KLUDGE: make-clim-application-pane doesn't return an application ;;; pane, but a pane that wraps the application pane. we need the @@ -88,33 +89,27 @@ :display-function (lambda (frame pane) (beirc-app-display frame pane object)) - :display-time :command-loop + :display-time nil :width 400 :height 600 - :incremental-redisplay t)))) + :incremental-redisplay t))) + (setf (slot-value object 'tab-pane) + (make-tab-pane-from-list (title object) (pane object) 'receiver)))
(defun make-receiver (name &rest initargs) - (let ((receiver (apply 'make-instance 'receiver :name name initargs))) - (setf (gethash name (receivers *application-frame*)) - receiver) - (setf (gethash (pane receiver) (receiver-panes *application-frame*)) - receiver) + (let ((receiver (apply 'make-instance 'receiver :title name initargs))) receiver))
(defun intern-receiver (name frame &rest initargs) - (let ((rec (gethash (irc:normalize-channel-name (slot-value frame 'connection) - name) (receivers frame)))) + (let ((rec (gethash name (receivers frame)))) (if rec rec (let ((*application-frame* frame)) (let ((receiver (apply 'make-receiver name initargs))) - (setf (sheet-enabled-p (pane receiver)) nil) - (sheet-adopt-child (find-pane-named *application-frame* 'query) - (pane receiver)) + (add-pane (tab-pane receiver) (find-pane-named frame 'query)) + (setf (gethash name (receivers frame)) receiver) + (setf (gethash (tab-pane receiver) (tab-panes-to-receivers frame)) receiver) receiver)))))
-(defun receiver-for-pane (pane &optional (frame *application-frame*)) - (gethash pane (receiver-panes frame))) - (macrolet ((define-privmsg-receiver-lookup (message-type) `(defmethod receiver-for-message ((message ,message-type) frame) (let* ((mynick (irc:normalize-nickname (slot-value frame 'connection) @@ -146,7 +141,6 @@ (intern-receiver target frame :channel target))) ;; TODO: more receiver-for-message methods.
- (macrolet ((define-delegate (function-name accessor &optional define-setter-p) `(progn ,(when define-setter-p @@ -158,46 +152,29 @@ (,accessor (current-receiver frame))))))) (define-delegate current-channel channel) (define-delegate current-query query) - (define-delegate current-pane pane) (define-delegate current-messages messages t) (define-delegate current-focused-nicks focused-nicks t))
-(defclass stack-layout-pane (clim:sheet-multiple-child-mixin - clim:basic-pane) - ()) - -(defmethod compose-space ((pane stack-layout-pane) &key width height) - (declare (ignore width height)) - (reduce (lambda (x y) - (space-requirement-combine #'max x y)) - (mapcar #'compose-space (sheet-children pane)) - :initial-value - (make-space-requirement :width 0 :min-width 0 :max-width 0 - :height 0 :min-height 0 :max-height 0))) - -(defmethod allocate-space ((pane stack-layout-pane) width height) - (dolist (child (sheet-children pane)) - (move-and-resize-sheet child 0 0 width height) - (allocate-space child width height))) - -(defmethod initialize-instance :after ((pane stack-layout-pane) - &rest args - &key initial-contents - &allow-other-keys) - (declare (ignore args)) - (dolist (k (or initial-contents - (list (make-clim-application-pane)))) - (sheet-adopt-child pane k))) +(defun update-drawing-options (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+))))) + +(defmethod switch-to-pane :after ((pane sheet) (parent (eql 'tab-layout-pane))) + (let ((receiver (receiver-from-tab-pane + (find-in-tab-panes-list pane + (find-pane-named *application-frame* 'query))))) + (unless (null receiver) + (setf (unseen-messages receiver) 0) + (setf (messages-directed-to-me receiver) 0) + (update-drawing-options receiver)))) +
-(defun raise-receiver (receiver &optional (frame *application-frame*)) - (setf (current-receiver frame) receiver) +(defun raise-receiver (receiver) (setf (unseen-messages receiver) 0) (setf (messages-directed-to-me receiver) 0) - (mapcar (lambda (pane) - (let ((pane-receiver (receiver-for-pane pane frame))) - (setf (sheet-enabled-p pane) - (eql receiver pane-receiver)))) - (sheet-children (find-pane-named frame 'query)))) + (switch-to-pane (pane receiver) 'tab-layout-pane))
;;; KLUDGE: workaround for mcclim bug "Application pane vertical ;;; scrolling does not work with table formatting" @@ -213,23 +190,14 @@
(define-application-frame beirc (redisplay-frame-mixin standard-application-frame) - ((current-receiver :initform nil :accessor current-receiver) - (connection :initform nil :reader current-connection) + ((connection :initform nil :reader current-connection) (nick :initform nil) (ignored-nicks :initform nil) - (receivers :initform (make-hash-table :test 'equal) :reader receivers) - (receiver-panes :initform (make-hash-table :test 'eql) :reader receiver-panes)) + (receivers :initform (make-hash-table :test #'equal) :accessor receivers) + (tab-panes-to-receivers :initform (make-hash-table :test #'equal) :accessor tab-panes-to-receivers)) (:panes (io :interactor) - (query (make-pane 'stack-layout-pane)) - (receiver-bar - :application - :display-function 'beirc-receivers-display - :display-time :command-loop - :incremental-redisplay t - :height 20 - :scroll-bars nil) (status-bar :application :display-function 'beirc-status-display @@ -239,31 +207,36 @@ :height 20 :scroll-bars nil :background +black+ - :foreground +white+) ) + :foreground +white+) + (server + :application + ;; TODO: server message display. + )) (:geometry :width 800 :height 600) (:top-level (clim:default-frame-top-level :prompt 'beirc-prompt)) (:layouts (default (vertically () - query + (with-tab-layout ('receiver :name 'query) + ("Server" server)) (60 io) - (20 - receiver-bar) (20 ;<-- Sigh! Bitrot! status-bar )))))
+(defun receiver-from-tab-pane (tab-pane) + (gethash tab-pane + (tab-panes-to-receivers *application-frame*))) + +(defmethod current-receiver ((frame beirc)) + (let ((receiver (receiver-from-tab-pane (enabled-pane (find-pane-named frame 'query))))) + (if (typep receiver 'receiver) + receiver + nil))) + (defvar *gui-process* nil)
(defvar *beirc-frame*)
-(defun beirc-receivers-display (*application-frame* *standard-output*) - (with-text-family (t :sans-serif) - (maphash (lambda (key value) - (declare (ignore key)) - (present value 'receiver :stream *standard-output*) - (format t " ")) - (receivers *application-frame*)))) - (defun beirc-status-display (*application-frame* *standard-output*) (with-text-family (t :sans-serif) (multiple-value-bind (seconds minutes hours) (decode-universal-time (get-universal-time)) @@ -331,10 +304,8 @@ (pane (actual-application-pane (pane receiver)))) (let ((btmp (pane-scrolled-to-bottom-p pane))) (setf (pane-needs-redisplay pane) t) - (time (redisplay-frame-pane frame pane)) - (redisplay-frame-pane frame (find-pane-named frame 'receiver-bar)) - (when btmp - (scroll-pane-to-bottom pane))) + (time (redisplay-frame-panes frame)) + (when btmp (scroll-pane-to-bottom pane))) (medium-force-output (sheet-medium pane)) ;### ))
@@ -368,9 +339,11 @@ (setf (messages receiver) (append (messages receiver) (list message))) (unless (eql receiver (current-receiver frame)) + (print "hallo" *debug-io*) (incf (unseen-messages receiver)) (when (message-directed-to-me-p frame message) (incf (messages-directed-to-me receiver)))) + (update-drawing-options receiver) (clim-internals::event-queue-prepend (climi::frame-event-queue frame) (make-instance 'foo-event :sheet frame :receiver receiver)) @@ -383,6 +356,7 @@ (sleep 1)))
(define-presentation-type nickname ()) +(define-presentation-type ignored-nickname (nickname))
(defun hash-alist (hashtable &aux res) (maphash (lambda (k v) (push (cons k v) res)) hashtable) @@ -391,8 +365,11 @@ (define-presentation-method accept ((type nickname) *standard-input* (view textual-view) &key) (with-slots (connection nick) *application-frame* (let ((users (mapcar #'car (hash-alist (irc:users (irc:find-channel connection (current-channel))))))) - (accept `(member ,@users) - :prompt nil)))) + (accept `(member ,@users) :prompt nil)))) + +(define-presentation-method accept ((type ignored-nickname) *standard-input* (view textual-view) &key) + (with-slots (ignored-nicks) *application-frame* + (accept `(member ,@ignored-nicks) :prompt nil)))
(define-presentation-method accept ((type receiver) *standard-input* (view textual-view) &key) (completing-from-suggestions (*standard-input* :partial-completers '(#\Space)) @@ -412,12 +389,6 @@ (format t "~A" o))) (format t "~A" o)))
-(define-presentation-method present (o (type receiver) *standard-output* (view textual-view) &key) - (with-drawing-options (t :ink (cond ((> (messages-directed-to-me o) 0) +green+) - ((> (unseen-messages o) 0) +red+) - (t +black+))) - (format t "~A" (receiver-name o)))) - (define-presentation-to-command-translator raise-this-receiver (receiver com-raise-receiver beirc :gesture :select @@ -425,7 +396,10 @@ (presentation) (list (presentation-object presentation)))
-(define-beirc-command (com-raise-receiver :name t) ((receiver 'receiver :prompt "Receiver")) +(define-beirc-command (com-query :name t) ((nick 'nickname :prompt "who")) + (raise-receiver (intern-receiver nick *application-frame* :query nick))) + +(define-beirc-command (com-raise :name t) ((receiver 'receiver :prompt "receiver")) (raise-receiver receiver))
(define-beirc-command (com-focus :name t) ((who 'nickname :prompt "who")) @@ -434,7 +408,7 @@ (define-beirc-command (com-ignore :name t) ((who 'nickname :prompt "who")) (pushnew who (slot-value *application-frame* 'ignored-nicks) :test #'string=))
-(define-beirc-command (com-unignore :name t) ((who 'nickname :prompt "who")) +(define-beirc-command (com-unignore :name t) ((who 'ignored-nickname :prompt "who")) (setf (slot-value *application-frame* 'ignored-nicks) (remove who (slot-value *application-frame* 'ignored-nicks) :test #'string=)))
@@ -442,6 +416,9 @@ (setf (current-focused-nicks) (remove who (current-focused-nicks) :test #'string=)))
+(define-beirc-command (com-quit :name t) ((reason 'string :prompt "reason")) + (irc:quit (current-connection *application-frame*) reason)) + (defun target (&optional (*application-frame* *application-frame*)) (or (current-query) (current-channel))) @@ -475,15 +452,37 @@ #+ (and sbcl linux) (sb-ext:run-program "/usr/bin/x-www-browser" `(,url) :wait nil))
+(define-presentation-to-command-translator nickname-to-ignore-translator + (nickname com-ignore beirc + :gesture :menu + :menu t + :documentation "Ignore this user") + (object) + (list object)) + +(define-presentation-to-command-translator nickname-to-focus-translator + (nickname com-focus beirc + :gesture :menu + :menu t + :documentation "Focus this user") + (object) + (list object)) + +(define-presentation-to-command-translator nickname-to-query-translator + (nickname com-query beirc + :gesture :menu + :menu t + :documentation "Query this user") + (object) + (list object)) + (define-presentation-to-command-translator url-to-browse-url-translator (url com-browse-url beirc) (presentation) (list (presentation-object presentation)))
(define-beirc-command (com-join :name t) ((channel 'string :prompt "channel")) - (setf (current-receiver *application-frame*) - (intern-receiver channel *application-frame* :channel channel)) - (raise-receiver (current-receiver *application-frame*)) + (raise-receiver (intern-receiver channel *application-frame* :channel channel)) (irc:join (current-connection *application-frame*) channel))
(define-beirc-command (com-connect :name t) @@ -493,6 +492,8 @@ (t (setf (slot-value *application-frame* 'connection) (irc:connect :nickname nick :server server)) + (setf (irc:client-stream (current-connection *application-frame*)) + (make-broadcast-stream)) (setf (slot-value *application-frame* 'nick) nick) (let ((connection (current-connection *application-frame*))) (let ((frame *application-frame*))
Index: beirc/package.lisp diff -u beirc/package.lisp:1.1 beirc/package.lisp:1.2 --- beirc/package.lisp:1.1 Wed Sep 14 22:31:44 2005 +++ beirc/package.lisp Fri Sep 23 21:05:15 2005 @@ -1,3 +1,3 @@ (cl:defpackage :beirc - (:use :clim :clim-lisp :clim-sys) + (:use :clim :clim-lisp :clim-sys :tab-layout) (:export #:beirc))