[beirc-cvs] CVS update: beirc/beirc.asd beirc/beirc.lisp beirc/package.lisp
Andreas Fuchs
afuchs at common-lisp.net
Fri Sep 23 19:05:17 UTC 2005
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 , at users)
- :prompt nil))))
+ (accept `(member , at users) :prompt nil))))
+
+(define-presentation-method accept ((type ignored-nickname) *standard-input* (view textual-view) &key)
+ (with-slots (ignored-nicks) *application-frame*
+ (accept `(member , at 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))
More information about the Beirc-cvs
mailing list