Update of /project/beirc/cvsroot/beirc In directory clnet:/tmp/cvs-serv16258

Modified Files: application.lisp message-display.lisp presentations.lisp receivers.lisp Log Message: Multi-server support; also, make mode change printing more robust.

There's a bug on /quit that I couldn't figure out; users are advised to use the terminate-thread restart for now (or help me find the bug (-:)

Details:

* /connect allows opening more than one connection now. * (current-connection frame) now returns the current connection of the currently selected receiver. * this means that every command operates on the current connection now. * (except /quit, which terminates all connections and closes the window)

--- /project/beirc/cvsroot/beirc/application.lisp 2006/02/23 19:43:29 1.40 +++ /project/beirc/cvsroot/beirc/application.lisp 2006/02/25 15:22:22 1.41 @@ -70,12 +70,11 @@

(define-application-frame beirc (redisplay-frame-mixin standard-application-frame) - ((connection :initform nil :reader current-connection) - (connection-process :initform nil :accessor connection-process) + ((connection-processes :initform nil :accessor connection-processes) (nick :initform nil) (ignored-nicks :initform nil) (receivers :initform (make-hash-table :test #'equal) :accessor receivers) - (server-receiver :initform (make-paneless-receiver "*Server*") :reader server-receiver) + (server-receivers :initform nil :reader server-receivers) (tab-panes-to-receivers :initform (make-hash-table :test #'equal) :accessor tab-panes-to-receivers)) (:panes (io @@ -105,7 +104,7 @@ (default (vertically () (with-tab-layout ('receiver-pane :name 'query) - ("*Server*" server 'receiver-pane)) + ("*Not Connected*" server 'receiver-pane)) ;; (68 io) ;; no drop-shadow prompt (72 io) (20 pointer-doc) @@ -121,6 +120,26 @@ receiver nil)))

+(defmethod current-connection ((frame beirc)) + (when (current-receiver frame) + (connection (current-receiver frame)))) + +(defmethod server-receiver ((frame beirc) + &optional (connection (current-connection *application-frame*))) + (cdr (assoc connection (server-receivers frame) :test #'connection=))) + +(defmethod (setf server-receiver) (newval (frame beirc) + &optional (connection (current-connection *application-frame*))) + (pushnew (cons connection newval) (slot-value frame 'server-receivers) + :key #'car :test #'connection=)) + +(defmethod connection-process ((frame beirc) connection) + (cdr (assoc connection (connection-processes frame) :test #'connection=))) + +(defmethod (setf connection-process) (newval (frame beirc) connection) + (pushnew (cons connection newval) (slot-value frame 'connection-processes) + :key #'car :test #'connection=)) + (defvar *gui-process* nil)

(defvar *beirc-frame*) @@ -242,9 +261,8 @@ (setf *beirc-frame* frame) (load-user-init-file) (run-frame-top-level frame) - (unless (null (current-connection frame)) - (irc:quit (current-connection frame) "Client Quit")) - (clim-sys:destroy-process ticker-process)))))))) + (clim-sys:destroy-process ticker-process) + (disconnect-all frame "Client Quit"))))))))

(defun message-directed-to-me-p (frame message) (irc:destructuring-arguments (&last body) message @@ -314,7 +332,8 @@ (format nil "IDENTIFY ~A" password)))

(define-beirc-command (com-query :name t) ((nick 'nickname :prompt "who")) - (raise-receiver (intern-receiver nick *application-frame* :query nick))) + (raise-receiver (intern-receiver nick (current-connection *application-frame*) + *application-frame* :query nick)))

(define-beirc-command (com-raise :name t) ((receiver 'receiver :prompt "receiver")) (raise-receiver receiver)) @@ -413,7 +432,7 @@ trailing-argument) (make-instance message-type :received-time (get-universal-time) - :connection :local + :connection (current-connection *application-frame*) :arguments `(,@arguments ,trailing-argument) :command command :HOST "localhost" @@ -467,13 +486,12 @@ (irc:away (current-connection *application-frame*) ""))

(define-beirc-command (com-quit :name t) ((reason 'mumble :prompt "reason")) - (when (current-connection *application-frame*) - (disconnect *application-frame* reason)) + (disconnect-all *application-frame* reason) (frame-exit *application-frame*))

(define-beirc-command (com-disconnect :name t) ((reason 'mumble :prompt "reason")) (when (current-connection *application-frame*) - (disconnect *application-frame* reason))) + (disconnect (current-connection *application-frame*) *application-frame* reason)))

(define-beirc-command (com-switch-timestamp-orientation :name t) () (setf *timestamp-column-orientation* (if (eql *timestamp-column-orientation* :left) @@ -505,15 +523,14 @@ (com-msg (target) what))

(define-beirc-command (com-me :name t) ((what 'mumble :prompt nil)) - (with-slots (connection) *application-frame* - (let ((m (make-fake-irc-message 'irc:ctcp-action-message + (let ((m (make-fake-irc-message 'irc:ctcp-action-message :trailing-argument (format nil "~AACTION ~A~A" (code-char 1) what (code-char 1)) :arguments (list (target)) :command "PRIVMSG"))) ;### (post-message *application-frame* m) - (irc:privmsg connection (target) - (format nil "~AACTION ~A~A" (code-char 1) what (code-char 1)))))) + (irc:privmsg (current-connection *application-frame*) (target) + (format nil "~AACTION ~A~A" (code-char 1) what (code-char 1)))))

(define-beirc-command (com-nick :name t) ((new-nick 'string :prompt "new nick")) (setf (slot-value *application-frame* 'nick) new-nick) ;This is _not_ the way to do it. @@ -697,9 +714,16 @@ (format nil "*!*@~A" (irc:hostname (irc:find-user (current-connection *application-frame*) object))))

(define-beirc-command (com-join :name t) ((channel 'channel :prompt "channel")) - (raise-receiver (intern-receiver channel *application-frame* :channel channel)) + (raise-receiver (intern-receiver channel (current-connection *application-frame*) + *application-frame* :channel channel)) (irc:join (current-connection *application-frame*) channel))

+(defun connection= (connection1 connection2) + ;; TODO: should compare by network, not by server name. + ;; TODO: also, there is no port that we could compare. + (and (equal (irc:nickname (irc:user connection1)) (irc:nickname (irc:user connection2))) + (equal (irc:server-name connection1) (irc:server-name connection2)))) + (define-beirc-command (com-connect :name t) ((server 'string :prompt "Server") &key @@ -707,54 +731,47 @@ (pass 'string :prompt "Password" :default nil) (port 'number :prompt "Port" :default irc::*default-irc-server-port*)) (let ((success nil)) - (cond ((current-connection *application-frame*) - (format *query-io* "You are already connected.~%")) - (t - (setf (slot-value *application-frame* 'connection) - (apply #'irc:connect - :nickname nick :server server :connection-type 'beirc-connection :port port - (if (null pass) - nil - `(:password ,pass)))) - (unwind-protect - (progn - (setf (irc:client-stream (current-connection *application-frame*)) - (make-broadcast-stream)) - (setf (slot-value *application-frame* 'nick) nick) - (let ((connection (current-connection *application-frame*))) - (let ((frame *application-frame*)) - (loop for receiver being the hash-values of (receivers frame) - if (channelp (channel receiver)) - do (irc:join connection (channel receiver))) - (join-missing-channels frame) - (initialize-receiver-with-pane (server-receiver frame) frame - (find-pane-named frame 'server) - :add-pane-p nil) - (setf (gethash "*Server*" (receivers frame)) (server-receiver frame)) - (setf (connection-process *application-frame*) - (clim-sys:make-process #'(lambda () - (restart-case - (irc-event-loop frame connection) - (disconnect () - :report "Disconnect from IRC" - (disconnect frame "Client Disconnect")))) - :name "IRC Message Muffling Loop")))) - (setf success t)) - (unless success - (disconnect *application-frame* "Client error."))))))) + (let* ((frame *application-frame*) + (connection (apply #'irc:connect + :nickname nick :server server :connection-type 'beirc-connection :port port + (if (null pass) + nil + `(:password ,pass)))) + (server-receiver (intern-receiver (format nil "~A on ~A:~A" nick server port) connection frame))) + (unwind-protect + (progn + (setf (irc:client-stream connection) (make-broadcast-stream)) + (setf (slot-value *application-frame* 'nick) nick) + (when (tab-layout:find-in-tab-panes-list (find-pane-named frame 'server) + (find-pane-named frame 'query)) + (tab-layout:remove-pane (find-pane-named frame 'server) + (find-pane-named frame 'query))) + (setf (server-receiver frame connection) server-receiver) + (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")) + (setf success t)) + (unless success + (disconnect connection frame "Client error."))))))

-(defun disconnect (frame reason) +(defun disconnect (connection frame reason) (raise-receiver (server-receiver frame)) - (irc:quit (current-connection frame) reason) - (when (and (connection-process frame) + (irc:quit connection reason) + (when (and (connection-process frame connection) (not (eql (clim-sys:current-process) - (connection-process frame)))) - (destroy-process (connection-process frame))) - (setf (slot-value frame 'connection) nil - (connection-process frame) nil + (connection-process frame connection)))) + (destroy-process (connection-process frame connection))) + (setf (connection-process frame connection) nil (slot-value frame 'nick) nil))

- +(defun disconnect-all (frame reason) + (loop for (conn . receiver) in (server-receivers frame) + do (disconnect (connection receiver) frame reason)))

(defmethod clim:read-frame-command ((frame beirc) &key (stream *standard-input*)) (multiple-value-prog1 @@ -768,7 +785,7 @@ (clim:read-gesture :stream stream) (clim:accept 'clim:command :stream stream :prompt nil)) (t - (list 'com-say (accept 'mumble :prompt nil :stream stream)))) + (list 'com-say (accept 'mumble :history 'mumble :prompt nil :stream stream)))) (setf *last-input-line* nil))) (command (let ((buffer (stream-input-buffer stream))) --- /project/beirc/cvsroot/beirc/message-display.lisp 2006/02/22 16:30:50 1.32 +++ /project/beirc/cvsroot/beirc/message-display.lisp 2006/02/25 15:22:22 1.33 @@ -396,8 +396,8 @@ target mode)))

(defmethod print-mode-change (target op mode (user irc:user)) - (format t "~A~A:" op (mode-symbol-to-char target mode)) - (present (irc:nickname user) 'nickname)) + (format t "~A~A:" op (mode-symbol-to-char target mode)) + (present (irc:nickname user) 'nickname))

(defmethod print-mode-change (target op (mode (eql :limit)) arg) (format t "~A~A" op (mode-symbol-to-char target mode)) @@ -405,12 +405,6 @@ (write-char #:) (present arg 'number)))

-(defmethod print-mode-change (target op (mode (eql :key)) arg) - (format t "~A~A" op (mode-symbol-to-char target mode)) - (when (not (null arg)) - (write-char #:) - (present arg 'string))) - (macrolet ((define-mode-change-with-hostmask-printer (&rest modes) `(progn ,@(loop for mode in modes @@ -419,8 +413,8 @@ (present mask 'hostmask)))))) (define-mode-change-with-hostmask-printer :ban :invite :except))

-(defmethod print-mode-change (target op mode (arg (eql nil))) - (format t "~A~A" op (mode-symbol-to-char target mode))) +(defmethod print-mode-change (target op mode arg) + (format t "~A~A~:[~;:~A~]" op (mode-symbol-to-char target mode) arg arg))

(defmethod print-message ((message irc:irc-mode-message) receiver) (case (length (irc:arguments message)) --- /project/beirc/cvsroot/beirc/presentations.lisp 2006/01/27 17:18:04 1.8 +++ /project/beirc/cvsroot/beirc/presentations.lisp 2006/02/25 15:22:22 1.9 @@ -88,7 +88,7 @@

(defun nick-equals-my-nick-p (nickname) (and (not (null *application-frame*)) - (not (null (slot-value *application-frame* 'connection))) + (not (null (current-connection *application-frame*))) (equal (irc:normalize-nickname (current-connection *application-frame*) (slot-value *application-frame* 'nick)) (irc:normalize-nickname (current-connection *application-frame*) --- /project/beirc/cvsroot/beirc/receivers.lisp 2006/02/22 16:30:50 1.16 +++ /project/beirc/cvsroot/beirc/receivers.lisp 2006/02/25 15:22:22 1.17 @@ -6,6 +6,7 @@ (all-unseen-messages :accessor all-unseen-messages :initform 0) (messages-directed-to-me :accessor messages-directed-to-me :initform 0) (channel :reader channel :initform nil :initarg :channel) + (connection :accessor connection :initarg :connection) (query :reader query :initform nil :initarg :query) ;; <- XXX: remove this. (focused-nicks :accessor focused-nicks :initform nil) (title :reader title :initarg :title) @@ -59,17 +60,18 @@ (change-space-requirements pane))) (setf (gethash (tab-pane receiver) (tab-panes-to-receivers frame)) receiver))

-(defun find-receiver (name frame) - (gethash (irc:normalize-channel-name (slot-value frame 'connection) name) +(defun find-receiver (name connection frame) + (gethash (list connection (irc:normalize-channel-name connection name)) (receivers frame)))

-(defun intern-receiver (name frame &rest initargs) - (let* ((normalized-name (irc:normalize-channel-name (slot-value frame 'connection) name)) - (rec (find-receiver name frame))) +(defun intern-receiver (name connection frame &rest initargs) + (let* ((normalized-name (irc:normalize-channel-name connection name)) + (rec (find-receiver name connection frame))) (if rec rec (let ((*application-frame* frame)) - (let ((receiver (apply 'make-paneless-receiver normalized-name initargs))) + (let ((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*) @@ -80,7 +82,7 @@ :display-time nil :min-width 600 :min-height 800 :incremental-redisplay t))) - (setf (gethash normalized-name (receivers frame)) receiver) + (setf (gethash (list connection normalized-name) (receivers frame)) receiver) receiver)))))

(defun remove-receiver (receiver frame) @@ -115,19 +117,19 @@ `(defmethod receiver-for-message ((message ,message-type) frame) (let* ((mynick (irc:normalize-nickname (current-connection frame) (slot-value frame 'nick))) - (nominal-target (irc:normalize-channel-name (slot-value frame 'connection) + (nominal-target (irc:normalize-channel-name (irc:connection message) (first (irc:arguments message)))) (target (if (equal nominal-target mynick) (irc:source message) nominal-target))) - (cond ((find-receiver target frame) - (intern-receiver target frame :channel target)) + (cond ((find-receiver target (irc:connection message) frame) + (intern-receiver target (irc:connection message) frame :channel target)) ((or (global-notice-p message nominal-target frame) (and (from-network-service-p (irc:source message) frame) (equal nominal-target mynick))) - (server-receiver frame)) + (server-receiver frame (irc:connection message))) (t - (intern-receiver target frame :channel target))))))) + (intern-receiver target (irc:connection message) frame :channel target))))))) (define-privmsg-receiver-lookup irc:irc-privmsg-message) (define-privmsg-receiver-lookup irc:ctcp-action-message) (define-privmsg-receiver-lookup irc:irc-notice-message)) @@ -136,7 +138,7 @@ `(defmethod receiver-for-message ((message ,message-type) frame) (remove nil (mapcar (lambda (channel) - (find-receiver (irc:name channel) frame)) + (find-receiver (irc:name channel) (irc:connection message) frame)) (let ((user (irc:find-user (current-connection frame) (irc:source message)))) (when user @@ -160,7 +162,7 @@ (let ((target ,(if (numberp nth) `(nth ,nth (irc:arguments message)) `(first (last (irc:arguments message)))))) - (intern-receiver target frame :channel target)))))))) + (intern-receiver target (irc:connection message) frame :channel target)))))))) (define-nth-arg-message-receiver-lookup (0 irc:irc-topic-message irc:irc-kick-message) (1 irc:irc-rpl_topic-message irc:irc-rpl_topicwhotime-message @@ -172,17 +174,17 @@ (defmethod receiver-for-message ((message irc:irc-part-message) frame) (let ((target (first (irc:arguments message)))) (if (and - (null (find-receiver target frame)) + (null (find-receiver target (irc:connection message) frame)) (string= (irc:source message) (slot-value frame 'nick))) - (server-receiver frame) ; don't re-open previously closed channels. - (intern-receiver target frame :channel target)))) + (server-receiver frame (irc:connection message)) ; don't re-open previously closed channels. + (intern-receiver target (irc:connection message) frame :channel target))))

(defmethod receiver-for-message ((message irc:irc-mode-message) frame) (case (length (irc:arguments message)) - (1 (server-receiver frame)) + (1 (server-receiver frame (irc:connection message))) (t (destructuring-bind (channel modes &rest args) (irc:arguments message) (declare (ignore modes args)) - (intern-receiver channel frame :channel channel))))) + (intern-receiver channel (irc:connection message) frame :channel channel)))))

(macrolet ((define-current-receiver-message-types (&rest mtypes) `(progn @@ -226,7 +228,7 @@ (defmethod receiver-for-message ((message irc:irc-message) frame) #+or ; comment out to debug on uncaught messages. (break) - (server-receiver frame)) + (server-receiver frame (irc:connection message)))

;; TODO: more receiver-for-message methods.