[beirc-cvs] CVS update: beirc/application.lisp

[Andreas Fuchs]

Update of /project/beirc/cvsroot/beirc
In directory common-lisp.net:/tmp/cvs-serv2852

Modified Files:
	application.lisp 
Log Message:
add "auto-join on reconnect" feature to com-connect; also, disconnect if
there was an error during connecting.

Date: Sun Oct  2 10:25:37 2005
Author: afuchs

Index: beirc/application.lisp
diff -u beirc/application.lisp:1.19 beirc/application.lisp:1.20
--- beirc/application.lisp:1.19	Sun Oct  2 06:01:25 2005
+++ beirc/application.lisp	Sun Oct  2 10:25:37 2005
@@ -524,28 +524,38 @@
     ((server 'string :prompt "Server")
      &key
      (nick 'string :prompt "Nick name" :default *default-nick*))
-  (cond ((current-connection *application-frame*)
-         (format *query-io* "You are already connected.~%"))
-        (t
-         (setf (slot-value *application-frame* 'connection)
-	       (irc:connect :nickname nick :server server :connection-type 'beirc-connection))
-         (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*))
-             (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")))))))
+  (let ((success nil))
+    (cond ((current-connection *application-frame*)
+               (format *query-io* "You are already connected.~%"))
+              (t
+               (setf (slot-value *application-frame* 'connection)
+                     (irc:connect :nickname nick :server server :connection-type 'beirc-connection))
+               (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)))
+                         (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.")))))))
+
 (defun disconnect (frame reason)
   (raise-receiver (server-receiver frame))
   (irc:quit (current-connection frame) reason)