[beirc-cvs] CVS beirc

[afuchs]

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

Modified Files:
	application.lisp 
Log Message:
Do nothing if connecting to a server/nick that we're already connected to.


--- /project/beirc/cvsroot/beirc/application.lisp	2006/03/16 19:29:10	1.59
+++ /project/beirc/cvsroot/beirc/application.lisp	2006/03/16 20:22:57	1.60
@@ -133,6 +133,14 @@
                             &optional (connection (current-connection *application-frame*)))
   (cdr (assoc connection (server-receivers frame) :test #'connection=)))
 
+(defmethod server-receiver-from-args ((frame beirc) server-name port nickname)
+  (loop for (connection . receiver) in (server-receivers frame)
+        if (and (equal (irc:nickname (irc:user connection)) nickname)
+                (equal (irc:server-name connection) server-name)
+                ;; TODO: no port.
+                )
+          do (return receiver)))
+
 (defmethod (setf server-receiver) (newval (frame beirc)
                                           &optional (connection (current-connection *application-frame*)))
   (pushnew (cons connection newval) (slot-value frame 'server-receivers)
@@ -817,33 +825,34 @@
      (pass 'string :prompt "Password" :default nil)
      (port 'number :prompt "Port" :default irc::*default-irc-server-port*))
   (let ((success nil))
-    (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))
-            (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 (ui-process *application-frame*) (current-process))
-            (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."))))))
+    (or (server-receiver-from-args *application-frame* server port nick)
+        (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))
+                (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 (ui-process *application-frame*) (current-process))
+                (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 (connection frame reason)
   (let ((*application-frame* frame))