[bknr-cvs] edi changed trunk/thirdparty/cl-fad/
BKNR Commits
bknr at bknr.net
Wed May 25 14:40:41 UTC 2011
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)
More information about the Bknr-cvs
mailing list