[beirc-cvs] CVS update: beirc/beirc.lisp
Andreas Fuchs
afuchs at common-lisp.net
Tue Sep 13 20:48:12 UTC 2005
Update of /project/beirc/cvsroot/beirc
In directory common-lisp.net:/tmp/cvs-serv12696
Modified Files:
beirc.lisp
Log Message:
The multi-channel ("receiver") hack.
This patch comes with a lot of problems. But it's just way too cool to
just leave it out. (-:
problems:
* on join (you or anybody else), you are thrown into the debugger,
with a message about a bounding-rectangle method that's not
applicable to (NIL). Not investigated yet.
* every time anybody (including you) sends a PRIVMSG, the interactor
pane is wiped. This is related to the frame-redisplay-panes call in
the (handle-event frame foo-event) method.
* Every IRC message that isn't a JOIN, QUIT or PRIVMSG will land you
in the terminal debugger. feel free to implement more
receiver-for-message methods.
Date: Tue Sep 13 22:48:12 2005
Author: afuchs
Index: beirc/beirc.lisp
diff -u beirc/beirc.lisp:1.1.1.1 beirc/beirc.lisp:1.2
--- beirc/beirc.lisp:1.1.1.1 Mon Sep 12 20:13:09 2005
+++ beirc/beirc.lisp Tue Sep 13 22:48:11 2005
@@ -28,6 +28,11 @@
;;; SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
;;;
+(cl:eval-when (:compile-toplevel :load-toplevel :execute)
+ (cl:require :split-sequence)
+ (cl:require :cl-irc)
+ (cl:require :mcclim))
+
(defpackage :beirc
(:use :clim :clim-lisp :clim-sys)
(:export #:beirc))
@@ -60,21 +65,130 @@
;; <mumble> is just the rest of the input line.
;; <nickname> is a nickname of someone, with completion
+(defclass receiver ()
+ ((name :reader receiver-name :initarg :name)
+ (messages :accessor messages :initform nil)
+ (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)))
+
+(defmethod initialize-instance :after ((object receiver) &rest initargs)
+ (declare (ignore initargs))
+ (setf (slot-value object 'pane)
+ (with-look-and-feel-realization
+ ((frame-manager *application-frame*) *application-frame*)
+ (print (make-clim-application-pane
+ :display-function
+ (lambda (frame pane)
+ (beirc-app-display frame pane object))
+ :display-time :command-loop
+ :width 400 :height 600
+ :incremental-redisplay t) *debug-io*))))
+
+(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)
+ receiver))
+
+(defun intern-receiver (name frame &rest initargs)
+ (let ((rec (gethash name (receivers frame))))
+ (if rec
+ rec
+ (let ((*application-frame* frame))
+ (apply 'make-receiver name initargs)))))
+
+(defun receiver-for-pane (pane &optional (frame *application-frame*))
+ (gethash pane (receiver-panes frame)))
+
+
+(defmethod receiver-for-message ((message irc:irc-privmsg-message) frame)
+ ;; XXX: handle target=ournick
+ (let ((target (first (irc:arguments message))))
+ (intern-receiver target frame :channel target)))
+
+(defmethod receiver-for-message ((message irc:irc-join-message) frame)
+ (let ((target (first (irc:arguments message))))
+ (intern-receiver target frame :channel target)))
+
+(defmethod receiver-for-message ((message irc:irc-quit-message) frame)
+ (current-receiver frame) ; FIXME: quit messages should go to all channels/queries the user was on.
+ )
+
+;; TODO: more receiver-for-message methods.
+
+(macrolet ((define-delegate (function-name accessor &optional define-setter-p)
+ `(progn
+ ,(when define-setter-p
+ `(defun (setf ,function-name) (new-value &optional (frame *application-frame*))
+ (when (current-receiver frame)
+ (setf (,accessor (current-receiver frame)) new-value))))
+ (defun ,function-name (&optional (frame *application-frame*))
+ (when (current-receiver frame)
+ (,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 initial-contents)
+ (sheet-adopt-child pane k)))
+
+(defun raise-receiver (receiver &optional (frame *application-frame*))
+ (setf (current-receiver frame) receiver)
+ (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))))
+
(define-application-frame beirc ()
- ((connection :initform nil)
- (messages :initform nil)
- (query :initform nil)
+ ((current-receiver :initform nil :accessor current-receiver)
+ (connection :initform nil)
(nick :initform nil)
- (channel :initform nil)
- (focused-nicks :initform nil)
- (ignored-nicks :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))
(:panes
- (app :application
- :display-function 'beirc-app-display
- :display-time :command-loop
- :incremental-redisplay t)
(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
@@ -90,8 +204,10 @@
(:layouts
(default
(vertically ()
- app
+ query
(60 io)
+ (20
+ receiver-bar)
(20 ;<-- Sigh! Bitrot!
status-bar )))))
@@ -99,6 +215,14 @@
(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))
@@ -106,14 +230,14 @@
(format t "~2,'0D:~2,'0D ~A on ~A~@[ speaking to ~A~]~100T~D messages"
hours minutes
(slot-value *application-frame* 'nick)
- (slot-value *application-frame* 'channel)
- (slot-value *application-frame* 'query)
- (length (slot-value *application-frame* 'messages))))))
+ (current-channel)
+ (current-query)
+ (length (current-messages))))))
(defun beirc-prompt (*standard-output* *application-frame*)
(format *standard-output* "Beirc ~A => "
- (or (slot-value *application-frame* 'query)
- (slot-value *application-frame* 'channel))))
+ (or (current-query)
+ (current-channel))))
;; (defun format-message (prefix mumble)
;; (write-line
@@ -131,14 +255,14 @@
(cond (start
(write-string (subseq url 0 start))
(present (concatenate 'string
- "file://localhost/path/to/your/HyperSpec/"
+ "file://localhost/Users/dmurray/lisp/HyperSpec/"
(subseq url (+ 45 start)))
'url))
(t (present url 'url)))))
(defun format-message* (preamble mumble
&key (prefix " ")
- (limit 105))
+ (limit 100))
(loop for word in (split-sequence:split-sequence #\Space mumble)
with line-prefix = prefix
with column = (+ (length line-prefix) (length preamble))
@@ -161,7 +285,7 @@
(define-presentation-type url ()
:inherit-from 'string)
-(defmethod print-message ((message irc:IRC-PRIVMSG-MESSAGE))
+(defmethod print-message ((message irc:IRC-PRIVMSG-MESSAGE) receiver)
(with-drawing-options
(*standard-output*
:ink (if (string-equal "localhost" (irc:host message))
@@ -171,7 +295,7 @@
:test #'string=)
(with-text-face
(*standard-output*
- (if (member (irc:source message) (slot-value *application-frame* 'focused-nicks)
+ (if (member (irc:source message) (current-focused-nicks)
:test #'string=)
:bold
:roman))
@@ -189,7 +313,7 @@
(format nil "*~A*" (irc:source message)))))))
(format-message* preamble (irc:trailing-argument message)))))))
-(defmethod print-message ((message irc:ctcp-action-message))
+(defmethod print-message ((message irc:ctcp-action-message) receiver)
(let ((source (cl-irc:source message))
(matter (trailing-argument* message))
(dest (car (cl-irc:arguments message))))
@@ -198,19 +322,18 @@
source)
matter)))
-(defmethod print-message ((message irc:irc-quit-message))
+(defmethod print-message ((message irc:irc-quit-message) receiver)
(with-drawing-options (*standard-output* :ink +gray33+ :text-size :small)
(format-message* (format nil "~10T Quit: ~A;"
(irc:source message))
(irc:trailing-argument message))))
-(defmethod print-message ((message irc:irc-join-message))
+(defmethod print-message ((message irc:irc-join-message) receiver)
(with-drawing-options (*standard-output* :ink +gray33+ :text-size :small)
(format *standard-output* "~10T Join: ~A (~A@~A)"
(irc:source message)
(irc:user message)
- (irc:host message)
- (irc:trailing-argument message))
+ (irc:host message))
(terpri) ))
;;; Here comes the trick:
@@ -222,7 +345,8 @@
;;; we send it to the frame.
(defclass foo-event (clim:window-manager-event)
- ((sheet :initarg :sheet :reader event-sheet)))
+ ((sheet :initarg :sheet :reader event-sheet)
+ (receiver :initarg :receiver :reader receiver)))
;;for updating the time display, triggered from TICKER
(defclass bar-event (clim:window-manager-event)
@@ -244,11 +368,14 @@
(defmethod handle-event ((frame beirc) (event foo-event))
;; Hack:
;; Figure out if we are scrolled to the bottom.
- (let ((pane (get-frame-pane frame 'app)))
+ (let* ((receiver (receiver event))
+ (pane (pane receiver))) ; FIXME: pane isn't a stream pane, but a VRACK-PANE. gack.
(let ((btmp (pane-scrolled-to-bottom-p pane)))
- (time (redisplay-frame-pane frame pane))
- (when btmp
- (scroll-pane-to-bottom pane)))
+ (setf (pane-needs-redisplay pane) t)
+ (time (redisplay-frame-panes frame :force-p t))
+;; (when btmp
+;; (scroll-pane-to-bottom pane))
+ )
(medium-force-output (sheet-medium pane)) ;###
))
@@ -273,12 +400,13 @@
(run-frame-top-level frame))))))))
(defun post-message (frame message)
- (setf (slot-value frame 'messages)
- (append (slot-value frame 'messages) (list message)))
- (clim-internals::event-queue-prepend
- (climi::frame-event-queue frame)
- (make-instance 'foo-event :sheet frame))
- nil)
+ (let ((receiver (receiver-for-message message frame)))
+ (setf (messages receiver)
+ (append (messages receiver) (list message)))
+ (clim-internals::event-queue-prepend
+ (climi::frame-event-queue frame)
+ (make-instance 'foo-event :sheet frame :receiver receiver))
+ nil))
(defun ticker (frame)
(loop
@@ -293,13 +421,30 @@
res)
(define-presentation-method accept ((type nickname) *standard-input* (view textual-view) &key)
- (with-slots (connection nick channel) *application-frame*
- (let ((users (mapcar #'car (hash-alist (irc:users (irc:find-channel connection channel))))))
+ (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))))
+(define-presentation-method accept ((type receiver) *standard-input* (view textual-view) &key)
+ (completing-from-suggestions (*standard-input* :partial-completers '(#\Space))
+ (maphash #'suggest (receivers *application-frame*))))
+
+(define-presentation-method present (o (type receiver) *standard-output* (view textual-view) &key)
+ (format t "~A" (receiver-name o)))
+
+(define-presentation-to-command-translator raise-this-receiver
+ (receiver com-raise-receiver beirc
+ :gesture :select
+ :documentation "Raise this receiver")
+ (presentation)
+ (list (presentation-object presentation)))
+
+(define-beirc-command (com-raise-receiver :name t) ((receiver 'receiver :prompt "Receiver"))
+ (raise-receiver receiver))
+
(define-beirc-command (com-focus :name t) ((who 'nickname :prompt "who"))
- (pushnew who (slot-value *application-frame* 'focused-nicks) :test #'string=))
+ (pushnew who (current-focused-nicks) :test #'string=))
(define-beirc-command (com-ignore :name t) ((who 'nickname :prompt "who"))
(pushnew who (slot-value *application-frame* 'ignored-nicks) :test #'string=))
@@ -309,12 +454,12 @@
(remove who (slot-value *application-frame* 'ignored-nicks) :test #'string=)))
(define-beirc-command (com-unfocus :name t) ((who 'nickname :prompt "who"))
- (setf (slot-value *application-frame* 'focused-nicks)
- (remove who (slot-value *application-frame* 'focused-nicks) :test #'string=)))
+ (setf (current-focused-nicks)
+ (remove who (current-focused-nicks) :test #'string=)))
(defun target (&optional (*application-frame* *application-frame*))
- (or (slot-value *application-frame* 'query)
- (slot-value *application-frame* 'channel)))
+ (or (current-query)
+ (current-channel)))
(define-beirc-command (com-say :name t) ((what 'mumble))
;; make a fake IRC-PRIV-MESSAGE object
@@ -347,11 +492,11 @@
(list (presentation-object presentation)))
(define-beirc-command (com-join :name t) ((channel 'string :prompt "channel"))
- (when (slot-value *application-frame* 'channel)
- (irc:part
- (slot-value *application-frame* 'connection)
- (slot-value *application-frame* 'channel)))
- (setf (slot-value *application-frame* 'channel) channel)
+ (setf (current-receiver *application-frame*)
+ (intern-receiver channel *application-frame* :channel channel))
+ (sheet-adopt-child (find-pane-named *application-frame* 'query)
+ (pane (current-receiver *application-frame*)))
+ (raise-receiver (current-receiver *application-frame*))
(irc:join (slot-value *application-frame* 'connection) channel))
(define-beirc-command (com-connect :name t)
@@ -381,12 +526,12 @@
(window-clear stream)))
(defun restart-beirc ()
- (let ((m (slot-value *beirc-frame* 'messages)))
+ (let ((m (current-messages)))
(clim-sys:destroy-process *gui-process*)
(setf *beirc-frame* nil)
(beirc)
(clim-sys:process-wait "waiting for beirc" (lambda () *beirc-frame*))
- (setf (slot-value *beirc-frame* 'messages) m)))
+ (setf (current-messages) m)))
;;;;;;;;;
@@ -436,36 +581,37 @@
(irc:read-message-loop connection) )
(irc:remove-all-hooks connection)))
-(defun beirc-app-display (*application-frame* *standard-output*)
+(defun beirc-app-display (*application-frame* *standard-output* receiver)
;; Fix me: This usage of UPDATING-OUTPUT is sub-optimal and ugly!
+ ;; Fix me: as is all that *standard-output* stuff
+ (print *standard-output* *debug-io*)
+ (print (pane receiver) *debug-io*)
(let ((w (- (floor (bounding-rectangle-width (sheet-parent *standard-output*))
(clim:stream-string-width *standard-output* "X"))
- 2)))
- (with-slots (messages) *application-frame*
- (let ((k 100)
- (n (length messages)))
- (loop for i below (* k (ceiling n k)) by k do
+ 2))
+ (messages (and receiver (messages receiver))))
+ (let ((k 100)
+ (n (length messages)))
+ (loop for i below (* k (ceiling n k)) by k do
+ (updating-output (*standard-output*
+ :unique-id i
+ :cache-value
+ (list (min n (+ i k))
+ (focused-nicks receiver)
+ (slot-value *application-frame* 'ignored-nicks)
+ w)
+ :cache-test #'equal)
+ (loop for j from i below (min n (+ i k)) do
+ (let ((m (elt messages j)))
(updating-output (*standard-output*
- :unique-id i
+ :unique-id j
:cache-value
- (list (min n (+ i k))
- (slot-value *application-frame* 'focused-nicks)
- (slot-value *application-frame* 'ignored-nicks)
- w)
- :cache-test #'equal
- )
- (loop for j from i below (min n (+ i k)) do
- (let ((m (elt messages j)))
- (updating-output (*standard-output*
- :unique-id j
- :cache-value
- (list m
- (slot-value *application-frame* 'focused-nicks)
- (slot-value *application-frame* 'ignored-nicks)
- w)
- :cache-test #'equal
- )
- (print-message m))))))))))
+ (list m
+ (focused-nicks receiver)
+ (slot-value *application-frame* 'ignored-nicks)
+ w)
+ :cache-test #'equal)
+ (print-message m receiver)))))))))
;;; Hack:
(defmethod allocate-space :after ((pane climi::viewport-pane) w h)
More information about the Beirc-cvs
mailing list