[beirc-cvs] CVS beirc
afuchs
afuchs at common-lisp.net
Tue Apr 4 18:37:29 UTC 2006
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))))
More information about the Beirc-cvs
mailing list