~ chicken-core (chicken-5) a116f30b77b79a3b9a732bdd334e7125e4ad79f6

commit a116f30b77b79a3b9a732bdd334e7125e4ad79f6
Author:     Evan Hanson <evhan@foldling.org>
AuthorDate: Tue Apr 18 22:52:21 2017 +1200
Commit:     Peter Bex <peter@more-magic.net>
CommitDate: Tue Apr 18 15:15:53 2017 +0200

    Move delete-directory tests into posix-tests.scm
    
    This moves the dotfile and symlink-related behaviour checks for
    `delete-directory` into posix-tests.scm and out of the test scripts
    themselves, and removes a potentially dangerous operation that would
    symlink to a system directory when deleting files.
    
    Signed-off-by: Peter Bex <peter@more-magic.net>

diff --git a/tests/posix-tests.scm b/tests/posix-tests.scm
index 04052ad2..ac4a36b7 100644
--- a/tests/posix-tests.scm
+++ b/tests/posix-tests.scm
@@ -46,13 +46,35 @@
   (assert (equal? 'ok (read in)))
   (assert (equal? 'err (read err))))
 
-(let* ((tmp-dir (create-temporary-directory))
-       (tmp-dot (make-pathname (list tmp-dir "foo" "bar") ".baz")))
-  (create-directory tmp-dot 'recursively)
-  (assert (directory-exists? tmp-dot))
-  (delete-directory tmp-dir 'recursively)
-  (assert (not (directory-exists? tmp-dot)))
-  (assert (not (directory-exists? tmp-dir))))
+;; delete-directory
+(let* ((t (create-temporary-directory))
+       (t/a (make-pathname t "a"))
+       (t/a/file (make-pathname t/a "file"))
+       (t/b (make-pathname t "b"))
+       (t/b/c (make-pathname t/b "c"))
+       (t/b/c/link (make-pathname t/b/c "link"))
+       (t/b/c/.file (make-pathname t/b/c ".file")))
+  ;; Create file under a:
+  (create-directory t/a)
+  (with-output-to-file t/a/file void)
+  ;; Create directories under b:
+  (create-directory t/b/c/.file 'recursively)
+  (assert (directory? t/b/c/.file))
+  (when (or (feature? #:unix) (feature? #:cygwin))
+    (create-symbolic-link t/a t/b/c/link)
+    (assert (directory? t/b/c/link)))
+  ;; Delete directory tree at b:
+  (delete-directory t/b 'recursively)
+  (assert (not (directory? t/b/c/.file)))
+  (assert (not (directory? t/b/c/link)))
+  (assert (not (directory? t/b/c)))
+  (assert (not (directory? t/b)))
+  ;; Make sure symlink wasn't followed:
+  (assert (directory? t/a))
+  (assert (regular-file? t/a/file))
+  ;; Clean up temporary directory:
+  (delete-directory t 'recursively)
+  (assert (not (directory? t))))
 
 ;; unset-environment-variable!
 (set-environment-variable! "FOO" "bar")
diff --git a/tests/runtests.bat b/tests/runtests.bat
index cdefd97f..cb3871c8 100644
--- a/tests/runtests.bat
+++ b/tests/runtests.bat
@@ -454,11 +454,6 @@ echo ======================================== posix tests ...
 if errorlevel 1 exit /b 1
 a.out
 if errorlevel 1 exit /b 1
-del /f /q /s tmpdir
-mkdir tmpdir
-echo 0 >tmpdir\.dotfile
-%interpret% -R posix -e "(delete-directory \"tmpdir\" #t)"
-if errorlevel 1 exit /b 1
 
 echo ======================================== find-files tests ...
 %interpret% -bnq test-find-files.scm
diff --git a/tests/runtests.sh b/tests/runtests.sh
index 74e7ecfa..852492a2 100755
--- a/tests/runtests.sh
+++ b/tests/runtests.sh
@@ -405,19 +405,10 @@ $interpret -s srfi-45-tests.scm
 echo "======================================== posix tests ..."
 $compile posix-tests.scm
 ./a.out
-rm -fr tmpdir
-mkdir tmpdir
-touch tmpdir/.dotfile
 
 echo "======================================== find-files tests ..."
 $interpret -bnq test-find-files.scm
 
-if test -z "$MSYSTEM"; then
-    ln -s /usr tmpdir/symlink
-fi
-
-$interpret -R posix -e '(delete-directory "tmpdir" #t)'
-
 echo "======================================== regular expression tests ..."
 $interpret -bnq test-irregex.scm
 $interpret -bnq test-glob.scm