From: Nikodemus Siivola <nikodemus@random-state.net>
Date: Wed, 7 Apr 2010 13:31:34 +0000 (+0000)
Subject: 1.0.37.49: add :ABORT to SOCKET-CLOSE
X-Git-Url: http://repo.macrolet.net/gitweb/?a=commitdiff_plain;h=89d35478424da24510ce5f285c4f9bf16ed5057c;p=sbcl.git

1.0.37.49: add :ABORT to SOCKET-CLOSE

 Also take care not to disassociate the stream from the socket if the
 close fails.

 Fixed launchpad bug #543951.
---

diff --git a/NEWS b/NEWS
index f287917..9352a0d 100644
--- a/NEWS
+++ b/NEWS
@@ -31,6 +31,9 @@ changes relative to sbcl-1.0.37:
        SOCKET-PEERNAME.
     ** SOCKET-MAKE-STREAM once more supports the :AUTO-CLOSE option.
        (lp#540413)
+    ** SOCKET-CLOSE now accepts :ABORT argument, which is passed on to
+       CL:CLOSE when appropriate, and no longer disassociates the stream
+       from the socket if close failed. (lp#543951)
   * improvements to the instrumenting profiler
     ** new feature: report per-function GC overhead. (thanks to John Fremlin)
     ** optimization: counters no longer use locks for the overflow mode.
diff --git a/contrib/sb-bsd-sockets/sockets.lisp b/contrib/sb-bsd-sockets/sockets.lisp
index 9788cf2..dcccc79 100644
--- a/contrib/sb-bsd-sockets/sockets.lisp
+++ b/contrib/sb-bsd-sockets/sockets.lisp
@@ -320,12 +320,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 +340,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
diff --git a/version.lisp-expr b/version.lisp-expr
index fed5edb..ea30468 100644
--- a/version.lisp-expr
+++ b/version.lisp-expr
@@ -17,4 +17,4 @@
 ;;; checkins which aren't released. (And occasionally for internal
 ;;; versions, especially for internal versions off the main CVS
 ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".)
-"1.0.37.48"
+"1.0.37.49"