[beirc-cvs] CVS beirc
afuchs
afuchs at common-lisp.net
Wed Apr 12 18:27:16 UTC 2006
Update of /project/beirc/cvsroot/beirc
In directory clnet:/tmp/cvs-serv25758
Modified Files:
application.lisp message-display.lisp message-processing.lisp
receivers.lisp
Log Message:
Add "reconnect" support.
* notices when connections are dropped
* offers to reconnect when the connection is dropped.
* connection setup now believes in reconnecting.
--- /project/beirc/cvsroot/beirc/application.lisp 2006/04/07 01:42:56 1.75
+++ /project/beirc/cvsroot/beirc/application.lisp 2006/04/12 18:27:16 1.76
@@ -374,9 +374,8 @@
(make-instance 'bar-event :sheet frame))
(sleep 1)))
-(defun join-missing-channels (frame)
- (let* ((connection (current-connection frame))
- (server (when connection (irc:server-name connection))))
+(defun join-missing-channels (frame &optional (connection (current-connection frame)))
+ (let* ((server (when connection (irc:server-name connection))))
(when server
(loop for join-channel in (cdr (assoc server *auto-join-alist* :test #'equal))
do (unless (gethash join-channel (receivers frame))
@@ -890,15 +889,20 @@
(nick 'string :prompt "Nick name" :default *default-nick*)
(pass 'string :prompt "Password" :default nil)
(port 'number :prompt "Port" :default irc::*default-irc-server-port*))
- (let ((success nil))
- (or (server-receiver-from-args *application-frame* server port nick)
+ (let ((success nil)
+ (maybe-server-receiver (server-receiver-from-args *application-frame* server port nick)))
+ (or (and maybe-server-receiver (connection-open-p maybe-server-receiver))
(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)))
+ (server-receiver (if maybe-server-receiver
+ (prog1 maybe-server-receiver
+ (reinit-receiver-for-new-connection maybe-server-receiver
+ connection))
+ (intern-receiver (format nil "~A on ~A:~A" nick server port) connection frame))))
(unwind-protect
(progn
(setf (irc:client-stream connection) (make-broadcast-stream))
@@ -1030,13 +1034,17 @@
(command
(save-input-line stream frame)
object)))
- (window-clear stream)))
+ (window-clear stream)))
(defun irc-event-loop (frame connection)
- (unwind-protect
- (let ((*application-frame* frame))
- (irc:read-message-loop connection))
- (irc:remove-all-hooks connection)))
+ (let ((*application-frame* frame))
+ (unwind-protect (irc:read-message-loop connection)
+ (setf (connection-open-p (server-receiver frame connection)) nil)
+ (irc:remove-all-hooks connection)
+ (irc:irc-message-event connection
+ (make-fake-irc-message 'irc-connection-closed-message
+ :command "Connnection closed"
+ :source (irc:server-name connection))))))
;;; Hack:
--- /project/beirc/cvsroot/beirc/message-display.lisp 2006/04/02 20:51:54 1.45
+++ /project/beirc/cvsroot/beirc/message-display.lisp 2006/04/12 18:27:16 1.46
@@ -494,6 +494,14 @@
(with-drawing-options (*standard-output* :ink +grey12+ :text-size :small)
(format-message* "Click here to close this tab."))))
+(defun offer-reconnect (receiver)
+ (let* ((conn (connection receiver))
+ (server (irc:server-name conn))
+ (nickname (irc:nickname (irc:user conn))))
+ (with-output-as-presentation (t `(com-connect ,server :nick ,nickname) 'command)
+ (with-drawing-options (*standard-output* :ink +grey12+ :text-size :small)
+ (format-message* (format nil "Click here to reconnect to ~A as ~A" server nickname))))))
+
(defmethod print-message ((message irc:irc-err_nosuchnick-message) receiver)
(formatting-message (t message receiver)
((format t " "))
@@ -672,6 +680,13 @@
(irc:irc-rpl_invitelist-message "INVITED: ")
(irc:irc-rpl_exceptlist-message "UNBANNED: ")))
+(defmethod print-message ((message irc-connection-closed-message) receiver)
+ (formatting-message (t message receiver)
+ ((format t " "))
+ ((with-drawing-options (*standard-output* :ink +red3+)
+ (format-message* "Connection to server closed.")
+ (offer-reconnect receiver)))))
+
;;; the display function (& utilities)
(defgeneric preamble-length (message)
--- /project/beirc/cvsroot/beirc/message-processing.lisp 2006/04/04 18:37:28 1.7
+++ /project/beirc/cvsroot/beirc/message-processing.lisp 2006/04/12 18:27:16 1.8
@@ -71,5 +71,4 @@
(define-beirc-hook autojoin-hoook ((message cl-irc:irc-rpl_welcome-message))
"When a connection is established, check the list of channels for autojoin
and set them up accordingly."
- (declare (ignore message))
- (join-missing-channels *application-frame*))
+ (join-missing-channels *application-frame* (irc:connection message)))
--- /project/beirc/cvsroot/beirc/receivers.lisp 2006/04/11 22:28:58 1.26
+++ /project/beirc/cvsroot/beirc/receivers.lisp 2006/04/12 18:27:16 1.27
@@ -9,7 +9,8 @@
(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.
+ (connection-open-p :accessor connection-open-p :initform t) ; used only on server receivers.
+ (query :reader query :initform nil :initarg :query)
(focused-nicks :accessor focused-nicks :initform nil)
(title :reader title :initarg :title)
(last-visited :accessor last-visited :initform 0)
@@ -18,6 +19,8 @@
(pane :reader pane)
(tab-pane :accessor tab-pane)))
+(defclass irc-connection-closed-message (irc:irc-message) ())
+
(defun slot-value-or-something (object &key (slot 'name) (something "without name"))
(if (slot-boundp object slot)
(slot-value object slot)
@@ -107,6 +110,23 @@
(setf (gethash (list connection normalized-name) (receivers frame)) receiver)
receiver))))
+(defun reinit-receiver-for-new-connection (server-receiver connection &optional (frame *application-frame*))
+ (let ((old-connection (connection server-receiver)))
+ (maphash (lambda (key receiver)
+ (destructuring-bind (rec-connection name) key
+ (when (eql old-connection rec-connection)
+ (remhash key (receivers frame))
+ (setf (gethash (list connection name) (receivers frame)) receiver)
+ (setf (connection receiver) connection)
+ (dolist (message (messages receiver))
+ ;; KLUDGE: reset the connection of messages so
+ ;; that channel/user finding queries don't fail
+ ;; horribly
+ (setf (irc:connection message) connection)))
+ (write-char #\Newline *debug-io*)))
+ (receivers frame))))
+
+
(defun remove-receiver (receiver frame)
(tab-layout:remove-pane (tab-pane receiver)
(find-pane-named frame 'query))
@@ -256,7 +276,6 @@
cl-irc:irc-rpl_endofexceptlist-message
cl-irc:irc-ping-message))
-
;;; default receiver.
(defmethod receiver-for-message ((message irc:irc-message) frame)
#+or ; comment out to debug on uncaught messages.
More information about the Beirc-cvs
mailing list