[beirc-cvs] CVS beirc
afuchs
afuchs at common-lisp.net
Sun Mar 12 09:48:57 UTC 2006
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 at A-~2,1,0,'0 at A-~2,1,0,'0 at A, ~2,1,0,'0 at A:~2,1,0,'0 at A:~2,1,0,'0 at 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)))
More information about the Beirc-cvs
mailing list