filesystem.lisp - clic - Clic is an command line interactive client for gopher written in Common LISP
(HTM) git clone git://bitreich.org/clic/ git://enlrupgkhuxnvlhsf6lc3fziv5h2hhfrinws65d7roiv6bfj7d652fid.onion/clic/
(DIR) Log
(DIR) Files
(DIR) Refs
(DIR) Tags
(DIR) README
(DIR) LICENSE
---
filesystem.lisp (36531B)
---
1 ;;;; -------------------------------------------------------------------------
2 ;;;; Portability layer around Common Lisp filesystem access
3
4 (uiop/package:define-package :uiop/filesystem
5 (:use :uiop/common-lisp :uiop/package :uiop/utility :uiop/os :uiop/pathname)
6 (:export
7 ;; Native namestrings
8 #:native-namestring #:parse-native-namestring
9 ;; Probing the filesystem
10 #:truename* #:safe-file-write-date #:probe-file* #:directory-exists-p #:file-exists-p
11 #:directory* #:filter-logical-directory-results #:directory-files #:subdirectories
12 #:collect-sub*directories
13 ;; Resolving symlinks somewhat
14 #:truenamize #:resolve-symlinks #:*resolve-symlinks* #:resolve-symlinks*
15 ;; merging with cwd
16 #:get-pathname-defaults #:call-with-current-directory #:with-current-directory
17 ;; Environment pathnames
18 #:inter-directory-separator #:split-native-pathnames-string
19 #:getenv-pathname #:getenv-pathnames
20 #:getenv-absolute-directory #:getenv-absolute-directories
21 #:lisp-implementation-directory #:lisp-implementation-pathname-p
22 ;; Simple filesystem operations
23 #:ensure-all-directories-exist
24 #:rename-file-overwriting-target
25 #:delete-file-if-exists #:delete-empty-directory #:delete-directory-tree))
26 (in-package :uiop/filesystem)
27
28 ;;; Native namestrings, as seen by the operating system calls rather than Lisp
29 (with-upgradability ()
30 (defun native-namestring (x)
31 "From a non-wildcard CL pathname, a return namestring suitable for passing to the operating system"
32 (when x
33 (let ((p (pathname x)))
34 #+clozure (with-pathname-defaults () (ccl:native-translated-namestring p)) ; see ccl bug 978
35 #+(or cmucl scl) (ext:unix-namestring p nil)
36 #+sbcl (sb-ext:native-namestring p)
37 #-(or clozure cmucl sbcl scl)
38 (os-cond
39 ((os-unix-p) (unix-namestring p))
40 (t (namestring p))))))
41
42 (defun parse-native-namestring (string &rest constraints &key ensure-directory &allow-other-keys)
43 "From a native namestring suitable for use by the operating system, return
44 a CL pathname satisfying all the specified constraints as per ENSURE-PATHNAME"
45 (check-type string (or string null))
46 (let* ((pathname
47 (when string
48 (with-pathname-defaults ()
49 #+clozure (ccl:native-to-pathname string)
50 #+cmucl (uiop/os::parse-unix-namestring* string)
51 #+sbcl (sb-ext:parse-native-namestring string)
52 #+scl (lisp::parse-unix-namestring string)
53 #-(or clozure cmucl sbcl scl)
54 (os-cond
55 ((os-unix-p) (parse-unix-namestring string :ensure-directory ensure-directory))
56 (t (parse-namestring string))))))
57 (pathname
58 (if ensure-directory
59 (and pathname (ensure-directory-pathname pathname))
60 pathname)))
61 (apply 'ensure-pathname pathname constraints))))
62
63
64 ;;; Probing the filesystem
65 (with-upgradability ()
66 (defun truename* (p)
67 "Nicer variant of TRUENAME that plays well with NIL, avoids logical pathname contexts, and tries both files and directories"
68 (when p
69 (when (stringp p) (setf p (with-pathname-defaults () (parse-namestring p))))
70 (values
71 (or (ignore-errors (truename p))
72 ;; this is here because trying to find the truename of a directory pathname WITHOUT supplying
73 ;; a trailing directory separator, causes an error on some lisps.
74 #+(or clisp gcl) (if-let (d (ensure-directory-pathname p nil)) (ignore-errors (truename d)))
75 ;; On Genera, truename of a directory pathname will probably fail as Genera
76 ;; will merge in a filename/type/version from *default-pathname-defaults* and
77 ;; will try to get the truename of a file that probably doesn't exist.
78 #+genera (when (directory-pathname-p p)
79 (let ((d (scl:send p :directory-pathname-as-file)))
80 (ensure-directory-pathname (ignore-errors (truename d)) nil)))))))
81
82 (defun safe-file-write-date (pathname)
83 "Safe variant of FILE-WRITE-DATE that may return NIL rather than raise an error."
84 ;; If FILE-WRITE-DATE returns NIL, it's possible that
85 ;; the user or some other agent has deleted an input file.
86 ;; Also, generated files will not exist at the time planning is done
87 ;; and calls compute-action-stamp which calls safe-file-write-date.
88 ;; So it is very possible that we can't get a valid file-write-date,
89 ;; and we can survive and we will continue the planning
90 ;; as if the file were very old.
91 ;; (or should we treat the case in a different, special way?)
92 (and pathname
93 (handler-case (file-write-date (physicalize-pathname pathname))
94 (file-error () nil))))
95
96 (defun probe-file* (p &key truename)
97 "when given a pathname P (designated by a string as per PARSE-NAMESTRING),
98 probes the filesystem for a file or directory with given pathname.
99 If it exists, return its truename if TRUENAME is true,
100 or the original (parsed) pathname if it is false (the default)."
101 (values
102 (ignore-errors
103 (setf p (funcall 'ensure-pathname p
104 :namestring :lisp
105 :ensure-physical t
106 :ensure-absolute t :defaults 'get-pathname-defaults
107 :want-non-wild t
108 :on-error nil))
109 (when p
110 #+allegro
111 (probe-file p :follow-symlinks truename)
112 #+gcl
113 (if truename
114 (truename* p)
115 (let ((kind (car (si::stat p))))
116 (when (eq kind :link)
117 (setf kind (ignore-errors (car (si::stat (truename* p))))))
118 (ecase kind
119 ((nil) nil)
120 ((:file :link)
121 (cond
122 ((file-pathname-p p) p)
123 ((directory-pathname-p p)
124 (subpathname p (car (last (pathname-directory p)))))))
125 (:directory (ensure-directory-pathname p)))))
126 #+clisp
127 #.(let* ((fs (or #-os-windows (find-symbol* '#:file-stat :posix nil)))
128 (pp (find-symbol* '#:probe-pathname :ext nil)))
129 `(if truename
130 ,(if pp
131 `(values (,pp p))
132 '(or (truename* p)
133 (truename* (ignore-errors (ensure-directory-pathname p)))))
134 ,(cond
135 (fs `(and (,fs p) p))
136 (pp `(nth-value 1 (,pp p)))
137 (t '(or (and (truename* p) p)
138 (if-let (d (ensure-directory-pathname p))
139 (and (truename* d) d)))))))
140 #-(or allegro clisp gcl)
141 (if truename
142 (probe-file p)
143 (and
144 #+(or cmucl scl) (unix:unix-stat (ext:unix-namestring p))
145 #+(and lispworks os-unix) (system:get-file-stat p)
146 #+sbcl (sb-unix:unix-stat (sb-ext:native-namestring p))
147 #-(or cmucl (and lispworks os-unix) sbcl scl) (file-write-date p)
148 p))))))
149
150 (defun directory-exists-p (x)
151 "Is X the name of a directory that exists on the filesystem?"
152 #+allegro
153 (excl:probe-directory x)
154 #+clisp
155 (handler-case (ext:probe-directory x)
156 (sys::simple-file-error ()
157 nil))
158 #-(or allegro clisp)
159 (let ((p (probe-file* x :truename t)))
160 (and (directory-pathname-p p) p)))
161
162 (defun file-exists-p (x)
163 "Is X the name of a file that exists on the filesystem?"
164 (let ((p (probe-file* x :truename t)))
165 (and (file-pathname-p p) p)))
166
167 (defun directory* (pathname-spec &rest keys &key &allow-other-keys)
168 "Return a list of the entries in a directory by calling DIRECTORY.
169 Try to override the defaults to not resolving symlinks, if implementation allows."
170 (apply 'directory pathname-spec
171 (append keys '#.(or #+allegro '(:directories-are-files nil :follow-symbolic-links nil)
172 #+(or clozure digitool) '(:follow-links nil)
173 #+clisp '(:circle t :if-does-not-exist :ignore)
174 #+(or cmucl scl) '(:follow-links nil :truenamep nil)
175 #+lispworks '(:link-transparency nil)
176 #+sbcl (when (find-symbol* :resolve-symlinks '#:sb-impl nil)
177 '(:resolve-symlinks nil))))))
178
179 (defun filter-logical-directory-results (directory entries merger)
180 "If DIRECTORY isn't a logical pathname, return ENTRIES. If it is,
181 given ENTRIES in the DIRECTORY, remove the entries which are physical yet
182 when transformed by MERGER have a different TRUENAME.
183 Also remove duplicates as may appear with some translation rules.
184 This function is used as a helper to DIRECTORY-FILES to avoid invalid entries
185 when using logical-pathnames."
186 (if (logical-pathname-p directory)
187 (remove-duplicates ;; on CLISP, querying ~/ will return duplicates
188 ;; Try hard to not resolve logical-pathname into physical pathnames;
189 ;; otherwise logical-pathname users/lovers will be disappointed.
190 ;; If directory* could use some implementation-dependent magic,
191 ;; we will have logical pathnames already; otherwise,
192 ;; we only keep pathnames for which specifying the name and
193 ;; translating the LPN commute.
194 (loop :for f :in entries
195 :for p = (or (and (logical-pathname-p f) f)
196 (let* ((u (ignore-errors (call-function merger f))))
197 ;; The first u avoids a cumbersome (truename u) error.
198 ;; At this point f should already be a truename,
199 ;; but isn't quite in CLISP, for it doesn't have :version :newest
200 (and u (equal (truename* u) (truename* f)) u)))
201 :when p :collect p)
202 :test 'pathname-equal)
203 entries))
204
205 (defun directory-files (directory &optional (pattern *wild-file-for-directory*))
206 "Return a list of the files in a directory according to the PATTERN.
207 Subdirectories should NOT be returned.
208 PATTERN defaults to a pattern carefully chosen based on the implementation;
209 override the default at your own risk.
210 DIRECTORY-FILES tries NOT to resolve symlinks if the implementation permits this,
211 but the behavior in presence of symlinks is not portable. Use IOlib to handle such situations."
212 (let ((dir (ensure-directory-pathname directory)))
213 (when (logical-pathname-p dir)
214 ;; Because of the filtering we do below,
215 ;; logical pathnames have restrictions on wild patterns.
216 ;; Not that the results are very portable when you use these patterns on physical pathnames.
217 (when (wild-pathname-p dir)
218 (parameter-error "~S: Invalid wild pattern in logical directory ~S"
219 'directory-files directory))
220 (unless (member (pathname-directory pattern) '(() (:relative)) :test 'equal)
221 (parameter-error "~S: Invalid file pattern ~S for logical directory ~S" 'directory-files pattern directory))
222 (setf pattern (make-pathname-logical pattern (pathname-host dir))))
223 (let* ((pat (merge-pathnames* pattern dir))
224 (entries (ignore-errors (directory* pat))))
225 (remove-if 'directory-pathname-p
226 (filter-logical-directory-results
227 directory entries
228 #'(lambda (f)
229 (make-pathname :defaults dir
230 :name (make-pathname-component-logical (pathname-name f))
231 :type (make-pathname-component-logical (pathname-type f))
232 :version (make-pathname-component-logical (pathname-version f)))))))))
233
234 (defun subdirectories (directory)
235 "Given a DIRECTORY pathname designator, return a list of the subdirectories under it.
236 The behavior in presence of symlinks is not portable. Use IOlib to handle such situations."
237 (let* ((directory (ensure-directory-pathname directory))
238 #-(or abcl cormanlisp genera xcl)
239 (wild (merge-pathnames*
240 #-(or abcl allegro cmucl lispworks sbcl scl xcl)
241 *wild-directory*
242 #+(or abcl allegro cmucl lispworks sbcl scl xcl) "*.*"
243 directory))
244 (dirs
245 #-(or abcl cormanlisp genera xcl)
246 (ignore-errors
247 (directory* wild . #.(or #+clozure '(:directories t :files nil)
248 #+mcl '(:directories t))))
249 #+(or abcl xcl) (system:list-directory directory)
250 #+cormanlisp (cl::directory-subdirs directory)
251 #+genera (handler-case (fs:directory-list directory) (fs:directory-not-found () nil)))
252 #+(or abcl allegro cmucl genera lispworks sbcl scl xcl)
253 (dirs (loop :for x :in dirs
254 :for d = #+(or abcl xcl) (extensions:probe-directory x)
255 #+allegro (excl:probe-directory x)
256 #+(or cmucl sbcl scl) (directory-pathname-p x)
257 #+genera (getf (cdr x) :directory)
258 #+lispworks (lw:file-directory-p x)
259 :when d :collect #+(or abcl allegro xcl) (ensure-directory-pathname d)
260 #+genera (ensure-directory-pathname (first x))
261 #+(or cmucl lispworks sbcl scl) x)))
262 (filter-logical-directory-results
263 directory dirs
264 (let ((prefix (or (normalize-pathname-directory-component (pathname-directory directory))
265 '(:absolute)))) ; because allegro returns NIL for #p"FOO:"
266 #'(lambda (d)
267 (let ((dir (normalize-pathname-directory-component (pathname-directory d))))
268 (and (consp dir) (consp (cdr dir))
269 (make-pathname
270 :defaults directory :name nil :type nil :version nil
271 :directory (append prefix (make-pathname-component-logical (last dir)))))))))))
272
273 (defun collect-sub*directories (directory collectp recursep collector)
274 "Given a DIRECTORY, when COLLECTP returns true when CALL-FUNCTION'ed with the directory,
275 call-function the COLLECTOR function designator on the directory,
276 and recurse each of its subdirectories on which the RECURSEP returns true when CALL-FUNCTION'ed with them.
277 This function will thus let you traverse a filesystem hierarchy,
278 superseding the functionality of CL-FAD:WALK-DIRECTORY.
279 The behavior in presence of symlinks is not portable. Use IOlib to handle such situations."
280 (when (call-function collectp directory)
281 (call-function collector directory)
282 (dolist (subdir (subdirectories directory))
283 (when (call-function recursep subdir)
284 (collect-sub*directories subdir collectp recursep collector))))))
285
286 ;;; Resolving symlinks somewhat
287 (with-upgradability ()
288 (defun truenamize (pathname)
289 "Resolve as much of a pathname as possible"
290 (block nil
291 (when (typep pathname '(or null logical-pathname)) (return pathname))
292 (let ((p pathname))
293 (unless (absolute-pathname-p p)
294 (setf p (or (absolute-pathname-p (ensure-absolute-pathname p 'get-pathname-defaults nil))
295 (return p))))
296 (when (logical-pathname-p p) (return p))
297 (let ((found (probe-file* p :truename t)))
298 (when found (return found)))
299 (let* ((directory (normalize-pathname-directory-component (pathname-directory p)))
300 (up-components (reverse (rest directory)))
301 (down-components ()))
302 (assert (eq :absolute (first directory)))
303 (loop :while up-components :do
304 (if-let (parent
305 (ignore-errors
306 (probe-file* (make-pathname :directory `(:absolute ,@(reverse up-components))
307 :name nil :type nil :version nil :defaults p))))
308 (if-let (simplified
309 (ignore-errors
310 (merge-pathnames*
311 (make-pathname :directory `(:relative ,@down-components)
312 :defaults p)
313 (ensure-directory-pathname parent))))
314 (return simplified)))
315 (push (pop up-components) down-components)
316 :finally (return p))))))
317
318 (defun resolve-symlinks (path)
319 "Do a best effort at resolving symlinks in PATH, returning a partially or totally resolved PATH."
320 #-allegro (truenamize path)
321 #+allegro
322 (if (physical-pathname-p path)
323 (or (ignore-errors (excl:pathname-resolve-symbolic-links path)) path)
324 path))
325
326 (defvar *resolve-symlinks* t
327 "Determine whether or not ASDF resolves symlinks when defining systems.
328 Defaults to T.")
329
330 (defun resolve-symlinks* (path)
331 "RESOLVE-SYMLINKS in PATH iff *RESOLVE-SYMLINKS* is T (the default)."
332 (if *resolve-symlinks*
333 (and path (resolve-symlinks path))
334 path)))
335
336
337 ;;; Check pathname constraints
338 (with-upgradability ()
339 (defun ensure-pathname
340 (pathname &key
341 on-error
342 defaults type dot-dot namestring
343 empty-is-nil
344 want-pathname
345 want-logical want-physical ensure-physical
346 want-relative want-absolute ensure-absolute ensure-subpath
347 want-non-wild want-wild wilden
348 want-file want-directory ensure-directory
349 want-existing ensure-directories-exist
350 truename resolve-symlinks truenamize
351 &aux (p pathname)) ;; mutable working copy, preserve original
352 "Coerces its argument into a PATHNAME,
353 optionally doing some transformations and checking specified constraints.
354
355 If the argument is NIL, then NIL is returned unless the WANT-PATHNAME constraint is specified.
356
357 If the argument is a STRING, it is first converted to a pathname via
358 PARSE-UNIX-NAMESTRING, PARSE-NAMESTRING or PARSE-NATIVE-NAMESTRING respectively
359 depending on the NAMESTRING argument being :UNIX, :LISP or :NATIVE respectively,
360 or else by using CALL-FUNCTION on the NAMESTRING argument;
361 if :UNIX is specified (or NIL, the default, which specifies the same thing),
362 then PARSE-UNIX-NAMESTRING it is called with the keywords
363 DEFAULTS TYPE DOT-DOT ENSURE-DIRECTORY WANT-RELATIVE, and
364 the result is optionally merged into the DEFAULTS if ENSURE-ABSOLUTE is true.
365
366 The pathname passed or resulting from parsing the string
367 is then subjected to all the checks and transformations below are run.
368
369 Each non-nil constraint argument can be one of the symbols T, ERROR, CERROR or IGNORE.
370 The boolean T is an alias for ERROR.
371 ERROR means that an error will be raised if the constraint is not satisfied.
372 CERROR means that an continuable error will be raised if the constraint is not satisfied.
373 IGNORE means just return NIL instead of the pathname.
374
375 The ON-ERROR argument, if not NIL, is a function designator (as per CALL-FUNCTION)
376 that will be called with the the following arguments:
377 a generic format string for ensure pathname, the pathname,
378 the keyword argument corresponding to the failed check or transformation,
379 a format string for the reason ENSURE-PATHNAME failed,
380 and a list with arguments to that format string.
381 If ON-ERROR is NIL, ERROR is used instead, which does the right thing.
382 You could also pass (CERROR \"CONTINUE DESPITE FAILED CHECK\").
383
384 The transformations and constraint checks are done in this order,
385 which is also the order in the lambda-list:
386
387 EMPTY-IS-NIL returns NIL if the argument is an empty string.
388 WANT-PATHNAME checks that pathname (after parsing if needed) is not null.
389 Otherwise, if the pathname is NIL, ensure-pathname returns NIL.
390 WANT-LOGICAL checks that pathname is a LOGICAL-PATHNAME
391 WANT-PHYSICAL checks that pathname is not a LOGICAL-PATHNAME
392 ENSURE-PHYSICAL ensures that pathname is physical via TRANSLATE-LOGICAL-PATHNAME
393 WANT-RELATIVE checks that pathname has a relative directory component
394 WANT-ABSOLUTE checks that pathname does have an absolute directory component
395 ENSURE-ABSOLUTE merges with the DEFAULTS, then checks again
396 that the result absolute is an absolute pathname indeed.
397 ENSURE-SUBPATH checks that the pathname is a subpath of the DEFAULTS.
398 WANT-FILE checks that pathname has a non-nil FILE component
399 WANT-DIRECTORY checks that pathname has nil FILE and TYPE components
400 ENSURE-DIRECTORY uses ENSURE-DIRECTORY-PATHNAME to interpret
401 any file and type components as being actually a last directory component.
402 WANT-NON-WILD checks that pathname is not a wild pathname
403 WANT-WILD checks that pathname is a wild pathname
404 WILDEN merges the pathname with **/*.*.* if it is not wild
405 WANT-EXISTING checks that a file (or directory) exists with that pathname.
406 ENSURE-DIRECTORIES-EXIST creates any parent directory with ENSURE-DIRECTORIES-EXIST.
407 TRUENAME replaces the pathname by its truename, or errors if not possible.
408 RESOLVE-SYMLINKS replaces the pathname by a variant with symlinks resolved by RESOLVE-SYMLINKS.
409 TRUENAMIZE uses TRUENAMIZE to resolve as many symlinks as possible."
410 (block nil
411 (flet ((report-error (keyword description &rest arguments)
412 (call-function (or on-error 'error)
413 "Invalid pathname ~S: ~*~?"
414 pathname keyword description arguments)))
415 (macrolet ((err (constraint &rest arguments)
416 `(report-error ',(intern* constraint :keyword) ,@arguments))
417 (check (constraint condition &rest arguments)
418 `(when ,constraint
419 (unless ,condition (err ,constraint ,@arguments))))
420 (transform (transform condition expr)
421 `(when ,transform
422 (,@(if condition `(when ,condition) '(progn))
423 (setf p ,expr)))))
424 (etypecase p
425 ((or null pathname))
426 (string
427 (when (and (emptyp p) empty-is-nil)
428 (return-from ensure-pathname nil))
429 (setf p (case namestring
430 ((:unix nil)
431 (parse-unix-namestring
432 p :defaults defaults :type type :dot-dot dot-dot
433 :ensure-directory ensure-directory :want-relative want-relative))
434 ((:native)
435 (parse-native-namestring p))
436 ((:lisp)
437 (parse-namestring p))
438 (t
439 (call-function namestring p))))))
440 (etypecase p
441 (pathname)
442 (null
443 (check want-pathname (pathnamep p) "Expected a pathname, not NIL")
444 (return nil)))
445 (check want-logical (logical-pathname-p p) "Expected a logical pathname")
446 (check want-physical (physical-pathname-p p) "Expected a physical pathname")
447 (transform ensure-physical () (physicalize-pathname p))
448 (check ensure-physical (physical-pathname-p p) "Could not translate to a physical pathname")
449 (check want-relative (relative-pathname-p p) "Expected a relative pathname")
450 (check want-absolute (absolute-pathname-p p) "Expected an absolute pathname")
451 (transform ensure-absolute (not (absolute-pathname-p p))
452 (ensure-absolute-pathname p defaults (list #'report-error :ensure-absolute "~@?")))
453 (check ensure-absolute (absolute-pathname-p p)
454 "Could not make into an absolute pathname even after merging with ~S" defaults)
455 (check ensure-subpath (absolute-pathname-p defaults)
456 "cannot be checked to be a subpath of non-absolute pathname ~S" defaults)
457 (check ensure-subpath (subpathp p defaults) "is not a sub pathname of ~S" defaults)
458 (check want-file (file-pathname-p p) "Expected a file pathname")
459 (check want-directory (directory-pathname-p p) "Expected a directory pathname")
460 (transform ensure-directory (not (directory-pathname-p p)) (ensure-directory-pathname p))
461 (check want-non-wild (not (wild-pathname-p p)) "Expected a non-wildcard pathname")
462 (check want-wild (wild-pathname-p p) "Expected a wildcard pathname")
463 (transform wilden (not (wild-pathname-p p)) (wilden p))
464 (when want-existing
465 (let ((existing (probe-file* p :truename truename)))
466 (if existing
467 (when truename
468 (return existing))
469 (err want-existing "Expected an existing pathname"))))
470 (when ensure-directories-exist (ensure-directories-exist p))
471 (when truename
472 (let ((truename (truename* p)))
473 (if truename
474 (return truename)
475 (err truename "Can't get a truename for pathname"))))
476 (transform resolve-symlinks () (resolve-symlinks p))
477 (transform truenamize () (truenamize p))
478 p)))))
479
480
481 ;;; Pathname defaults
482 (with-upgradability ()
483 (defun get-pathname-defaults (&optional (defaults *default-pathname-defaults*))
484 "Find the actual DEFAULTS to use for pathnames, including
485 resolving them with respect to GETCWD if the DEFAULTS were relative"
486 (or (absolute-pathname-p defaults)
487 (merge-pathnames* defaults (getcwd))))
488
489 (defun call-with-current-directory (dir thunk)
490 "call the THUNK in a context where the current directory was changed to DIR, if not NIL.
491 Note that this operation is usually NOT thread-safe."
492 (if dir
493 (let* ((dir (resolve-symlinks*
494 (get-pathname-defaults
495 (ensure-directory-pathname
496 dir))))
497 (cwd (getcwd))
498 (*default-pathname-defaults* dir))
499 (chdir dir)
500 (unwind-protect
501 (funcall thunk)
502 (chdir cwd)))
503 (funcall thunk)))
504
505 (defmacro with-current-directory ((&optional dir) &body body)
506 "Call BODY while the POSIX current working directory is set to DIR"
507 `(call-with-current-directory ,dir #'(lambda () ,@body))))
508
509
510 ;;; Environment pathnames
511 (with-upgradability ()
512 (defun inter-directory-separator ()
513 "What character does the current OS conventionally uses to separate directories?"
514 (os-cond ((os-unix-p) #\:) (t #\;)))
515
516 (defun split-native-pathnames-string (string &rest constraints &key &allow-other-keys)
517 "Given a string of pathnames specified in native OS syntax, separate them in a list,
518 check constraints and normalize each one as per ENSURE-PATHNAME,
519 where an empty string denotes NIL."
520 (loop :for namestring :in (split-string string :separator (string (inter-directory-separator)))
521 :collect (unless (emptyp namestring) (apply 'parse-native-namestring namestring constraints))))
522
523 (defun getenv-pathname (x &rest constraints &key ensure-directory want-directory on-error &allow-other-keys)
524 "Extract a pathname from a user-configured environment variable, as per native OS,
525 check constraints and normalize as per ENSURE-PATHNAME."
526 ;; For backward compatibility with ASDF 2, want-directory implies ensure-directory
527 (apply 'parse-native-namestring (getenvp x)
528 :ensure-directory (or ensure-directory want-directory)
529 :on-error (or on-error
530 `(error "In (~S ~S), invalid pathname ~*~S: ~*~?" getenv-pathname ,x))
531 constraints))
532 (defun getenv-pathnames (x &rest constraints &key on-error &allow-other-keys)
533 "Extract a list of pathname from a user-configured environment variable, as per native OS,
534 check constraints and normalize each one as per ENSURE-PATHNAME.
535 Any empty entries in the environment variable X will be returned as NILs."
536 (unless (getf constraints :empty-is-nil t)
537 (parameter-error "Cannot have EMPTY-IS-NIL false for ~S" 'getenv-pathnames))
538 (apply 'split-native-pathnames-string (getenvp x)
539 :on-error (or on-error
540 `(error "In (~S ~S), invalid pathname ~*~S: ~*~?" getenv-pathnames ,x))
541 :empty-is-nil t
542 constraints))
543 (defun getenv-absolute-directory (x)
544 "Extract an absolute directory pathname from a user-configured environment variable,
545 as per native OS"
546 (getenv-pathname x :want-absolute t :ensure-directory t))
547 (defun getenv-absolute-directories (x)
548 "Extract a list of absolute directories from a user-configured environment variable,
549 as per native OS. Any empty entries in the environment variable X will be returned as
550 NILs."
551 (getenv-pathnames x :want-absolute t :ensure-directory t))
552
553 (defun lisp-implementation-directory (&key truename)
554 "Where are the system files of the current installation of the CL implementation?"
555 (declare (ignorable truename))
556 (let ((dir
557 #+abcl extensions:*lisp-home*
558 #+(or allegro clasp ecl mkcl) #p"SYS:"
559 #+clisp custom:*lib-directory*
560 #+clozure #p"ccl:"
561 #+cmucl (ignore-errors (pathname-parent-directory-pathname (truename #p"modules:")))
562 #+gcl system::*system-directory*
563 #+lispworks lispworks:*lispworks-directory*
564 #+sbcl (if-let (it (find-symbol* :sbcl-homedir-pathname :sb-int nil))
565 (funcall it)
566 (getenv-pathname "SBCL_HOME" :ensure-directory t))
567 #+scl (ignore-errors (pathname-parent-directory-pathname (truename #p"file://modules/")))
568 #+xcl ext:*xcl-home*))
569 (if (and dir truename)
570 (truename* dir)
571 dir)))
572
573 (defun lisp-implementation-pathname-p (pathname)
574 "Is the PATHNAME under the current installation of the CL implementation?"
575 ;; Other builtin systems are those under the implementation directory
576 (and (when pathname
577 (if-let (impdir (lisp-implementation-directory))
578 (or (subpathp pathname impdir)
579 (when *resolve-symlinks*
580 (if-let (truename (truename* pathname))
581 (if-let (trueimpdir (truename* impdir))
582 (subpathp truename trueimpdir)))))))
583 t)))
584
585
586 ;;; Simple filesystem operations
587 (with-upgradability ()
588 (defun ensure-all-directories-exist (pathnames)
589 "Ensure that for every pathname in PATHNAMES, we ensure its directories exist"
590 (dolist (pathname pathnames)
591 (when pathname
592 (ensure-directories-exist (physicalize-pathname pathname)))))
593
594 (defun delete-file-if-exists (x)
595 "Delete a file X if it already exists"
596 (when x (handler-case (delete-file x) (file-error () nil))))
597
598 (defun rename-file-overwriting-target (source target)
599 "Rename a file, overwriting any previous file with the TARGET name,
600 in an atomic way if the implementation allows."
601 (let ((source (ensure-pathname source :namestring :lisp :ensure-physical t :want-file t))
602 (target (ensure-pathname target :namestring :lisp :ensure-physical t :want-file t)))
603 #+clisp ;; in recent enough versions of CLISP, :if-exists :overwrite would make it atomic
604 (progn (funcall 'require "syscalls")
605 (symbol-call :posix :copy-file source target :method :rename))
606 #+(and sbcl os-windows) (delete-file-if-exists target) ;; not atomic
607 #-clisp
608 (rename-file source target
609 #+(or clasp clozure ecl) :if-exists
610 #+clozure :rename-and-delete #+(or clasp ecl) t)))
611
612 (defun delete-empty-directory (directory-pathname)
613 "Delete an empty directory"
614 #+(or abcl digitool gcl) (delete-file directory-pathname)
615 #+allegro (excl:delete-directory directory-pathname)
616 #+clisp (ext:delete-directory directory-pathname)
617 #+clozure (ccl::delete-empty-directory directory-pathname)
618 #+(or cmucl scl) (multiple-value-bind (ok errno)
619 (unix:unix-rmdir (native-namestring directory-pathname))
620 (unless ok
621 #+cmucl (error "Error number ~A when trying to delete directory ~A"
622 errno directory-pathname)
623 #+scl (error "~@<Error deleting ~S: ~A~@:>"
624 directory-pathname (unix:get-unix-error-msg errno))))
625 #+cormanlisp (win32:delete-directory directory-pathname)
626 #+(or clasp ecl) (si:rmdir directory-pathname)
627 #+genera (fs:delete-directory directory-pathname)
628 #+lispworks (lw:delete-directory directory-pathname)
629 #+mkcl (mkcl:rmdir directory-pathname)
630 #+sbcl #.(if-let (dd (find-symbol* :delete-directory :sb-ext nil))
631 `(,dd directory-pathname) ;; requires SBCL 1.0.44 or later
632 `(progn (require :sb-posix) (symbol-call :sb-posix :rmdir directory-pathname)))
633 #+xcl (symbol-call :uiop :run-program `("rmdir" ,(native-namestring directory-pathname)))
634 #-(or abcl allegro clasp clisp clozure cmucl cormanlisp digitool ecl gcl genera lispworks mkcl sbcl scl xcl)
635 (not-implemented-error 'delete-empty-directory "(on your platform)")) ; genera
636
637 (defun delete-directory-tree (directory-pathname &key (validate nil validatep) (if-does-not-exist :error))
638 "Delete a directory including all its recursive contents, aka rm -rf.
639
640 To reduce the risk of infortunate mistakes, DIRECTORY-PATHNAME must be
641 a physical non-wildcard directory pathname (not namestring).
642
643 If the directory does not exist, the IF-DOES-NOT-EXIST argument specifies what happens:
644 if it is :ERROR (the default), an error is signaled, whereas if it is :IGNORE, nothing is done.
645
646 Furthermore, before any deletion is attempted, the DIRECTORY-PATHNAME must pass
647 the validation function designated (as per ENSURE-FUNCTION) by the VALIDATE keyword argument
648 which in practice is thus compulsory, and validates by returning a non-NIL result.
649 If you're suicidal or extremely confident, just use :VALIDATE T."
650 (check-type if-does-not-exist (member :error :ignore))
651 (setf directory-pathname (ensure-pathname directory-pathname
652 :want-pathname t :want-non-wild t
653 :want-physical t :want-directory t))
654 (cond
655 ((not validatep)
656 (parameter-error "~S was asked to delete ~S but was not provided a validation predicate"
657 'delete-directory-tree directory-pathname))
658 ((not (call-function validate directory-pathname))
659 (parameter-error "~S was asked to delete ~S but it is not valid ~@[according to ~S~]"
660 'delete-directory-tree directory-pathname validate))
661 ((not (directory-exists-p directory-pathname))
662 (ecase if-does-not-exist
663 (:error
664 (error "~S was asked to delete ~S but the directory does not exist"
665 'delete-directory-tree directory-pathname))
666 (:ignore nil)))
667 #-(or allegro cmucl clozure genera sbcl scl)
668 ((os-unix-p) ;; On Unix, don't recursively walk the directory and delete everything in Lisp,
669 ;; except on implementations where we can prevent DIRECTORY from following symlinks;
670 ;; instead spawn a standard external program to do the dirty work.
671 (symbol-call :uiop :run-program `("rm" "-rf" ,(native-namestring directory-pathname))))
672 (t
673 ;; On supported implementation, call supported system functions
674 #+allegro (symbol-call :excl.osi :delete-directory-and-files
675 directory-pathname :if-does-not-exist if-does-not-exist)
676 #+clozure (ccl:delete-directory directory-pathname)
677 #+genera (fs:delete-directory directory-pathname :confirm nil)
678 #+sbcl #.(if-let (dd (find-symbol* :delete-directory :sb-ext nil))
679 `(,dd directory-pathname :recursive t) ;; requires SBCL 1.0.44 or later
680 '(error "~S requires SBCL 1.0.44 or later" 'delete-directory-tree))
681 ;; Outside Unix or on CMUCL and SCL that can avoid following symlinks,
682 ;; do things the hard way.
683 #-(or allegro clozure genera sbcl)
684 (let ((sub*directories
685 (while-collecting (c)
686 (collect-sub*directories directory-pathname t t #'c))))
687 (dolist (d (nreverse sub*directories))
688 (map () 'delete-file (directory-files d))
689 (delete-empty-directory d)))))))