From: Nikodemus Siivola Date: Sun, 30 Oct 2011 19:51:30 +0000 (+0200) Subject: make DELETE-FILE respect *DEFAULT-PATHNAME-DEFAULTS* X-Git-Url: http://repo.macrolet.net/gitweb/?a=commitdiff_plain;h=2a0f8515245d080dee97b72ee910c5dcbc4fc5e4;p=sbcl.git make DELETE-FILE respect *DEFAULT-PATHNAME-DEFAULTS* MERGE-PATHNAMES to get an absolute pathname. (Using TRUENAME would be wrong, since then we would delete files pointed to by symbolic links, and not the symbolic links themselves -- a nasty regression that would be!) Also remove the "for error checking" TRUENAME call from there: unlink will give us an errno that tells what we need to know -- and lo! there is one race condition less in the system. Previously using relative pathnames it was possible to accidentally delete the wrong file. Fixes lp#882877. NB: currently DELETE-DIRECTORY and RENAME-FILE use TRUENAME with just the aforementioned unfortunate consequence, but I'm hesitant to change them during the freeze -- so dealing with this issue in them will have to wait a bit. --- diff --git a/NEWS b/NEWS index a099c94..9f2db4e 100644 --- a/NEWS +++ b/NEWS @@ -25,6 +25,8 @@ changes relative to sbcl-1.0.52: constant characters. * bug fix: ROOM reported only the low 32 bits of dynamic space usage on 64 bit platforms. (lp#881445) + * bug fix: DELETE-FILE did not MERGE-PATHNAMES, making it possible to + delete the wrong file when using relative pathnames. (lp#882877) changes in sbcl-1.0.52 relative to sbcl-1.0.51: * enhancement: ASDF has been updated to version 2.017. diff --git a/src/code/filesys.lisp b/src/code/filesys.lisp index 8817dcf..c25818f 100644 --- a/src/code/filesys.lisp +++ b/src/code/filesys.lisp @@ -493,9 +493,9 @@ If FILE is a stream, on Windows the stream is closed immediately. On Unix plaforms the stream remains open, allowing IO to continue: the OS resources associated with the deleted file remain available till the stream is closed as per standard Unix unlink() behaviour." - (let* ((pathname (translate-logical-pathname file)) + (let* ((pathname (translate-logical-pathname + (merge-pathnames file (sane-default-pathname-defaults)))) (namestring (native-namestring pathname :as-file t))) - (truename file) ; for error-checking side-effect #!+win32 (when (streamp file) (close file)) @@ -518,9 +518,7 @@ the directory could not be deleted for any reason. \(DELETE-DIRECTORY \"/tmp/foo\") and \(DELETE-DIRECTORY \"/tmp/foo/\") both delete the \"foo\" subdirectory of \"/tmp\", or signal an error if it does not -exist or is a file. - -Experimental: interface subject to change." +exist or is a file." (declare (type pathname-designator pathspec)) (with-pathname (pathname pathspec) (let ((truename (truename (translate-logical-pathname pathname)))) diff --git a/tests/filesys.test.sh b/tests/filesys.test.sh index 77aff65..a02e368 100644 --- a/tests/filesys.test.sh +++ b/tests/filesys.test.sh @@ -265,6 +265,18 @@ test -d foo?bar check_status_maybe_lose "ENSURE-DIRECTORIES-EXIST part 2" $? \ 0 "(directory exists)" +# DELETE-FILE +use_test_subdirectory +mkdir sub +touch deltest +touch sub/deltest +run_sbcl --eval '(let ((*default-pathname-defaults* (truename "sub"))) + (delete-file "deltest") + (sb-ext:quit))' +test -f deltest && test ! -f sub/deltest +check_status_maybe_lose "delete-file via d-p-d" $? \ + 0 "ok" + # DELETE-DIRECTORY use_test_subdirectory mkdir dont_delete_me @@ -280,10 +292,15 @@ touch deep/1/2/e touch deep/1/2/f ln -s `pwd`/dont_delete_me deep/linky ln -s `pwd`/me_neither deep/1/another_linky +mkdir -p one/one +touch one/one/two +touch one/two run_sbcl --eval '(sb-ext:delete-directory "simple_test_subdir1")' \ --eval '(sb-ext:delete-directory "simple_test_subdir2/")' \ --eval '(sb-ext:delete-directory "deep" :recursive t)' \ + --eval '(let ((*default-pathname-defaults* (truename "one"))) + (delete-directory "one" :recursive t))' \ --eval '(sb-ext:quit)' test -d simple_test_subdir1 @@ -306,5 +323,9 @@ test -f me_neither check_status_maybe_lose "delete-directory 5" $? \ 0 "didn't follow link" +test -f one/two && test -d one && test ! -d one/one +check_status_maybe_lose "delete-directory via d-p-d" $? \ + 0 "ok" + # success convention for script exit $EXIT_TEST_WIN diff --git a/tests/subr.sh b/tests/subr.sh index 333ffb6..b96dd29 100644 --- a/tests/subr.sh +++ b/tests/subr.sh @@ -119,6 +119,10 @@ check_status_maybe_lose () { # them consistently do so in subdirectories. Note that such tests # should not change their exit action, or do so only very carefully. use_test_subdirectory () { + if test -d "$TEST_DIRECTORY" + then + cleanup_test_subdirectory + fi mkdir "$TEST_DIRECTORY" cd "$TEST_DIRECTORY" trap "cleanup_test_subdirectory" EXIT