From 031646c3b8236eb441434664e10fb88f8e7ec7be Mon Sep 17 00:00:00 2001 From: Nikodemus Siivola Date: Wed, 16 Jan 2008 15:46:22 +0000 Subject: [PATCH] 1.0.13.45: close the fd before deleting / moving files on CLOSE :ABORT T * Windows is not happy about files with open handles dancing around. This should one of the SB-COVER problems on Windows, and is arguably better for posixoid platforms as well. * SET-CLOSED-FLAME immediately after closing the fd, since that is in a very real sense the boundary after which doing stream operations is going to lose. * Windows additions to .gitignore. --- .gitignore | 3 ++ NEWS | 1 + src/code/fd-stream.lisp | 129 ++++++++++++++++++++++++++---------------------- version.lisp-expr | 2 +- 4 files changed, 75 insertions(+), 60 deletions(-) diff --git a/.gitignore b/.gitignore index 3db8355f5..26c68916e 100644 --- a/.gitignore +++ b/.gitignore @@ -28,7 +28,10 @@ src/runtime/target-os.h tests/test-status.lisp-expr tools-for-build/grovel-headers tools-for-build/grovel-headers.exe +tools-for-build/os-provides-putwc-test +tools-for-build/os-provides-putwc-test.exe contrib/*/test-passed contrib/*/foo.c contrib/*/a.out +contrib/*/a.exe contrib/sb-cover/test-output diff --git a/NEWS b/NEWS index 25b0f557f..923b8a303 100644 --- a/NEWS +++ b/NEWS @@ -19,6 +19,7 @@ changes in sbcl-1.0.14 relative to sbcl-1.0.13: single-floats on 64-bit platforms where single-floats are not boxed. * bug fix: SB-MOP:CLASS-SLOTS now signals an error if the class has not yet been finalized. (reported by Levente Meszaros) + * bug fix: CLOSE :ABORT T behaves more correctly on Windows. * DESCRIBE and (DOCUMENTATION ... 'OPTIMIZE) describe meaning of SBCL-specific optimize qualities. diff --git a/src/code/fd-stream.lisp b/src/code/fd-stream.lisp index 4e9aab7b1..9cbafafdb 100644 --- a/src/code/fd-stream.lisp +++ b/src/code/fd-stream.lisp @@ -1950,20 +1950,26 @@ input-type output-type)))))) -;;; Handles the resource-release aspects of stream closing. +;;; Handles the resource-release aspects of stream closing, and marks +;;; it as closed. (defun release-fd-stream-resources (fd-stream) (handler-case (without-interrupts + ;; Drop handlers first. + (when (fd-stream-handler fd-stream) + (remove-fd-handler (fd-stream-handler fd-stream)) + (setf (fd-stream-handler fd-stream) nil)) ;; Disable interrupts so that a asynch unwind will not leave ;; us with a dangling finalizer (that would close the same - ;; --possibly reassigned-- FD again). + ;; --possibly reassigned-- FD again), or a stream with a closed + ;; FD that appears open. (sb!unix:unix-close (fd-stream-fd fd-stream)) + (set-closed-flame fd-stream) (when (fboundp 'cancel-finalization) (cancel-finalization fd-stream))) ;; On error unwind from WITHOUT-INTERRUPTS. (serious-condition (e) (error e))) - ;; Release all buffers. If this is undone, or interrupted, ;; we're still safe: buffers have finalizers of their own. (release-fd-stream-buffers fd-stream)) @@ -2036,66 +2042,71 @@ (setf (fd-stream-listen fd-stream) t)) (:close (cond (arg1 ; We got us an abort on our hands. - (when (fd-stream-handler fd-stream) - (remove-fd-handler (fd-stream-handler fd-stream)) - (setf (fd-stream-handler fd-stream) nil)) - ;; We can't do anything unless we know what file were - ;; dealing with, and we don't want to do anything - ;; strange unless we were writing to the file. - (when (and (fd-stream-file fd-stream) (fd-stream-obuf fd-stream)) - (if (fd-stream-original fd-stream) - ;; If the original is EQ to file we are appending - ;; and can just close the file without renaming. - (unless (eq (fd-stream-original fd-stream) - (fd-stream-file fd-stream)) - ;; We have a handle on the original, just revert. + (let ((outputp (fd-stream-obuf fd-stream)) + (file (fd-stream-file fd-stream)) + (orig (fd-stream-original fd-stream))) + ;; This takes care of the important stuff -- everything + ;; rest is cleaning up the file-system, which we cannot + ;; do on some platforms as long as the file is open. + (release-fd-stream-resources fd-stream) + ;; We can't do anything unless we know what file were + ;; dealing with, and we don't want to do anything + ;; strange unless we were writing to the file. + (when (and outputp file) + (if orig + ;; If the original is EQ to file we are appending to + ;; and can just close the file without renaming. + (unless (eq orig file) + ;; We have a handle on the original, just revert. + (multiple-value-bind (okay err) + (sb!unix:unix-rename orig file) + ;; FIXME: Why is this a SIMPLE-STREAM-ERROR, and the + ;; others are SIMPLE-FILE-ERRORS? Surely they should + ;; all be the same? + (unless okay + (error 'simple-stream-error + :format-control + "~@" + :format-arguments + (list file orig fd-stream (strerror err)) + :stream fd-stream)))) + ;; We can't restore the original, and aren't + ;; appending, so nuke that puppy. + ;; + ;; FIXME: This is currently the fate of superseded + ;; files, and according to the CLOSE spec this is + ;; wrong. However, there seems to be no clean way to + ;; do that that doesn't involve either copying the + ;; data (bad if the :abort resulted from a full + ;; disk), or renaming the old file temporarily + ;; (probably bad because stream opening becomes more + ;; racy). (multiple-value-bind (okay err) - (sb!unix:unix-rename (fd-stream-original fd-stream) - (fd-stream-file fd-stream)) + (sb!unix:unix-unlink file) (unless okay - (simple-stream-perror - "couldn't restore ~S to its original contents" - fd-stream - err)))) - ;; We can't restore the original, and aren't - ;; appending, so nuke that puppy. - ;; - ;; FIXME: This is currently the fate of superseded - ;; files, and according to the CLOSE spec this is - ;; wrong. However, there seems to be no clean way to - ;; do that that doesn't involve either copying the - ;; data (bad if the :abort resulted from a full - ;; disk), or renaming the old file temporarily - ;; (probably bad because stream opening becomes more - ;; racy). - (multiple-value-bind (okay err) - (sb!unix:unix-unlink (fd-stream-file fd-stream)) - (unless okay - (error 'simple-file-error - :pathname (fd-stream-file fd-stream) - :format-control - "~@" - :format-arguments (list (fd-stream-file fd-stream) - (strerror err)))))))) + (error 'simple-file-error + :pathname file + :format-control + "~@" + :format-arguments + (list file fd-stream (strerror err))))))))) (t (finish-fd-stream-output fd-stream) - (when (and (fd-stream-original fd-stream) - (fd-stream-delete-original fd-stream)) - (multiple-value-bind (okay err) - (sb!unix:unix-unlink (fd-stream-original fd-stream)) - (unless okay - (error 'simple-file-error - :pathname (fd-stream-original fd-stream) - :format-control - "~@" - :format-arguments - (list (fd-stream-original fd-stream) - fd-stream - (strerror err)))))))) - (release-fd-stream-resources fd-stream) - ;; Mark as closed. FIXME: Maybe this should be the first thing done? - (sb!impl::set-closed-flame fd-stream)) + (let ((orig (fd-stream-original fd-stream))) + (when (and orig (fd-stream-delete-original fd-stream)) + (multiple-value-bind (okay err) (sb!unix:unix-unlink orig) + (unless okay + (error 'simple-file-error + :pathname orig + :format-control + "~@" + :format-arguments + (list orig fd-stream (strerror err))))))) + ;; In case of no-abort close, don't *really* close the + ;; stream until the last moment -- the cleaning up of the + ;; original can be done first. + (release-fd-stream-resources fd-stream)))) (:clear-input (fd-stream-clear-input fd-stream)) (:force-output diff --git a/version.lisp-expr b/version.lisp-expr index fe27a51a6..b0c2bf9dc 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.13.44" +"1.0.13.45" -- 2.11.4.GIT