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 (file)
--- 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 (file)
--- 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 (file)
--- 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 (file)
--- 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