[beirc-cvs] CVS update: beirc/beirc.lisp beirc/message-display.lisp
Andreas Fuchs
afuchs at common-lisp.net
Sat Sep 24 09:14:05 UTC 2005
Update of /project/beirc/cvsroot/beirc
In directory common-lisp.net:/tmp/cvs-serv8786
Modified Files:
beirc.lisp message-display.lisp
Log Message:
Fix /quit, /disconnect commands and quitting the irc worker thread.
* /quit, /disconnect and later /connect commands now work, hopefully in
all combinations.
* This change also introduces a level of thread hygiene. When beirc's
application frame exits, every thread (except the clim/clx listener
thread) should be killed as well.
Date: Sat Sep 24 11:14:04 2005
Author: afuchs
Index: beirc/beirc.lisp
diff -u beirc/beirc.lisp:1.18 beirc/beirc.lisp:1.19
--- beirc/beirc.lisp:1.18 Sat Sep 24 01:22:50 2005
+++ beirc/beirc.lisp Sat Sep 24 11:14:03 2005
@@ -190,7 +190,6 @@
(setf (messages-directed-to-me receiver) 0)
(update-drawing-options receiver))))
-
(defun raise-receiver (receiver)
(setf (unseen-messages receiver) 0)
(setf (messages-directed-to-me receiver) 0)
@@ -211,6 +210,7 @@
(define-application-frame beirc (redisplay-frame-mixin
standard-application-frame)
((connection :initform nil :reader current-connection)
+ (connection-process :initform nil :accessor connection-process)
(nick :initform nil)
(ignored-nicks :initform nil)
(receivers :initform (make-hash-table :test #'equal) :accessor receivers)
@@ -347,11 +347,12 @@
(clim-sys:make-process
(lambda ()
(progv syms vals
- (let ((frame (make-application-frame 'beirc)))
+ (let* ((frame (make-application-frame 'beirc))
+ (ticker-process (clim-sys:make-process (lambda () (ticker frame))
+ :name "Beirc Ticker")))
(setf *beirc-frame* frame)
- (clim-sys:make-process (lambda () (ticker frame))
- :name "Beirc Ticker")
- (run-frame-top-level frame))))))))
+ (run-frame-top-level frame)
+ (clim-sys:destroy-process ticker-process))))))))
(defun message-directed-to-me-p (frame message)
(let ((my-nick (slot-value frame 'nick))
@@ -372,11 +373,16 @@
(make-instance 'foo-event :sheet frame :receiver receiver))
nil))
+;;; XXX: ticker continues to run even if the frame is no longer active
+;;; or on the display.
(defun ticker (frame)
- (loop
- (clim-internals::event-queue-prepend (climi::frame-event-queue frame)
- (make-instance 'bar-event :sheet frame))
- (sleep 1)))
+ (handler-case
+ (loop
+ (clim-internals::event-queue-prepend (climi::frame-event-queue frame)
+ (make-instance 'bar-event :sheet frame))
+ (sleep 1))
+ (frame-exit ()
+ nil)))
(define-presentation-type nickname ())
(define-presentation-type ignored-nickname (nickname))
@@ -406,7 +412,8 @@
(find-in-tab-panes-list object 'tab-layout-pane)))
(defun nick-equals-my-nick-p (nickname)
- (and *application-frame*
+ (and (not (null *application-frame*))
+ (not (null (slot-value *application-frame* 'connection)))
(equal (irc:normalize-nickname (current-connection *application-frame*)
(slot-value *application-frame* 'nick))
(irc:normalize-nickname (current-connection *application-frame*)
@@ -440,7 +447,13 @@
(remove who (current-focused-nicks) :test #'string=)))
(define-beirc-command (com-quit :name t) ((reason 'mumble :prompt "reason"))
- (irc:quit (current-connection *application-frame*) reason))
+ (when (current-connection *application-frame*)
+ (quit *application-frame* reason))
+ (frame-exit *application-frame*))
+
+(define-beirc-command (com-disconnect :name t) ((reason 'mumble :prompt "reason"))
+ (when (current-connection *application-frame*)
+ (quit *application-frame* reason)))
(defun target (&optional (*application-frame* *application-frame*))
(or (current-query)
@@ -527,9 +540,45 @@
(find-pane-named frame 'server)
:add-pane-p nil)
(setf (gethash "*Server*" (receivers frame)) (server-receiver frame))
- (clim-sys:make-process #'(lambda ()
- (irc-event-loop frame connection))
- :name "IRC Message Muffling Loop") )))))
+ (setf (connection-process *application-frame*)
+ (clim-sys:make-process #'(lambda ()
+ (unwind-protect
+ (irc-event-loop frame connection)
+ (disconnect frame)))
+ :name "IRC Message Muffling Loop")) )))))
+
+(defun disconnect (frame)
+ (let ((old-nickname (slot-value frame 'nick)))
+ (raise-receiver (server-receiver frame))
+ (post-message frame
+ (make-instance 'irc:irc-quit-message
+ :received-time (get-universal-time)
+ :connection :local
+ :trailing-argument
+ (format nil "You disconnected from IRC")
+ :arguments nil
+ :command "QUIT"
+ :host "localhost" ;###
+ :user "localuser" ;###
+ :source old-nickname))
+ (when (and (connection-process frame)
+ (not (eql (clim-sys:current-process)
+ (connection-process frame))))
+ (destroy-process (connection-process frame)))
+ (setf (slot-value frame 'connection) nil
+ (connection-process frame) nil
+ (slot-value frame 'nick) nil)))
+
+(defun quit (frame reason)
+ (raise-receiver (server-receiver frame))
+ (irc:quit (current-connection frame) reason)
+ (when (and (connection-process frame)
+ (not (eql (clim-sys:current-process)
+ (connection-process frame))))
+ (destroy-process (connection-process frame)))
+ (setf (slot-value frame 'connection) nil
+ (connection-process frame) nil
+ (slot-value frame 'nick) nil))
(defmethod clim:read-frame-command ((frame beirc) &key (stream *standard-input*))
(multiple-value-prog1
@@ -544,12 +593,10 @@
(window-clear stream)))
(defun restart-beirc ()
- (let ((m (current-messages)))
- (clim-sys:destroy-process *gui-process*)
- (setf *beirc-frame* nil)
- (beirc)
- (clim-sys:process-wait "waiting for beirc" (lambda () *beirc-frame*))
- (setf (current-messages) m)))
+ (clim-sys:destroy-process *gui-process*)
+ (setf *beirc-frame* nil)
+ (beirc)
+ (clim-sys:process-wait "waiting for beirc" (lambda () *beirc-frame*)))
;;;;;;;;;
Index: beirc/message-display.lisp
diff -u beirc/message-display.lisp:1.6 beirc/message-display.lisp:1.7
--- beirc/message-display.lisp:1.6 Sat Sep 24 01:04:21 2005
+++ beirc/message-display.lisp Sat Sep 24 11:14:03 2005
@@ -103,7 +103,8 @@
(present-url word%))
((or
(nick-equals-my-nick-p word%)
- (irc:find-user (current-connection *application-frame*) word%))
+ (and (current-connection *application-frame*)
+ (irc:find-user (current-connection *application-frame*) word%)))
(present word% 'nickname))
(t (write-string word%)))
(write-string stripped-punctuation)))
More information about the Beirc-cvs
mailing list