Update of /project/beirc/cvsroot/beirc In directory clnet:/tmp/cvs-serv18901
Modified Files: application.lisp events.lisp message-processing.lisp receivers.lisp Log Message: Experimental single-thread support. Beware. Please test.
--- /project/beirc/cvsroot/beirc/application.lisp 2006/04/03 17:32:37 1.73 +++ /project/beirc/cvsroot/beirc/application.lisp 2006/04/04 18:37:28 1.74 @@ -86,6 +86,7 @@ :interactor :height 72) (pointer-doc :pointer-documentation) + (status-bar :application :display-function 'beirc-status-display @@ -111,7 +112,6 @@ (vertically () (with-tab-layout ('receiver-pane :name 'query) ("*Not Connected*" server 'receiver-pane)) - ;; (68 io) ;; no drop-shadow prompt (make-pane 'clim-extensions:box-adjuster-gadget) io (20 pointer-doc) @@ -189,7 +189,8 @@ (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" + (processes-supported-p) ; don't display time if threads are not supported hours minutes (current-nickname) (away-status *application-frame* (current-connection *application-frame*)) @@ -274,7 +275,7 @@ ;; Figure out if we are scrolled to the bottom. (let* ((receiver (receiver event)) (pane (actual-application-pane (pane receiver))) - (next-event (event-peek (frame-top-level-sheet frame)))) + (next-event (and (processes-supported-p) (event-peek (frame-top-level-sheet frame))))) (with-pane-kept-scrolled-to-bottom (pane) (update-drawing-options receiver) ;; delay redisplay until this is the last event in the queue @@ -295,18 +296,20 @@
;;;
-(defun beirc (&key (new-process t)) +(defun beirc (&key (new-process (processes-supported-p))) (let* ((syms '(*package* *trace-output*)) (vals (mapcar #'symbol-value syms)) (program (lambda () (progv syms vals (let* ((frame (make-application-frame 'beirc)) - (ticker-process (clim-sys:make-process (lambda () (ticker frame)) - :name "Beirc Ticker"))) + (ticker-process (when (processes-supported-p) + (clim-sys:make-process (lambda () (ticker frame)) + :name "Beirc Ticker")))) (setf *beirc-frame* frame) (load-user-init-file) (run-frame-top-level frame) - (clim-sys:destroy-process ticker-process) + (when (processes-supported-p) + (clim-sys:destroy-process ticker-process)) (disconnect-all frame "Client Quit")))))) (cond (new-process @@ -330,7 +333,7 @@ (let ((message-to-me-p (message-directed-to-me-p message)) (interesting-message-p (interesting-message-p message))) (setf (messages receiver) - (append (messages receiver) (list message))) + (append (messages receiver) (list message))) (unless (eql receiver (current-receiver frame)) (when interesting-message-p (incf (unseen-messages receiver))) @@ -347,8 +350,8 @@ (positions-mentioning-user receiver))))) (run-post-message-hooks message frame receiver :message-directed-to-me message-to-me-p :message-interesting-p interesting-message-p) - (queue-event (frame-top-level-sheet frame) - (make-instance 'foo-event :sheet frame :receiver receiver)) + (queue-beirc-event frame + (make-instance 'foo-event :sheet frame :receiver receiver)) nil))
(defun post-message (frame message) @@ -899,14 +902,16 @@ (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 - (irc-event-loop frame connection) - (disconnect () - :report "Terminate this connection" - (disconnect connection frame "Client Disconnect")))) - :name "IRC Message Muffling Loop")) + (if (processes-supported-p) + (setf (connection-process *application-frame* connection) + (clim-sys:make-process #'(lambda () + (restart-case + (irc-event-loop frame connection) + (disconnect () + :report "Terminate this connection" + (disconnect connection frame "Client Disconnect")))) + :name "IRC Message Muffling Loop")) + (irc:start-background-message-handler connection)) (setf success t)) (unless success (disconnect connection frame "Client error."))))))) --- /project/beirc/cvsroot/beirc/events.lisp 2006/03/12 09:48:57 1.1 +++ /project/beirc/cvsroot/beirc/events.lisp 2006/04/04 18:37:28 1.2 @@ -19,4 +19,13 @@ (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))) \ No newline at end of file + (receiver :initarg :receiver :reader receiver))) + +(defun processes-supported-p () + (processp (current-process))) + +(defun queue-beirc-event (frame event) + (if (processes-supported-p) + (queue-event (frame-top-level-sheet frame) + event) + (handle-event frame event))) \ No newline at end of file --- /project/beirc/cvsroot/beirc/message-processing.lisp 2006/03/27 13:46:47 1.6 +++ /project/beirc/cvsroot/beirc/message-processing.lisp 2006/04/04 18:37:28 1.7 @@ -73,9 +73,3 @@ and set them up accordingly." (declare (ignore message)) (join-missing-channels *application-frame*)) - -(define-beirc-hook meme-whois-hook ((message irc:irc-rpl_welcome-message)) - "When a connection is established, look up the channels on -which the meme log bot is listening." - (when (not (null *meme-log-bot-nick*)) - (irc:whois (irc:connection message) *meme-log-bot-nick*))) \ No newline at end of file --- /project/beirc/cvsroot/beirc/receivers.lisp 2006/04/02 20:43:20 1.24 +++ /project/beirc/cvsroot/beirc/receivers.lisp 2006/04/04 18:37:29 1.25 @@ -103,7 +103,7 @@ (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))) + (queue-beirc-event frame (make-instance 'new-sheet-event :sheet frame :creator creator))) (setf (gethash (list connection normalized-name) (receivers frame)) receiver) receiver))))