Revision: 4667 Author: edi URL: http://bknr.net/trac/changeset/4667
Symlink behavior
U trunk/thirdparty/cl-fad/CHANGELOG U trunk/thirdparty/cl-fad/doc/index.html U trunk/thirdparty/cl-fad/fad.lisp U trunk/thirdparty/cl-fad/openmcl.lisp
Modified: trunk/thirdparty/cl-fad/CHANGELOG =================================================================== --- trunk/thirdparty/cl-fad/CHANGELOG 2011-05-01 07:30:43 UTC (rev 4666) +++ trunk/thirdparty/cl-fad/CHANGELOG 2011-05-25 14:40:41 UTC (rev 4667) @@ -1,3 +1,7 @@ +Version 0.6.5 +xxx +Fix symlink behaviour for some platforms (Mihai Bazon and Janis Dzerins) + Version 0.6.4 2010-11-18 Adapt to newer ClozureCL version (patch from Zach Beane, thanks to Chun Tian and Ralph Moritz as well)
Modified: trunk/thirdparty/cl-fad/doc/index.html =================================================================== --- trunk/thirdparty/cl-fad/doc/index.html 2011-05-01 07:30:43 UTC (rev 4666) +++ trunk/thirdparty/cl-fad/doc/index.html 2011-05-25 14:40:41 UTC (rev 4667) @@ -164,18 +164,31 @@ </blockquote>
<p><br>[Function] -<br><a class=none name="list-directory"><b>list-directory</b> <i> dirname </i> => <i> list</i></a> +<br><a class=none name="list-directory"><b>list-directory</b> <i> dirname <tt>&key</tt> follow-symlinks</i> => <i> list</i></a>
<blockquote><br> -Returns a <a href="http://www.lispworks.com/documentation/HyperSpec/Body/26_glo_f.htm#fresh">fresh</a> list of pathnames corresponding to the truenames of +<p> +Returns a <a href="http://www.lispworks.com/documentation/HyperSpec/Body/26_glo_f.htm#fresh">fresh</a> list of pathnames corresponding to all files within the directory named by the non-wild <a href="http://www.lispworks.com/documentation/HyperSpec/Body/26_glo_p.htm#pathname_designator">pathname designator</a> <code><i>dirname</i></code>. The pathnames of sub-directories are returned in <em>directory form</em> - see <a href="#pathname-as-directory"><code>PATHNAME-AS-DIRECTORY</code></a>. +</p> +<p> + If <code><i>follow-symlinks</i></code> is true (which is the + default), then the returned list contains truenames (symlinks will + be resolved) which essentially means that it might also return files + from <b>outside</b> the directory. This works on all platforms. +</p> +<p> + When <code><i>follow-symlinks</i></code> is <code>NIL</code>, it should return the actual directory + contents, which might include symlinks. (This is currently implemented only on SBCL and CCL.) +</p> </blockquote>
<p><br>[Function] -<br><a class=none name="walk-directory"><b>walk-directory</b> <i> dirname fn <tt>&key</tt> directories if-does-not-exist test</i> => |</a> +<br><a class=none name="walk-directory"><b>walk-directory</b> <i> dirname fn <tt>&key</tt> directories if-does-not-exist test follow-symlinks</i> => |</a>
<blockquote><br> +<p> Recursively applies the function designated by the <a href="http://www.lispworks.com/documentation/HyperSpec/Body/26_glo_f.htm#function_designator">function designator</a> <code><i>fn</i></code> to all files within the directory named by the non-wild <a href="http://www.lispworks.com/documentation/HyperSpec/Body/26_glo_p.htm#pathname_designator">pathname @@ -190,17 +203,33 @@ directory's content will be skipped. <code><i>if-does-not-exist</i></code> must be one of <code>:ERROR</code> or <code>:IGNORE</code> where <code>:ERROR</code> (the default) means that an error will be signaled if the directory <code><i>dirname</i></code> - does not exist. </blockquote> + does not exist. +</p> +<p> + If <code><i>follow-symlinks</i></code> is true (which is + the default), then your callback will receive truenames. Otherwise + you should get the actual directory contents, which might include + symlinks. This might not be supported on all platforms. See + <a href="#list-directory"><code>LIST-DIRECTORY</code></a>. +</p> +</blockquote>
<p><br>[Function] <br><a class=none name="delete-directory-and-files"><b>delete-directory-and-files</b> <i> dirname<tt>&key</tt> if-does-not-exist</i> => |</a>
<blockquote><br> +<p> Recursively deletes all files and directories within the directory designated by the non-wild <a href="http://www.lispworks.com/documentation/HyperSpec/Body/26_glo_p.htm#pathname_designator">pathname designator</a> <code><i>dirname</i></code> including <code><i>dirname</i></code> itself. <code><i>if-does-not-exist</i></code> must be one of <code>:ERROR</code> or <code>:IGNORE</code> where <code>:ERROR</code> (the default) means that an error will be signaled if the directory <code><i>dirname</i></code> does not exist. +</p> +<p> + <b>Warning:</b> this function <em>might</em> remove files from outside the + directory, if the directory that you are deleting contains links to + external files. This is currently fixed for SBCL and CCL. +</p> </blockquote>
<p><br>[Function]
Modified: trunk/thirdparty/cl-fad/fad.lisp =================================================================== --- trunk/thirdparty/cl-fad/fad.lisp 2011-05-01 07:30:43 UTC (rev 4666) +++ trunk/thirdparty/cl-fad/fad.lisp 2011-05-25 14:40:41 UTC (rev 4667) @@ -39,7 +39,7 @@ "Returns NIL if PATHSPEC (a pathname designator) does not designate a directory, PATHSPEC otherwise. It is irrelevant whether file or directory designated by PATHSPEC does actually exist." - (and + (and (not (component-present-p (pathname-name pathspec))) (not (component-present-p (pathname-type pathspec))) pathspec)) @@ -80,23 +80,33 @@ :type nil :defaults wildcard))
-(defun list-directory (dirname) - "Returns a fresh list of pathnames corresponding to the truenames of -all files within the directory named by the non-wild pathname -designator DIRNAME. The pathnames of sub-directories are returned in -directory form - see PATHNAME-AS-DIRECTORY." +(defun list-directory (dirname &key (follow-symlinks t)) + "Returns a fresh list of pathnames corresponding to all files within +the directory named by the non-wild pathname designator DIRNAME. The +pathnames of sub-directories are returned in directory form - see +PATHNAME-AS-DIRECTORY. + +If FOLLOW-SYMLINKS is true, then the returned list contains +truenames (symlinks will be resolved) which essentially means that it +might also return files from *outside* the directory. This works on +all platforms. + +When FOLLOW-SYMLINKS is NIL, it should return the actual directory +contents, which might include symlinks. Currently this works on SBCL +and CCL." (when (wild-pathname-p dirname) (error "Can only list concrete directory names.")) - #+:ecl + #+:ecl (let ((dir (pathname-as-directory dirname))) (concatenate 'list (directory (merge-pathnames (pathname "*/") dir)) (directory (merge-pathnames (pathname "*.*") dir)))) - #-:ecl + #-:ecl (let ((wildcard (directory-wildcard dirname))) #+:abcl (system::list-directory dirname) - #+(or :sbcl :cmu :scl :lispworks) (directory wildcard) - #+(or :openmcl :digitool) (directory wildcard :directories t) + #+:sbcl (directory wildcard :resolve-symlinks follow-symlinks) + #+(or :cmu :scl :lispworks) (directory wildcard) + #+(or :openmcl :digitool) (directory wildcard :directories t :follow-links follow-symlinks) #+:allegro (directory wildcard :directories-are-files nil) #+:clisp (nconc (directory wildcard :if-does-not-exist :keep) (directory (clisp-subdirectories-wildcard wildcard))) @@ -160,32 +170,36 @@
(defun walk-directory (dirname fn &key directories (if-does-not-exist :error) - (test (constantly t))) + (test (constantly t)) + (follow-symlinks t)) "Recursively applies the function FN to all files within the directory named by the non-wild pathname designator DIRNAME and all of its sub-directories. FN will only be applied to files for which the function TEST returns a true value. If DIRECTORIES is not NIL, FN and -TEST are applied to directories as well. If DIRECTORIES is :DEPTH-FIRST, -FN will be applied to the directory's contents first. If -DIRECTORIES is :BREADTH-FIRST and TEST returns NIL, the -directory's content will be skipped. IF-DOES-NOT-EXIST must be -one of :ERROR or :IGNORE where :ERROR means that an error will be -signaled if the directory DIRNAME does not exist." +TEST are applied to directories as well. If DIRECTORIES +is :DEPTH-FIRST, FN will be applied to the directory's contents first. +If DIRECTORIES is :BREADTH-FIRST and TEST returns NIL, the directory's +content will be skipped. IF-DOES-NOT-EXIST must be one of :ERROR +or :IGNORE where :ERROR means that an error will be signaled if the +directory DIRNAME does not exist. If FOLLOW-SYMLINKS is T, then your +callback will receive truenames. Otherwise you should get the actual +directory contents, which might include symlinks. This might not be +supported on all platforms. See LIST-DIRECTORY." (labels ((walk (name) (cond ((directory-pathname-p name) ;; the code is written in a slightly awkward way for ;; backward compatibility (cond ((not directories) - (dolist (file (list-directory name)) + (dolist (file (list-directory name :follow-symlinks follow-symlinks)) (walk file))) ((eql directories :breadth-first) (when (funcall test name) (funcall fn name) - (dolist (file (list-directory name)) + (dolist (file (list-directory name :follow-symlinks follow-symlinks)) (walk file)))) ;; :DEPTH-FIRST is implicit - (t (dolist (file (list-directory name)) + (t (dolist (file (list-directory name :follow-symlinks follow-symlinks)) (walk file)) (when (funcall test name) (funcall fn name))))) @@ -253,32 +267,53 @@ designated by the non-wild pathname designator DIRNAME including DIRNAME itself. IF-DOES-NOT-EXIST must be one of :ERROR or :IGNORE where :ERROR means that an error will be signaled if the directory -DIRNAME does not exist." +DIRNAME does not exist. + +NOTE: this function is dangerous if the directory that you are +removing contains symlinks to files outside of it - the target files +might be removed instead! This is currently fixed for SBCL and CCL." + #+:allegro (excl.osi:delete-directory-and-files dirname :if-does-not-exist if-does-not-exist) - #-:allegro (walk-directory dirname - (lambda (file) - (cond ((directory-pathname-p file) - #+:lispworks (lw:delete-directory file) - #+:cmu (multiple-value-bind (ok err-number) - (unix:unix-rmdir (namestring (truename file))) - (unless ok - (error "Error number ~A when trying to delete ~A" - err-number file))) - #+:scl (multiple-value-bind (ok errno) - (unix:unix-rmdir (ext:unix-namestring (truename file))) - (unless ok - (error "~@<Error deleting ~S: ~A~@:>" - file (unix:get-unix-error-msg errno)))) - #+:sbcl (sb-posix:rmdir file) - #+:clisp (ext:delete-dir file) - #+:openmcl (cl-fad-ccl:delete-directory file) - #+:cormanlisp (win32:delete-directory file) - #+:ecl (si:rmdir file) - #+(or :abcl :digitool) (delete-file file)) - (t (delete-file file)))) - :directories t - :if-does-not-exist if-does-not-exist) + + #+:sbcl + (if (directory-exists-p dirname) + (sb-ext:delete-directory dirname :recursive t) + (ecase if-does-not-exist + (:error (error "~S is not a directory" dirname)) + (:ignore nil))) + + #+:ccl-has-delete-directory + (if (directory-exists-p dirname) + (ccl:delete-directory dirname) + (ecase if-does-not-exist + (:error (error "~S is not a directory" dirname)) + (:ignore nil))) + + #-(or :allegro :sbcl :ccl-has-delete-directory) + (walk-directory dirname + (lambda (file) + (cond ((directory-pathname-p file) + #+:lispworks (lw:delete-directory file) + #+:cmu (multiple-value-bind (ok err-number) + (unix:unix-rmdir (namestring (truename file))) + (unless ok + (error "Error number ~A when trying to delete ~A" + err-number file))) + #+:scl (multiple-value-bind (ok errno) + (unix:unix-rmdir (ext:unix-namestring (truename file))) + (unless ok + (error "~@<Error deleting ~S: ~A~@:>" + file (unix:get-unix-error-msg errno)))) + #+:clisp (ext:delete-dir file) + #+:openmcl (cl-fad-ccl:delete-directory file) + #+:cormanlisp (win32:delete-directory file) + #+:ecl (si:rmdir file) + #+(or :abcl :digitool) (delete-file file)) + (t (delete-file file)))) + :follow-symlinks nil + :directories t + :if-does-not-exist if-does-not-exist) (values))
(pushnew :cl-fad *features*)
Modified: trunk/thirdparty/cl-fad/openmcl.lisp =================================================================== --- trunk/thirdparty/cl-fad/openmcl.lisp 2011-05-01 07:30:43 UTC (rev 4666) +++ trunk/thirdparty/cl-fad/openmcl.lisp 2011-05-25 14:40:41 UTC (rev 4667) @@ -59,6 +59,9 @@
;;; ClozureCL 1.6 introduced ccl:delete-directory with semantics that ;;; are acceptably similar to this "legacy" definition. +;;; +;;; Except this legacy definition is not recursive, hence this function is +;;; used only if there is no :CCL-HAS-DELETE-DIRECTORY feature.
#-ccl-has-delete-directory (defun delete-directory (path)
-
BKNR Commits