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