Update of /project/beirc/cvsroot/beirc In directory common-lisp.net:/tmp/cvs-serv25178

Modified Files: beirc.lisp message-display.lisp Log Message: baby steps towards a server buffer.

* don't register hook functions into cl-irc anymore, just catch all of them and tries to print them in a mostly sensible manner in the *Server* buffer.

* doesn't actually display the messages, as redisplay is broken, for only the Server buffer.

* requires cl-irc cvs patched with http://common-lisp.net/pipermail/cl-irc-devel/2005-September/000061.html

anybody who can fix the redisplay issue is welcome to do so (-:

Date: Fri Sep 23 23:31:39 2005 Author: afuchs

Index: beirc/beirc.lisp diff -u beirc/beirc.lisp:1.14 beirc/beirc.lisp:1.15 --- beirc/beirc.lisp:1.14 Fri Sep 23 21:05:15 2005 +++ beirc/beirc.lisp Fri Sep 23 23:31:27 2005 @@ -80,34 +80,57 @@ for found-pane = (actual-application-pane child) if found-pane do (return found-pane))))

-(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*) - (make-clim-application-pane - :display-function - (lambda (frame pane) - (beirc-app-display frame pane object)) - :display-time nil - :width 400 :height 600 - :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 :title name initargs))) - receiver)) +;;; 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)) + +(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 (direct-tab-pane-child-from pane) + 'tab-layout-pane)) + (progn + (setf (slot-value receiver 'tab-pane) + (make-tab-pane-from-list (title receiver) (pane receiver) 'receiver)) + (add-pane (tab-pane receiver) (find-pane-named frame 'query)))) + (setf (gethash (tab-pane receiver) (tab-panes-to-receivers frame)) receiver))

(defun intern-receiver (name frame &rest initargs) - (let ((rec (gethash name (receivers frame)))) + (let ((rec (gethash (irc:normalize-channel-name (slot-value frame 'connection) name) + (receivers frame)))) (if rec rec (let ((*application-frame* frame)) - (let ((receiver (apply 'make-receiver name initargs))) - (add-pane (tab-pane receiver) (find-pane-named frame 'query)) + (let ((receiver (apply 'make-paneless-receiver name initargs))) + (initialize-receiver-with-pane receiver frame + (with-look-and-feel-realization + ((frame-manager *application-frame*) *application-frame*) + (make-clim-application-pane + :display-function + (lambda (frame pane) + (beirc-app-display frame pane receiver)) + :display-time nil + :width 400 :height 600 + :incremental-redisplay t))) (setf (gethash name (receivers frame)) receiver) - (setf (gethash (tab-pane receiver) (tab-panes-to-receivers frame)) receiver) receiver)))))

(macrolet ((define-privmsg-receiver-lookup (message-type) @@ -122,7 +145,8 @@ (intern-receiver target frame :channel target))))) (define-privmsg-receiver-lookup irc:irc-privmsg-message) (define-privmsg-receiver-lookup irc:ctcp-action-message) - (define-privmsg-receiver-lookup irc:irc-notice-message)) + ;; (define-privmsg-receiver-lookup irc:irc-notice-message) ; XXX: NOTICEs in freenode are a bit tricky. + )

(macrolet ((define-global-message-receiver-lookup (message-type) `(defmethod receiver-for-message ((message ,message-type) frame) @@ -139,6 +163,10 @@ (defmethod receiver-for-message ((message irc:irc-part-message) frame) (let ((target (first (irc:arguments message)))) (intern-receiver target frame :channel target))) + +(defmethod receiver-for-message ((message irc:irc-message) frame) + (server-receiver frame)) + ;; TODO: more receiver-for-message methods.

(macrolet ((define-delegate (function-name accessor &optional define-setter-p) @@ -156,7 +184,7 @@ (define-delegate current-focused-nicks focused-nicks t))

(defun update-drawing-options (receiver) - (set-drawing-options-for-pane-in-tab-layout (pane receiver) + (set-drawing-options-for-pane-in-tab-layout (direct-tab-pane-child-from (pane receiver)) `(:ink ,(cond ((> (messages-directed-to-me receiver) 0) +green+) ((> (unseen-messages receiver) 0) +red+) (t +black+))))) @@ -174,7 +202,7 @@ (defun raise-receiver (receiver) (setf (unseen-messages receiver) 0) (setf (messages-directed-to-me receiver) 0) - (switch-to-pane (pane receiver) 'tab-layout-pane)) + (switch-to-pane (direct-tab-pane-child-from (pane receiver)) 'tab-layout-pane))

;;; KLUDGE: workaround for mcclim bug "Application pane vertical ;;; scrolling does not work with table formatting" @@ -194,6 +222,7 @@ (nick :initform nil) (ignored-nicks :initform nil) (receivers :initform (make-hash-table :test #'equal) :accessor receivers) + (server-receiver :initform (make-paneless-receiver "*Server*") :reader server-receiver) (tab-panes-to-receivers :initform (make-hash-table :test #'equal) :accessor tab-panes-to-receivers)) (:panes (io @@ -210,22 +239,25 @@ :foreground +white+) (server :application - ;; TODO: server message display. - )) + :display (lambda (frame pane) + (beirc-app-display frame pane (server-receiver *application-frame*))) + :display-time :command-loop + :width 400 + :height 600 + :incremental-redisplay t)) (:geometry :width 800 :height 600) (:top-level (clim:default-frame-top-level :prompt 'beirc-prompt)) (:layouts (default (vertically () (with-tab-layout ('receiver :name 'query) - ("Server" server)) + ("*Server*" server)) (60 io) (20 ;<-- Sigh! Bitrot! - status-bar ))))) + status-bar)))))

(defun receiver-from-tab-pane (tab-pane) - (gethash tab-pane - (tab-panes-to-receivers *application-frame*))) + (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))))) @@ -339,7 +371,6 @@ (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)))) @@ -364,8 +395,9 @@

(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)))) + (let ((users (unless (null (current-channel)) + (mapcar #'car (hash-alist (irc:users (irc:find-channel connection (current-channel)))))))) + (accept `(or (member ,@users) string) :prompt nil))))

(define-presentation-method accept ((type ignored-nickname) *standard-input* (view textual-view) &key) (with-slots (ignored-nicks) *application-frame* @@ -491,12 +523,15 @@ (format *query-io* "You are already connected.~%")) (t (setf (slot-value *application-frame* 'connection) - (irc:connect :nickname nick :server server)) + (irc:connect :nickname nick :server server :connection-type 'beirc-connection)) (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*)) + (initialize-receiver-with-pane (server-receiver frame) frame + (find-pane-named frame 'server) + :add-pane-p nil) (clim-sys:make-process #'(lambda () (irc-event-loop frame connection)) :name "IRC Message Muffling Loop") ))))) @@ -553,24 +588,18 @@ ; (finish-output *trace-output*) nil)

+(defclass beirc-connection (irc:connection) + ()) + +(defmethod irc:read-message :around ((connection beirc-connection)) + (let ((message (call-next-method connection))) + (post-message *application-frame* message) + message)) + (defun irc-event-loop (frame connection) (unwind-protect - (progn - (irc:add-hook connection 'irc:irc-privmsg-message - (lambda (m) (post-message frame m))) - (irc:add-hook connection 'irc:irc-nick-message - (lambda (m) (post-message frame m))) - (irc:add-hook connection 'irc:irc-part-message - (lambda (m) (post-message frame m))) - (irc:add-hook connection 'irc:irc-quit-message - (lambda (m) (post-message frame m))) - (irc:add-hook connection 'irc:irc-join-message - (lambda (m) (post-message frame m))) - (irc:add-hook connection 'irc:irc-ping-message - (lambda (m) (process-message frame m))) - (irc:add-hook connection 'cl-irc:ctcp-action-message - (lambda (m) (post-message frame m))) - (irc:read-message-loop connection) ) + (let ((*application-frame* frame)) + (irc:read-message-loop connection)) (irc:remove-all-hooks connection)))

;;; Hack:

Index: beirc/message-display.lisp diff -u beirc/message-display.lisp:1.4 beirc/message-display.lisp:1.5 --- beirc/message-display.lisp:1.4 Fri Sep 23 11:52:40 2005 +++ beirc/message-display.lisp Fri Sep 23 23:31:27 2005 @@ -101,7 +101,7 @@ (incf column)) (terpri))

-(defmethod print-message ((message irc:IRC-PRIVMSG-MESSAGE) receiver) +(defun print-privmsg-like-message (message receiver start-string end-string) (with-drawing-options (*standard-output* :ink (if (string-equal "localhost" (irc:host message)) @@ -112,10 +112,16 @@ (*standard-output* (if (message-from-focused-nick-p message receiver) :bold :roman)) (formatting-message (t message receiver) - ((format t "<") - (present (irc:source message) 'nickname) - (format t ">")) - ((format-message* (irc:trailing-argument message)))))))) + ((write-string start-string *standard-output*) + (present (irc:source message) 'nickname) + (write-string end-string *standard-output*)) + ((format-message* (irc:trailing-argument message)))))))) + +(defmethod print-message ((message irc:IRC-PRIVMSG-MESSAGE) receiver) + (print-privmsg-like-message message receiver "<" ">")) + +(defmethod print-message ((message irc:IRC-NOTICE-MESSAGE) receiver) + (print-privmsg-like-message message receiver "-" "-"))

(defmethod print-message ((message irc:ctcp-action-message) receiver) (let ((source (cl-irc:source message)) @@ -161,6 +167,11 @@ (present (irc:source message) 'nickname) (format t " left ~A: ~A" (first (irc:arguments message)) (irc:trailing-argument message))))))

+(defmethod print-message (message receiver) + (formatting-message (t message receiver) + ((format t "!!! ~A" (irc:source message))) + ((with-drawing-options (*standard-output* :ink +red+ :text-size :small) + (format t "args: ~A :~A" (irc:arguments message) (irc:trailing-argument message))))))

(defgeneric preamble-length (message) (:method ((message irc:irc-privmsg-message))