From 96a1badea2523bf188f7ba023e2f69a6785847d6 Mon Sep 17 00:00:00 2001 From: Nikodemus Siivola Date: Thu, 20 May 2004 14:47:54 +0000 Subject: [PATCH] 0.8.10.40: Fixed bug in OPEN / CLOSE interaction that caused file deletion when appending stream was closed with :ABORT T. ... BUGS entry about similar behaviour when superseding files. ... Regression test for the same. --- BUGS | 13 ++++++++++ NEWS | 2 ++ src/code/fd-stream.lisp | 59 +++++++++++++++++++++++++++++----------------- tests/stream.impure.lisp | 24 +++++++++++++++++++ 4 files changed, 77 insertions(+), 21 deletions(-) diff --git a/BUGS b/BUGS index 175889a..d16501c 100644 --- a/BUGS +++ b/BUGS @@ -1443,3 +1443,16 @@ WORKAROUND: to about 1024 (and similarly for signed-byte), so (open "/dev/zero" :element-type '(unsigned-byte 1025)) gives an error in sbcl-0.8.10. + +325: "CLOSE :ABORT T on supeseding streams" + Closing a stream opened with :IF-EXISTS :SUPERSEDE with :ABORT T leaves no + file on disk, even if one existed before opening. + + The illegality of this is not crystal clear, as the ANSI dictionary + entry for CLOSE says that when :ABORT is T superseded files are not + superseded (ie. the original should be restored), whereas the OPEN + entry says about :IF-EXISTS :SUPERSEDE "If possible, the + implementation should not destroy the old file until the new stream + is closed." -- implying that even though undesirable, early deletion + is legal. Restoring the original would none the less be the polite + thing to do. diff --git a/NEWS b/NEWS index e0e20f7..e186ee4 100644 --- a/NEWS +++ b/NEWS @@ -2403,6 +2403,8 @@ changes in sbcl-0.8.11 relative to sbcl-0.8.10: SB-EXT:INHIBIT-WARNINGS OPTIMIZE quality. See the manual for documentation on this feature. The SB-EXT:INHIBIT-WARNINGS quality should be considered deprecated. + * fixed bug: CLOSE :ABORT T on appending stream no longer causes + file deletion. * fixed bug: Invalid slot specification errors now print correctly. (thanks to Zach Beane) * fixed bug 320: Shared to local slot value transfers in class diff --git a/src/code/fd-stream.lisp b/src/code/fd-stream.lisp index 564f53b..d8a2d57 100644 --- a/src/code/fd-stream.lisp +++ b/src/code/fd-stream.lisp @@ -883,27 +883,40 @@ (setf (fd-stream-unread fd-stream) arg1) (setf (fd-stream-listen fd-stream) t)) (:close - (cond (arg1 - ;; We got us an abort on our hands. + (cond (arg1 ; We got us an abort on our hands. (when (fd-stream-handler fd-stream) - (sb!sys:remove-fd-handler (fd-stream-handler fd-stream)) - (setf (fd-stream-handler fd-stream) nil)) + (sb!sys: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-sap 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. (if (fd-stream-original fd-stream) - ;; We have a handle on the original, just revert. - (multiple-value-bind (okay err) - (sb!unix:unix-rename (fd-stream-original fd-stream) - (fd-stream-file fd-stream)) - (unless okay - (simple-stream-perror - "couldn't restore ~S to its original contents" - fd-stream - err))) - ;; We can't restore the original, so nuke that puppy. + ;; 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. + (multiple-value-bind (okay err) + (sb!unix:unix-rename (fd-stream-original fd-stream) + (fd-stream-file fd-stream)) + (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 @@ -1243,12 +1256,16 @@ (if (eq if-does-not-exist :create) (setf mask (logior mask sb!unix:o_creat))) - (let ((original (if (member if-exists - '(:rename :rename-and-delete)) - (pick-backup-name namestring))) + (let ((original (case if-exists + ((:rename :rename-and-delete) + (pick-backup-name namestring)) + ((:append) + ;; KLUDGE: Provent CLOSE from deleting + ;; appending streams when called with :ABORT T + namestring))) (delete-original (eq if-exists :rename-and-delete)) (mode #o666)) - (when original + (when (and original (not (eq original namestring))) ;; We are doing a :RENAME or :RENAME-AND-DELETE. Determine ;; whether the file already exists, make sure the original ;; file is not a directory, and keep the mode. diff --git a/tests/stream.impure.lisp b/tests/stream.impure.lisp index 7348bfe..598c55a 100644 --- a/tests/stream.impure.lisp +++ b/tests/stream.impure.lisp @@ -125,5 +125,29 @@ (assert (= 1 (file-position s))) ; unicode... (assert (file-position s 0)))) (delete-file p)) + +;;; CLOSING a non-new streams should not delete them, and superseded +;;; files should be restored. +(let ((test "test-file-for-close-should-not-delete")) + (macrolet ((test-mode (mode) + `(progn + (catch :close-test-exit + (with-open-file (f test :direction :output :if-exists ,mode) + (write-line "test" f) + (throw :close-test-exit t))) + (assert (and (probe-file test) ,mode))))) + (unwind-protect + (progn + (with-open-file (f test :direction :output) + (write-line "test" f)) + (test-mode :append) + ;; FIXME: We really should recover supersede files as well, according to + ;; CLOSE in CLHS, but at the moment we don't. + ;; (test-mode :supersede) + (test-mode :rename) + (test-mode :rename-and-delete)) + (when (probe-file test) + (delete-file test))))) + ;;; success (quit :unix-status 104) -- 1.7.10.4