[beirc-cvs] CVS beirc
afuchs
afuchs at common-lisp.net
Sat Feb 25 15:22:23 UTC 2006
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 `(, at 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.
More information about the Beirc-cvs
mailing list