[usocket-cvs] r575 - usocket/trunk/backend

[Chun Tian (binghe)]

Author: ctian
Date: Thu Mar 10 05:17:43 2011
New Revision: 575

Log:
[SBCL] Merge a patch from Nikodemus Siivola (SBCL maintainer), for "better SOCKET-CONNECT for SBCL".

Modified:
   usocket/trunk/backend/sbcl.lisp

Modified: usocket/trunk/backend/sbcl.lisp
==============================================================================
--- usocket/trunk/backend/sbcl.lisp	(original)
+++ usocket/trunk/backend/sbcl.lisp	Thu Mar 10 05:17:43 2011
@@ -199,6 +199,11 @@
                  (if usock-cond
                      (signal usock-cond :socket socket))))))
 
+(defvar *dummy-stream*
+  (let ((stream (make-broadcast-stream)))
+    (close stream)
+    stream))
+
 (defun socket-connect (host port &key (protocol :stream) (element-type 'character)
                        timeout deadline (nodelay t nodelay-specified)
                        local-host local-port
@@ -219,47 +224,53 @@
   (let ((socket (make-instance 'sb-bsd-sockets:inet-socket
                                :type protocol
                                :protocol (case protocol
-					   (:stream :tcp)
-					   (:datagram :udp)))))
-    (handler-case
-        (ecase protocol
-          (:stream
-	   (let* ((stream
-		   (sb-bsd-sockets:socket-make-stream socket
-						      :input t
-						      :output t
-						      :buffering :full
-						      #+sbcl #+sbcl
-						      :timeout timeout
-						      :element-type element-type))
-		  ;;###FIXME: The above line probably needs an :external-format
-		  (usocket (make-stream-socket :stream stream :socket socket))
-		  (ip (host-to-vector-quad host)))
-	     ;; binghe: use SOCKOPT-TCP-NODELAY as internal symbol
-	     ;;         to pass compilation on ECL without it.
-	     (when (and nodelay-specified sockopt-tcp-nodelay-p)
-	       (setf (sb-bsd-sockets::sockopt-tcp-nodelay socket) nodelay))
-	     (when (or local-host local-port)
-	       (sb-bsd-sockets:socket-bind socket
-					   (host-to-vector-quad
-					    (or local-host *wildcard-host*))
-					   (or local-port *auto-port*)))
-	     (with-mapped-conditions (usocket)
-	       (sb-bsd-sockets:socket-connect socket ip port))
-	     usocket))
-          (:datagram
-	   (when (or local-host local-port)
-	     (sb-bsd-sockets:socket-bind socket
-					 (host-to-vector-quad
-					  (or local-host *wildcard-host*))
-					 (or local-port *auto-port*)))
-	   (when (and host port)
-	     (sb-bsd-sockets:socket-connect socket (host-to-vector-quad host) port))
-	   (make-datagram-socket socket)))
-      (t (c)
-        ;; Make sure we don't leak filedescriptors
-        (sb-bsd-sockets:socket-close socket)
-        (error c)))))
+                                           (:stream :tcp)
+                                           (:datagram :udp))))
+        (ip (host-to-vector-quad host))
+        (local-host (host-to-vector-quad (or local-host *wildcard-host*)))
+        (local-port (or local-port *auto-port*))
+        usocket ok)
+    (unwind-protect
+         (progn
+           (ecase protocol
+             (:stream
+              ;; If make a real socket stream before the socket is
+              ;; connected, it gets a misleading name so supply a
+              ;; dummy value to start with.
+              (setf usocket (make-stream-socket :socket socket :stream *dummy-stream*))
+              ;; binghe: use SOCKOPT-TCP-NODELAY as internal symbol
+              ;;         to pass compilation on ECL without it.
+              (when (and nodelay-specified sockopt-tcp-nodelay-p)
+                (setf (sb-bsd-sockets::sockopt-tcp-nodelay socket) nodelay))
+              (when (or local-host local-port)
+                (sb-bsd-sockets:socket-bind socket local-host local-port))
+              (with-mapped-conditions (usocket)
+                (sb-bsd-sockets:socket-connect socket ip port)
+                ;; Now that we're connected make the stream.
+                (setf (socket-stream usocket)
+                      (sb-bsd-sockets:socket-make-stream socket
+                                                         :input t
+                                                         :output t
+                                                         :buffering :full
+                                                         #+sbcl #+sbcl
+                                                         :timeout timeout
+                                                         :element-type element-type))))
+             (:datagram
+              (when (or local-host local-port)
+                (sb-bsd-sockets:socket-bind socket
+                                            (host-to-vector-quad
+                                             (or local-host *wildcard-host*))
+                                            (or local-port *auto-port*)))
+              (setf usocket (make-datagram-socket socket))
+              (when (and host port)
+                (with-mapped-conditions (usocket)
+                  (sb-bsd-sockets:socket-connect socket ip port)
+                  (setf (connected-p usocket) t)))))
+           (setf ok t))
+      ;; Clean up in case of an error.
+      (unless ok
+        (sb-bsd-sockets:socket-close socket :abort t)))
+    usocket))
 
 (defun socket-listen (host port
                            &key reuseaddress