0.8.7.49:

[sbcl.git] / contrib / sb-bsd-sockets / sockets.lisp

diff --git a/contrib/sb-bsd-sockets/sockets.lisp b/contrib/sb-bsd-sockets/sockets.lisp
index ed03482..9f15ad6 100644 (file)
--- a/contrib/sb-bsd-sockets/sockets.lisp
+++ b/contrib/sb-bsd-sockets/sockets.lisp
@@ -62,9 +62,9 @@ See also bind(2)"))
 (defmethod socket-bind ((socket socket)
                         &rest address)
   (let ((sockaddr (apply #'make-sockaddr-for socket nil address)))
-    (if (= (sb-sys:without-gcing
+    (if (= (sb-sys:with-pinned-objects (sockaddr)
            (sockint::bind (socket-file-descriptor socket)
-                          (sockint::array-data-address sockaddr)
+                          (sb-grovel::array-data-address sockaddr)
                           (size-of-sockaddr socket)))
            -1)
         (socket-error "bind"))))
@@ -76,30 +76,30 @@ newly-created connected socket and the peer address as multiple
 values"))
   
 (defmethod socket-accept ((socket socket))
-  (let* ((sockaddr (make-sockaddr-for socket))
-         (fd (sb-sys:without-gcing
-             (sockint::accept (socket-file-descriptor socket)
-                              (sockint::array-data-address sockaddr)
-                              (size-of-sockaddr socket)))))
-    (apply #'values
-          (if (= fd -1)
-              (socket-error "accept") 
-              (let ((s (make-instance (class-of socket)
-                                      :type (socket-type socket)
-                                      :protocol (socket-protocol socket)
-                                      :descriptor fd)))
-                (sb-ext:finalize s (lambda () (sockint::close fd)))))
-          (multiple-value-list (bits-of-sockaddr socket sockaddr)))))
-
+  (let ((sockaddr (make-sockaddr-for socket)))
+    (sb-sys:with-pinned-objects (sockaddr)
+      (let ((fd (sockint::accept (socket-file-descriptor socket)
+                                (sb-grovel::array-data-address sockaddr)
+                                (size-of-sockaddr socket))))
+       (apply #'values
+              (if (= fd -1)
+                  (socket-error "accept")
+                  (let ((s (make-instance (class-of socket)
+                                          :type (socket-type socket)
+                                          :protocol (socket-protocol socket)
+                                          :descriptor fd)))
+                    (sb-ext:finalize s (lambda () (sockint::close fd)))))
+              (multiple-value-list (bits-of-sockaddr socket sockaddr)))))))
+    
 (defgeneric socket-connect (socket &rest address)
   (:documentation "Perform the connect(2) call to connect SOCKET to a
   remote PEER.  No useful return value."))
 
 (defmethod socket-connect ((socket socket) &rest peer)
   (let* ((sockaddr (apply #'make-sockaddr-for socket nil peer)))
-    (if (= (sb-sys:without-gcing
+    (if (= (sb-sys:with-pinned-objects (sockaddr)
            (sockint::connect (socket-file-descriptor socket)
-                             (sockint::array-data-address sockaddr)
+                             (sb-grovel::array-data-address sockaddr)
                              (size-of-sockaddr socket)))
           -1)
        (socket-error "connect") )))
@@ -110,9 +110,9 @@ values"))
   
 (defmethod socket-peername ((socket socket))
   (let* ((sockaddr (make-sockaddr-for socket)))
-    (when (= (sb-sys:without-gcing
+    (when (= (sb-sys:with-pinned-objects (sockaddr)
              (sockint::getpeername (socket-file-descriptor socket)
-                                   (sockint::array-data-address sockaddr)
+                                   (sb-grovel::array-data-address sockaddr)
                                    (size-of-sockaddr socket)))
             -1)
       (socket-error "getpeername"))
@@ -124,9 +124,9 @@ values"))
 
 (defmethod socket-name ((socket socket))
   (let* ((sockaddr (make-sockaddr-for socket)))
-    (when (= (sb-sys:without-gcing
+    (when (= (sb-sys:with-pinned-objects (sockaddr)
              (sockint::getsockname (socket-file-descriptor socket)
-                                   (sockint::array-data-address sockaddr)
+                                   (sb-grovel::array-data-address sockaddr)
                                    (size-of-sockaddr socket)))
             -1)
       (socket-error "getsockname"))
@@ -169,13 +169,13 @@ small"))
       (setf buffer (make-array length :element-type element-type)))
     (sb-alien:with-alien ((sa-len (array (sb-alien:unsigned 32) 2)))
       (setf (sb-alien:deref sa-len 0) (size-of-sockaddr socket))
-      (sb-sys:without-gcing 
+      (sb-sys:with-pinned-objects (buffer sockaddr) 
        (let ((len
              (sockint::recvfrom (socket-file-descriptor socket)
-                                (sockint::array-data-address buffer)
+                                (sb-grovel::array-data-address buffer)
                                 (or length (length buffer))
                                 flags
-                                (sockint::array-data-address sockaddr)
+                                (sb-grovel::array-data-address sockaddr)
                                 (sb-alien:cast sa-len (* integer)))))
         (when (= len -1) (socket-error "recvfrom"))
         (apply #'values buffer len (multiple-value-list
@@ -207,19 +207,27 @@ stream instead"))
   ;; descriptor).  Presumably this is an oversight and we could also
   ;; get anything that write(2) would have given us.
 
-  ;; What we do: we catch EBADF.  It should only ever happen if
-  ;; (a) someone's closed the socket already (stream closing seems
-  ;; to have this effect) or (b) the caller is messing around with
-  ;; socket internals.  That's not supported, dude
-  
-  (if (slot-boundp socket 'stream)
-      (close (slot-value socket 'stream))  ;; closes socket as well
-    (handler-case
-     (if (= (sockint::close (socket-file-descriptor socket)) -1)
-         (socket-error "close"))
-     (bad-file-descriptor-error (c) (declare (ignore c)) nil)
-     (:no-error (c)  (declare (ignore c)) nil))))
-
+  ;; note that if you have a socket _and_ a stream on the same fd, 
+  ;; the socket will avoid doing anything to close the fd in case
+  ;; the stream has done it already - if so, it may have been
+  ;; reassigned to some other file, and closing it would be bad
+
+  (let ((fd (socket-file-descriptor socket)))
+    (cond ((eql fd -1) ; already closed
+          nil)
+         ((slot-boundp socket 'stream)
+          (close (slot-value socket 'stream)) ;; closes fd
+          (setf (slot-value socket 'file-descriptor) -1)
+          (slot-makunbound socket 'stream))
+         (t
+          (sb-ext:cancel-finalization socket)
+          (handler-case
+              (if (= (sockint::close fd) -1)
+                  (socket-error "close"))
+            (bad-file-descriptor-error (c) (declare (ignore c)) nil)
+            (:no-error (c)  (declare (ignore c)) nil))))))
+
+    
 (defgeneric socket-make-stream (socket  &rest args)
     (:documentation "Find or create a STREAM that can be used for IO
 on SOCKET (which must be connected).  ARGS are passed onto
@@ -230,7 +238,9 @@ SB-SYS:MAKE-FD-STREAM."))
         (and (slot-boundp socket 'stream) (slot-value socket 'stream))))
     (unless stream
       (setf stream (apply #'sb-sys:make-fd-stream
-                         (socket-file-descriptor socket) args))
+                         (socket-file-descriptor socket)
+                         :name "a constant string"
+                         args))
       (setf (slot-value socket 'stream) stream)
       (sb-ext:cancel-finalization socket))
     stream))