X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=contrib%2Fsb-bsd-sockets%2Fsockets.lisp;h=66f57a120d64c8c2b2b10c63319b1cf77011b4b8;hb=c4776b3b3121be1c3bad293a4fa7efffb592f7f7;hp=9788cf2bcae674f6c86394f5767cec7938c6174c;hpb=808457cb2af9dac048727de6b089d6d81235d29e;p=sbcl.git

diff --git a/contrib/sb-bsd-sockets/sockets.lisp b/contrib/sb-bsd-sockets/sockets.lisp
index 9788cf2..66f57a1 100644
--- a/contrib/sb-bsd-sockets/sockets.lisp
+++ b/contrib/sb-bsd-sockets/sockets.lisp
@@ -59,7 +59,8 @@ directly instantiated.")))
       (setf (slot-value socket 'file-descriptor) fd
             (slot-value socket 'protocol) proto-num
             (slot-value socket 'type) type)
-      (sb-ext:finalize socket (lambda () (sockint::close fd)))))
+      (sb-ext:finalize socket (lambda () (sockint::close fd))
+                       :dont-save t)))
 
 
 
@@ -117,7 +118,8 @@ values"))
                               :type (socket-type socket)
                               :protocol (socket-protocol socket)
                               :descriptor fd)))
-                    (sb-ext:finalize s (lambda () (sockint::close fd))))
+                    (sb-ext:finalize s (lambda () (sockint::close fd))
+                                     :dont-save t))
                   (multiple-value-list (bits-of-sockaddr socket sockaddr))))))))
 
 (defgeneric socket-connect (socket &rest address)
@@ -320,12 +322,14 @@ grow to before new connection attempts are refused.  See also listen(2)"))
       (open-stream-p (slot-value socket 'stream))
       (/= -1 (socket-file-descriptor socket))))
 
-(defgeneric socket-close (socket)
-  (:documentation "Close SOCKET.  May throw any kind of error that
-write(2) would have thrown.  If SOCKET-MAKE-STREAM has been called,
-calls CLOSE on that stream instead"))
+(defgeneric socket-close (socket &key abort)
+  (:documentation
+   "Close SOCKET, unless it was already closed.
+
+If SOCKET-MAKE-STREAM has been called, calls CLOSE using ABORT on that stream.
+Otherwise closes the socket file descriptor using close(2)."))
 
-(defmethod socket-close ((socket socket))
+(defmethod socket-close ((socket socket) &key abort)
   ;; the close(2) manual page has all kinds of warning about not
   ;; checking the return value of close, on the grounds that an
   ;; earlier write(2) might have returned successfully w/o actually
@@ -338,25 +342,30 @@ calls CLOSE on that stream instead"))
   ;; 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)
-           (unwind-protect (close (slot-value socket 'stream)) ;; closes fd
+    (flet ((drop-it (&optional streamp)
              (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))
-               (setf (slot-value socket 'file-descriptor) -1)
-               nil))))))
-
+             (if streamp
+                 (slot-makunbound socket 'stream)
+                 (sb-ext:cancel-finalization socket))
+             t))
+      (cond ((eql fd -1)
+             ;; already closed
+             nil)
+           ((slot-boundp socket 'stream)
+            (close (slot-value socket 'stream) :abort abort)
+            ;; Don't do this if there was an error from CLOSE -- the stream is
+            ;; still live.
+            (drop-it t))
+           (t
+            (handler-case
+                (when (minusp (sockint::close fd))
+                  (socket-error "close"))
+              (bad-file-descriptor-error ()
+                (drop-it))
+              (:no-error (r)
+                (declare (ignore r))
+                (drop-it))))))))
 
 (defgeneric socket-make-stream (socket &key input output
                                        element-type external-format
@@ -374,12 +383,17 @@ for the stream."))
                                (buffering :full)
                                (external-format :default)
                                timeout
-                               auto-close)
-  "Default method for SOCKET objects. An ELEMENT-TYPE of :DEFAULT will
-construct a bivalent stream. Acceptable values for BUFFERING are :FULL, :LINE
+                               auto-close
+                               (serve-events t))
+  "Default method for SOCKET objects.
+
+An ELEMENT-TYPE of :DEFAULT will construct a bivalent stream, capable of both
+binary and character IO. Acceptable values for BUFFERING are :FULL, :LINE
 and :NONE. Streams will have no TIMEOUT by default. If AUTO-CLOSE is true, the
 underlying OS socket is automatically closed after the stream and the socket
-have been garbage collected.
+have been garbage collected. If SERVE-EVENTS is true, blocking IO on the
+socket will dispatch to the recursive event loop -- the default is currently
+true, but this liable to change.
 
 The stream for SOCKET will be cached, and a second invocation of this method
 will return the same stream. This may lead to oddities if this function is
@@ -400,8 +414,9 @@ and get an output stream in response\)."
                     :buffering buffering
                     :external-format external-format
                     :timeout timeout
-                    :auto-close auto-close)))
-      (setf (slot-value socket 'stream) stream)
+                    :auto-close auto-close
+                    :serve-events serve-events))
+      (setf (slot-value socket 'stream) stream))
     (sb-ext:cancel-finalization socket)
     stream))