~ chicken-core (chicken-5) 1cf1f95b8762a385647cbae839882cf00b03430a

commit 1cf1f95b8762a385647cbae839882cf00b03430a
Author:     felix <felix@call-with-current-continuation.org>
AuthorDate: Mon Oct 25 02:05:48 2010 -0400
Commit:     felix <felix@call-with-current-continuation.org>
CommitDate: Mon Oct 25 02:05:48 2010 -0400

    find-files did not respect follow-symlinks; fixed brokenness in delete-directory

diff --git a/posix-common.scm b/posix-common.scm
index 40eb2293..07e8efb1 100644
--- a/posix-common.scm
+++ b/posix-common.scm
@@ -246,10 +246,17 @@ EOF
     (##sys#check-string name 'delete-directory)
     (let ((name (##sys#expand-home-path name)))
       (if recursive
-	  (let ((files (find-files name))) ; relies on `find-files' lists dir-contents before dir
+	  (let ((files (find-files ; relies on `find-files' to list dir-contents before dir
+			name 
+			dotfiles: #t
+			follow-symlinks: #f)))
 	    (for-each
 	     (lambda (f)
-	       ((if (directory? f) rmdir delete-file) f))
+	       ((case (file-type f)
+		  ((symbolic-link) delete-file)
+		  ((directory) rmdir)
+		  (else delete-file))
+		f))
 	     files)
 	    (rmdir name))
 	  (rmdir name)))))
@@ -326,6 +333,8 @@ EOF
 		  (rest (##sys#slot fs 1)) )
 	      (cond ((directory? f)
 		     (cond ((member (pathname-file f) '("." "..")) (loop rest r))
+			   ((and (symbolic-link? f) (not follow))
+			    (loop rest (if (pproc f) (action f r) r)))
 			   ((lproc f)
 			    (loop rest
 				  (fluid-let ((depth (fx+ depth 1)))
diff --git a/tests/runtests.sh b/tests/runtests.sh
index 243a421a..563a7db3 100644
--- a/tests/runtests.sh
+++ b/tests/runtests.sh
@@ -226,6 +226,11 @@ $interpret -bnq path-tests.scm
 echo "======================================== posix tests ..."
 $compile posix-tests.scm
 ./a.out
+rm -fr tmpdir
+mkdir tmpdir
+touch tmpdir/.dotfile
+ln -s /usr tmpdir/symlink
+$interpret -R posix -e '(delete-directory "tmpdir" #t)'
 
 echo "======================================== regular expression tests ..."
 $interpret -bnq test-irregex.scm