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