Skip to content

Commit f3b7abb

Browse files
author
Edi Weitz
committed
Symlink behavior
git-svn-id: svn://bknr.net/svn/trunk/thirdparty/cl-fad@4667 4281704c-cde7-0310-8518-8e2dc76b1ff0
1 parent 33dfa62 commit f3b7abb

File tree

4 files changed

+119
-48
lines changed

4 files changed

+119
-48
lines changed

CHANGELOG

Lines changed: 4 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -1,3 +1,7 @@
1+
Version 0.6.5
2+
xxx
3+
Fix symlink behaviour for some platforms (Mihai Bazon and Janis Dzerins)
4+
15
Version 0.6.4
26
2010-11-18
37
Adapt to newer ClozureCL version (patch from Zach Beane, thanks to Chun Tian and Ralph Moritz as well)

doc/index.html

Lines changed: 33 additions & 4 deletions
Original file line numberDiff line numberDiff line change
@@ -164,18 +164,31 @@ <h2>CL-FAD - A portable pathname library for Common Lisp</h2>
164164
</blockquote>
165165

166166
<p><br>[Function]
167-
<br><a class=none name="list-directory"><b>list-directory</b> <i> dirname </i> =&gt; <i> list</i></a>
167+
<br><a class=none name="list-directory"><b>list-directory</b> <i> dirname <tt>&amp;key</tt> follow-symlinks</i> =&gt; <i> list</i></a>
168168

169169
<blockquote><br>
170-
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
170+
<p>
171+
Returns a <a href="http://www.lispworks.com/documentation/HyperSpec/Body/26_glo_f.htm#fresh">fresh</a> list of pathnames corresponding to
171172
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
172173
<em>directory form</em> - see <a href="#pathname-as-directory"><code>PATHNAME-AS-DIRECTORY</code></a>.
174+
</p>
175+
<p>
176+
If <code><i>follow-symlinks</i></code> is true (which is the
177+
default), then the returned list contains truenames (symlinks will
178+
be resolved) which essentially means that it might also return files
179+
from <b>outside</b> the directory. This works on all platforms.
180+
</p>
181+
<p>
182+
When <code><i>follow-symlinks</i></code> is <code>NIL</code>, it should return the actual directory
183+
contents, which might include symlinks. (This is currently implemented only on SBCL and CCL.)
184+
</p>
173185
</blockquote>
174186

175187
<p><br>[Function]
176-
<br><a class=none name="walk-directory"><b>walk-directory</b> <i> dirname fn <tt>&amp;key</tt> directories if-does-not-exist test</i> =&gt; |</a>
188+
<br><a class=none name="walk-directory"><b>walk-directory</b> <i> dirname fn <tt>&amp;key</tt> directories if-does-not-exist test follow-symlinks</i> =&gt; |</a>
177189

178190
<blockquote><br>
191+
<p>
179192
Recursively applies the function designated by the <a href="http://www.lispworks.com/documentation/HyperSpec/Body/26_glo_f.htm#function_designator">function
180193
designator</a> <code><i>fn</i></code> to all files within the directory named
181194
by the non-wild <a href="http://www.lispworks.com/documentation/HyperSpec/Body/26_glo_p.htm#pathname_designator">pathname
@@ -190,17 +203,33 @@ <h2>CL-FAD - A portable pathname library for Common Lisp</h2>
190203
directory's content will be skipped. <code><i>if-does-not-exist</i></code> must
191204
be one of <code>:ERROR</code> or <code>:IGNORE</code> where <code>:ERROR</code>
192205
(the default) means that an error will be signaled if the directory <code><i>dirname</i></code>
193-
does not exist. </blockquote>
206+
does not exist.
207+
</p>
208+
<p>
209+
If <code><i>follow-symlinks</i></code> is true (which is
210+
the default), then your callback will receive truenames. Otherwise
211+
you should get the actual directory contents, which might include
212+
symlinks. This might not be supported on all platforms. See
213+
<a href="#list-directory"><code>LIST-DIRECTORY</code></a>.
214+
</p>
215+
</blockquote>
194216

195217
<p><br>[Function]
196218
<br><a class=none name="delete-directory-and-files"><b>delete-directory-and-files</b> <i> dirname<tt>&amp;key</tt> if-does-not-exist</i> =&gt; |</a>
197219

198220
<blockquote><br>
221+
<p>
199222
Recursively deletes all files and directories within the directory
200223
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
201224
<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>
202225
where <code>:ERROR</code> (the default) means that an error will be signaled if the directory
203226
<code><i>dirname</i></code> does not exist.
227+
</p>
228+
<p>
229+
<b>Warning:</b> this function <em>might</em> remove files from outside the
230+
directory, if the directory that you are deleting contains links to
231+
external files. This is currently fixed for SBCL and CCL.
232+
</p>
204233
</blockquote>
205234

206235
<p><br>[Function]

fad.lisp

Lines changed: 79 additions & 44 deletions
Original file line numberDiff line numberDiff line change
@@ -39,7 +39,7 @@ is neither NIL nor the keyword :UNSPECIFIC."
3939
"Returns NIL if PATHSPEC \(a pathname designator) does not designate
4040
a directory, PATHSPEC otherwise. It is irrelevant whether file or
4141
directory designated by PATHSPEC does actually exist."
42-
(and
42+
(and
4343
(not (component-present-p (pathname-name pathspec)))
4444
(not (component-present-p (pathname-type pathspec)))
4545
pathspec))
@@ -80,23 +80,33 @@ sub-directories are returned by DIRECTORY."
8080
:type nil
8181
:defaults wildcard))
8282

83-
(defun list-directory (dirname)
84-
"Returns a fresh list of pathnames corresponding to the truenames of
85-
all files within the directory named by the non-wild pathname
86-
designator DIRNAME. The pathnames of sub-directories are returned in
87-
directory form - see PATHNAME-AS-DIRECTORY."
83+
(defun list-directory (dirname &key (follow-symlinks t))
84+
"Returns a fresh list of pathnames corresponding to all files within
85+
the directory named by the non-wild pathname designator DIRNAME. The
86+
pathnames of sub-directories are returned in directory form - see
87+
PATHNAME-AS-DIRECTORY.
88+
89+
If FOLLOW-SYMLINKS is true, then the returned list contains
90+
truenames (symlinks will be resolved) which essentially means that it
91+
might also return files from *outside* the directory. This works on
92+
all platforms.
93+
94+
When FOLLOW-SYMLINKS is NIL, it should return the actual directory
95+
contents, which might include symlinks. Currently this works on SBCL
96+
and CCL."
8897
(when (wild-pathname-p dirname)
8998
(error "Can only list concrete directory names."))
90-
#+:ecl
99+
#+:ecl
91100
(let ((dir (pathname-as-directory dirname)))
92101
(concatenate 'list
93102
(directory (merge-pathnames (pathname "*/") dir))
94103
(directory (merge-pathnames (pathname "*.*") dir))))
95-
#-:ecl
104+
#-:ecl
96105
(let ((wildcard (directory-wildcard dirname)))
97106
#+:abcl (system::list-directory dirname)
98-
#+(or :sbcl :cmu :scl :lispworks) (directory wildcard)
99-
#+(or :openmcl :digitool) (directory wildcard :directories t)
107+
#+:sbcl (directory wildcard :resolve-symlinks follow-symlinks)
108+
#+(or :cmu :scl :lispworks) (directory wildcard)
109+
#+(or :openmcl :digitool) (directory wildcard :directories t :follow-links follow-symlinks)
100110
#+:allegro (directory wildcard :directories-are-files nil)
101111
#+:clisp (nconc (directory wildcard :if-does-not-exist :keep)
102112
(directory (clisp-subdirectories-wildcard wildcard)))
@@ -160,32 +170,36 @@ by PATHNAME-AS-DIRECTORY."
160170

161171
(defun walk-directory (dirname fn &key directories
162172
(if-does-not-exist :error)
163-
(test (constantly t)))
173+
(test (constantly t))
174+
(follow-symlinks t))
164175
"Recursively applies the function FN to all files within the
165176
directory named by the non-wild pathname designator DIRNAME and all of
166177
its sub-directories. FN will only be applied to files for which the
167178
function TEST returns a true value. If DIRECTORIES is not NIL, FN and
168-
TEST are applied to directories as well. If DIRECTORIES is :DEPTH-FIRST,
169-
FN will be applied to the directory's contents first. If
170-
DIRECTORIES is :BREADTH-FIRST and TEST returns NIL, the
171-
directory's content will be skipped. IF-DOES-NOT-EXIST must be
172-
one of :ERROR or :IGNORE where :ERROR means that an error will be
173-
signaled if the directory DIRNAME does not exist."
179+
TEST are applied to directories as well. If DIRECTORIES
180+
is :DEPTH-FIRST, FN will be applied to the directory's contents first.
181+
If DIRECTORIES is :BREADTH-FIRST and TEST returns NIL, the directory's
182+
content will be skipped. IF-DOES-NOT-EXIST must be one of :ERROR
183+
or :IGNORE where :ERROR means that an error will be signaled if the
184+
directory DIRNAME does not exist. If FOLLOW-SYMLINKS is T, then your
185+
callback will receive truenames. Otherwise you should get the actual
186+
directory contents, which might include symlinks. This might not be
187+
supported on all platforms. See LIST-DIRECTORY."
174188
(labels ((walk (name)
175189
(cond
176190
((directory-pathname-p name)
177191
;; the code is written in a slightly awkward way for
178192
;; backward compatibility
179193
(cond ((not directories)
180-
(dolist (file (list-directory name))
194+
(dolist (file (list-directory name :follow-symlinks follow-symlinks))
181195
(walk file)))
182196
((eql directories :breadth-first)
183197
(when (funcall test name)
184198
(funcall fn name)
185-
(dolist (file (list-directory name))
199+
(dolist (file (list-directory name :follow-symlinks follow-symlinks))
186200
(walk file))))
187201
;; :DEPTH-FIRST is implicit
188-
(t (dolist (file (list-directory name))
202+
(t (dolist (file (list-directory name :follow-symlinks follow-symlinks))
189203
(walk file))
190204
(when (funcall test name)
191205
(funcall fn name)))))
@@ -253,32 +267,53 @@ OVERWRITE is true overwrites the file designtated by TO if it exists."
253267
designated by the non-wild pathname designator DIRNAME including
254268
DIRNAME itself. IF-DOES-NOT-EXIST must be one of :ERROR or :IGNORE
255269
where :ERROR means that an error will be signaled if the directory
256-
DIRNAME does not exist."
270+
DIRNAME does not exist.
271+
272+
NOTE: this function is dangerous if the directory that you are
273+
removing contains symlinks to files outside of it - the target files
274+
might be removed instead! This is currently fixed for SBCL and CCL."
275+
257276
#+:allegro (excl.osi:delete-directory-and-files dirname
258277
:if-does-not-exist if-does-not-exist)
259-
#-:allegro (walk-directory dirname
260-
(lambda (file)
261-
(cond ((directory-pathname-p file)
262-
#+:lispworks (lw:delete-directory file)
263-
#+:cmu (multiple-value-bind (ok err-number)
264-
(unix:unix-rmdir (namestring (truename file)))
265-
(unless ok
266-
(error "Error number ~A when trying to delete ~A"
267-
err-number file)))
268-
#+:scl (multiple-value-bind (ok errno)
269-
(unix:unix-rmdir (ext:unix-namestring (truename file)))
270-
(unless ok
271-
(error "~@<Error deleting ~S: ~A~@:>"
272-
file (unix:get-unix-error-msg errno))))
273-
#+:sbcl (sb-posix:rmdir file)
274-
#+:clisp (ext:delete-dir file)
275-
#+:openmcl (cl-fad-ccl:delete-directory file)
276-
#+:cormanlisp (win32:delete-directory file)
277-
#+:ecl (si:rmdir file)
278-
#+(or :abcl :digitool) (delete-file file))
279-
(t (delete-file file))))
280-
:directories t
281-
:if-does-not-exist if-does-not-exist)
278+
279+
#+:sbcl
280+
(if (directory-exists-p dirname)
281+
(sb-ext:delete-directory dirname :recursive t)
282+
(ecase if-does-not-exist
283+
(:error (error "~S is not a directory" dirname))
284+
(:ignore nil)))
285+
286+
#+:ccl-has-delete-directory
287+
(if (directory-exists-p dirname)
288+
(ccl:delete-directory dirname)
289+
(ecase if-does-not-exist
290+
(:error (error "~S is not a directory" dirname))
291+
(:ignore nil)))
292+
293+
#-(or :allegro :sbcl :ccl-has-delete-directory)
294+
(walk-directory dirname
295+
(lambda (file)
296+
(cond ((directory-pathname-p file)
297+
#+:lispworks (lw:delete-directory file)
298+
#+:cmu (multiple-value-bind (ok err-number)
299+
(unix:unix-rmdir (namestring (truename file)))
300+
(unless ok
301+
(error "Error number ~A when trying to delete ~A"
302+
err-number file)))
303+
#+:scl (multiple-value-bind (ok errno)
304+
(unix:unix-rmdir (ext:unix-namestring (truename file)))
305+
(unless ok
306+
(error "~@<Error deleting ~S: ~A~@:>"
307+
file (unix:get-unix-error-msg errno))))
308+
#+:clisp (ext:delete-dir file)
309+
#+:openmcl (cl-fad-ccl:delete-directory file)
310+
#+:cormanlisp (win32:delete-directory file)
311+
#+:ecl (si:rmdir file)
312+
#+(or :abcl :digitool) (delete-file file))
313+
(t (delete-file file))))
314+
:follow-symlinks nil
315+
:directories t
316+
:if-does-not-exist if-does-not-exist)
282317
(values))
283318

284319
(pushnew :cl-fad *features*)

openmcl.lisp

Lines changed: 3 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -59,6 +59,9 @@
5959

6060
;;; ClozureCL 1.6 introduced ccl:delete-directory with semantics that
6161
;;; are acceptably similar to this "legacy" definition.
62+
;;;
63+
;;; Except this legacy definition is not recursive, hence this function is
64+
;;; used only if there is no :CCL-HAS-DELETE-DIRECTORY feature.
6265

6366
#-ccl-has-delete-directory
6467
(defun delete-directory (path)

0 commit comments

Comments
 (0)