Update of /project/beirc/cvsroot/beirc In directory clnet:/tmp/cvs-serv22818

Modified Files: application.lisp beirc.asd message-display.lisp receivers.lisp Added Files: events.lisp Log Message: Speedup redisplay; time display; factor out events; robustify pane creation.

* The foo-event handler now calls redisplay only if it is invoked for the last foo-event for the current event's receiver. This speeds up redisplay considerably if many messages come in simultaneously. * Added time/date display for some message types * Moved event definitions to events.lisp * Pane creation doesn't happen in the irc listener thread anymore, but is triggered in the ui thread via a new-sheet-event.

--- /project/beirc/cvsroot/beirc/application.lisp 2006/03/06 17:53:58 1.52 +++ /project/beirc/cvsroot/beirc/application.lisp 2006/03/12 09:48:57 1.53 @@ -75,6 +75,7 @@ (define-application-frame beirc (redisplay-frame-mixin standard-application-frame) ((connection-processes :initform nil :accessor connection-processes) + (ui-process :initform (current-process) :accessor ui-process) (ignored-nicks :initform nil) (receivers :initform (make-hash-table :test #'equal) :accessor receivers) (server-receivers :initform nil :reader server-receivers) @@ -168,7 +169,7 @@ (with-text-family (t :sans-serif) (multiple-value-bind (seconds minutes hours) (decode-universal-time (get-universal-time)) seconds - (format t "~2,'0D:~2,'0D ~A~:[~;(away)~] on ~A~@[ speaking to ~A~]~100T~D messages" + (format t "~2,'0D:~2,'0D ~A~:[~;(away)~] ~@[on ~A~]~@[ speaking to ~A~]~100T~D messages" hours minutes (current-nickname) (away-status *application-frame* (current-connection *application-frame*)) @@ -199,23 +200,6 @@ ;; "~:@>") ;; prefix)))

- -;;; Here comes the trick: - -;;; Although I would pretty much prefer an implementation of CLIM -;;; which is thread safe, I figure we better go through the central -;;; event loop. We define a new event class, subclass of -;;; WINDOW-MANAGER-EVENT, and when ever we want to update the display -;;; we send it to the frame. - -(defclass foo-event (clim:window-manager-event) - ((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) - ((sheet :initarg :sheet :reader event-sheet))) - ;;;

(defun pane-scrolled-to-bottom-p (pane) @@ -245,14 +229,25 @@ (redraw-receiver receiver)) (receivers *application-frame*))))

+;;; event handling methods + +(defmethod handle-event ((frame beirc) (event new-sheet-event)) + (funcall (sheet-creation-closure event) frame)) + (defmethod handle-event ((frame beirc) (event foo-event)) ;; Hack: ;; Figure out if we are scrolled to the bottom. (let* ((receiver (receiver event)) - (pane (actual-application-pane (pane receiver)))) + (pane (actual-application-pane (pane receiver))) + (next-event (event-peek (frame-top-level-sheet frame)))) (let ((btmp (pane-scrolled-to-bottom-p pane))) - (setf (pane-needs-redisplay pane) t) - (redisplay-frame-panes frame) + (update-drawing-options receiver) + ;; delay redisplay until this is the last event in the queue + ;; (for this event's receiver). + (unless (and (typep next-event 'foo-event) + (eql (receiver next-event) receiver)) + (setf (pane-needs-redisplay pane) t) + (redisplay-frame-panes frame)) (when btmp (scroll-pane-to-bottom pane))) (medium-force-output (sheet-medium pane)) ;### )) @@ -299,10 +294,8 @@ (when (message-directed-to-me-p message) (incf (messages-directed-to-me receiver))) (incf (all-unseen-messages receiver))) - (update-drawing-options receiver) - (clim-internals::event-queue-prepend - (climi::frame-event-queue frame) - (make-instance 'foo-event :sheet frame :receiver receiver)) + (queue-event (frame-top-level-sheet frame) + (make-instance 'foo-event :sheet frame :receiver receiver)) nil)

(defun post-message (frame message) @@ -776,6 +769,7 @@ (tab-layout:remove-pane (find-pane-named frame 'server) (find-pane-named frame 'query))) (setf (server-receiver frame connection) server-receiver) + (setf (ui-process *application-frame*) (current-process)) (setf (connection-process *application-frame* connection) (clim-sys:make-process #'(lambda () (restart-case --- /project/beirc/cvsroot/beirc/beirc.asd 2006/02/26 18:41:21 1.6 +++ /project/beirc/cvsroot/beirc/beirc.asd 2006/03/12 09:48:57 1.7 @@ -9,8 +9,9 @@ :depends-on (:mcclim :cl-irc :split-sequence :tab-layout) :components ((:file "package") (:file "variables" :depends-on ("package")) - (:file "receivers" :depends-on ("package" "variables")) + (:file "events" :depends-on ("package")) + (:file "receivers" :depends-on ("package" "variables" "events")) (:file "presentations" :depends-on ("package" "variables" "receivers")) (:file "message-display" :depends-on ("package" "variables" "presentations")) - (:file "application" :depends-on ("package" "variables" "presentations" "receivers")) + (:file "application" :depends-on ("package" "variables" "presentations" "events" "receivers")) (:file "message-processing" :depends-on ("package" "variables" "receivers" "application")))) \ No newline at end of file --- /project/beirc/cvsroot/beirc/message-display.lisp 2006/03/02 21:46:49 1.38 +++ /project/beirc/cvsroot/beirc/message-display.lisp 2006/03/12 09:48:57 1.39 @@ -224,6 +224,8 @@ (irc:irc-rpl_unaway-message))))

(defmethod print-message (message receiver) + ;; default message if we don't know how to render a message. + #+(or) (break "~S" message) ; uncomment to debug (irc:destructuring-arguments (&whole args &last body) message (formatting-message (t message receiver) ((format t "!!! ~A" (irc:source message))) @@ -302,7 +304,7 @@ ((with-drawing-options (*standard-output* :ink +gray33+ :text-size :small) (present nickname 'nickname) (format-message* (format nil " is away: ~A" away-msg) - :start-length (length (second (irc:arguments message))))))))) + :start-length (length nickname)))))))

(defmethod print-message ((message irc:irc-rpl_whoisidentified-message) receiver) (irc:destructuring-arguments (me nickname body) message @@ -312,7 +314,29 @@ ((with-drawing-options (*standard-output* :ink +gray33+ :text-size :small) (present nickname 'nickname) (write-char #\Space) - (format-message* body :start-length (length (second (irc:arguments message))))))))) + (format-message* body :start-length (length nickname))))))) + +(defun unix-epoch-to-universal-time (epoch-time) + (+ epoch-time 2208988800 ; seconds between 1970-01-01 0:00 and 1900-01-01 0:00 + )) + +(defun format-unix-epoch (unix-epoch) + (multiple-value-bind (second minute hour date month year) + (decode-universal-time (unix-epoch-to-universal-time unix-epoch)) + (format nil "~4,1,0,'0@A-~2,1,0,'0@A-~2,1,0,'0@A, ~2,1,0,'0@A:~2,1,0,'0@A:~2,1,0,'0@A" + year month date hour minute second))) + +(defmethod print-message ((message irc:irc-rpl_whoisidle-message) receiver) + (irc:destructuring-arguments (me nickname idle signon &rest rest) message + (declare (ignore me rest)) + (formatting-message (t message receiver) + ((format t " ")) + ((with-drawing-options (*standard-output* :ink +gray33+ :text-size :small) + (present nickname 'nickname) + (write-char #\Space) + (format-message* (format nil "was idle ~A seconds, signed on: ~A" + idle (format-unix-epoch (parse-integer signon))) + :start-length (length nickname)))))))

;;; channel management messages

@@ -343,18 +367,25 @@ (formatting-message (t message receiver) ((format t " ")) ((with-drawing-options (*standard-output* :ink +gray33+ :text-size :small) - (if (null sender) - (format-message* (format nil "Topic for ~A: ~A" channel topic)) - (progn - (present sender 'nickname) - (format-message* (format nil " set the topic for ~A to ~A" channel topic)))))))) + (cond + ((and (null sender) (null topic)) + (format-message* (format nil "No topic for ~A" channel))) + ((null sender) + (format-message* (format nil "Topic for ~A: ~A" channel topic))) + ((null topic) + (present sender 'nickname) + (format-message* (format nil " cleared the topic of ~A" channel))) + (t + (present sender 'nickname) + (format-message* (format nil " set the topic for ~A to ~A" channel topic))))))))

(defmethod print-message ((message irc:irc-topic-message) receiver) (irc:destructuring-arguments (channel &last topic) message (print-topic receiver message (irc:source message) channel topic)))

(defmethod print-message ((message irc:irc-rpl_topic-message) receiver) - (irc:destructuring-arguments (channel &last topic) message + (irc:destructuring-arguments (target channel &optional topic) message + (declare (ignore target)) (print-topic receiver message nil channel topic)))

(defmethod print-message ((message irc:irc-rpl_topicwhotime-message) receiver) @@ -362,10 +393,9 @@ ((format t " ")) ((with-drawing-options (*standard-output* :ink +gray33+ :text-size :small) (irc:destructuring-arguments (me channel who time) message - (declare (ignore me - time ; TODO: no date display for now. - )) - (format-message* (format nil "~A topic set by ~A" channel who))))))) + (declare (ignore me)) + (format-message* (format nil "~A topic set by ~A on ~A" channel who + (format-unix-epoch (parse-integer time)))))))))

(defmethod print-message ((message irc:irc-rpl_namreply-message) receiver) (irc:destructuring-arguments (me privacy channel &last nicks) message --- /project/beirc/cvsroot/beirc/receivers.lisp 2006/03/06 10:21:28 1.21 +++ /project/beirc/cvsroot/beirc/receivers.lisp 2006/03/12 09:48:57 1.22 @@ -85,19 +85,24 @@ (rec (find-receiver name connection frame))) (if rec rec - (let ((*application-frame* frame) - (receiver (apply 'make-paneless-receiver normalized-name :connection connection - 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 - :min-width 600 :min-height 800 - :incremental-redisplay t))) + (let* ((*application-frame* frame) + (receiver (apply 'make-paneless-receiver normalized-name :connection connection + initargs)) + (creator (lambda (frame) + (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 + :min-width 600 :min-height 800 + :incremental-redisplay t))) + (update-drawing-options receiver)))) + (if (equal (current-process) (ui-process frame)) + (funcall creator frame) + (queue-event (frame-top-level-sheet frame) (make-instance 'new-sheet-event :sheet frame :creator creator))) (setf (gethash (list connection normalized-name) (receivers frame)) receiver) receiver))))

@@ -209,18 +214,21 @@ (declare (ignore modes args)) (intern-receiver channel (irc:connection message) frame :channel channel)))))

-(macrolet ((define-current-receiver-message-types (&rest mtypes) +(macrolet ((define-current-receiver-or-server-message-types (&rest mtypes) `(progn ,@(loop for mtype in mtypes collect `(defmethod receiver-for-message ((message ,mtype) frame) - (current-receiver frame)))))) - (define-current-receiver-message-types + (if (equal (connection (current-receiver frame)) (irc:connection message)) + (current-receiver frame) + (server-receiver frame (irc:connection message)))))))) + (define-current-receiver-or-server-message-types irc:irc-rpl_whoisuser-message irc:irc-rpl_whoischannels-message - irc:irc-rpl_whoisserver-message - irc:irc-rpl_whoisidentified-message - irc:irc-rpl_away-message - irc:irc-err_nosuchnick-message)) + irc:irc-rpl_whoisserver-message + irc:irc-rpl_whoisidentified-message + irc:irc-rpl_whoisidle-message + irc:irc-rpl_away-message + irc:irc-err_nosuchnick-message))

(macrolet ((define-ignore-message-types (&rest mtypes) `(progn @@ -270,10 +278,12 @@ (define-delegate current-focused-nicks focused-nicks t))

(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+))))) + (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)))

--- /project/beirc/cvsroot/beirc/events.lisp 2006/03/12 09:48:57 NONE +++ /project/beirc/cvsroot/beirc/events.lisp 2006/03/12 09:48:57 1.1 (in-package :beirc)

;;; Here comes the trick:

;;; Although I would pretty much prefer an implementation of CLIM ;;; which is thread safe, I figure we better go through the central ;;; event loop. We define a new event class, subclass of ;;; WINDOW-MANAGER-EVENT, and when ever we want to update the display ;;; we send it to the frame.

(defclass foo-event (clim:window-manager-event) ((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) ((sheet :initarg :sheet :reader event-sheet)))

(defclass new-sheet-event (clim:window-manager-event) ((sheet :initarg :sheet :reader event-sheet) (closure :initarg :creator :reader sheet-creation-closure) (receiver :initarg :receiver :reader receiver)))