filesystem.lisp - clic - Clic is an command line interactive client for gopher … | |
git clone git://bitreich.org/clic/ git://enlrupgkhuxnvlhsf6lc3fziv5h2hhfrinws65… | |
Log | |
Files | |
Refs | |
Tags | |
README | |
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/pat… | |
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… | |
11 #:directory* #:filter-logical-directory-results #:directory-files #:s… | |
12 #:collect-sub*directories | |
13 ;; Resolving symlinks somewhat | |
14 #:truenamize #:resolve-symlinks #:*resolve-symlinks* #:resolve-symlin… | |
15 ;; merging with cwd | |
16 #:get-pathname-defaults #:call-with-current-directory #:with-current-… | |
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-t… | |
26 (in-package :uiop/filesystem) | |
27 | |
28 ;;; Native namestrings, as seen by the operating system calls rather tha… | |
29 (with-upgradability () | |
30 (defun native-namestring (x) | |
31 "From a non-wildcard CL pathname, a return namestring suitable for p… | |
32 (when x | |
33 (let ((p (pathname x))) | |
34 #+clozure (with-pathname-defaults () (ccl:native-translated-name… | |
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-d… | |
43 "From a native namestring suitable for use by the operating system, … | |
44 a CL pathname satisfying all the specified constraints as per ENSURE-PAT… | |
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-dir… | |
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 … | |
68 (when p | |
69 (when (stringp p) (setf p (with-pathname-defaults () (parse-namest… | |
70 (values | |
71 (or (ignore-errors (truename p)) | |
72 ;; this is here because trying to find the truename of a dire… | |
73 ;; a trailing directory separator, causes an error on some li… | |
74 #+(or clisp gcl) (if-let (d (ensure-directory-pathname p nil)… | |
75 ;; On Genera, truename of a directory pathname will probably … | |
76 ;; will merge in a filename/type/version from *default-pathna… | |
77 ;; will try to get the truename of a file that probably doesn… | |
78 #+genera (when (directory-pathname-p p) | |
79 (let ((d (scl:send p :directory-pathname-as-file))) | |
80 (ensure-directory-pathname (ignore-errors (truen… | |
81 | |
82 (defun safe-file-write-date (pathname) | |
83 "Safe variant of FILE-WRITE-DATE that may return NIL rather than rai… | |
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-NAMEST… | |
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-defaul… | |
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 … | |
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-path… | |
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-d… | |
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 implementatio… | |
170 (apply 'directory pathname-spec | |
171 (append keys '#.(or #+allegro '(:directories-are-files nil :f… | |
172 #+(or clozure digitool) '(:follow-links n… | |
173 #+clisp '(:circle t :if-does-not-exist :i… | |
174 #+(or cmucl scl) '(:follow-links nil :tru… | |
175 #+lispworks '(:link-transparency nil) | |
176 #+sbcl (when (find-symbol* :resolve-symli… | |
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 en… | |
185 when using logical-pathnames." | |
186 (if (logical-pathname-p directory) | |
187 (remove-duplicates ;; on CLISP, querying ~/ will return duplicat… | |
188 ;; Try hard to not resolve logical-pathname into physical pathn… | |
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 merg… | |
197 ;; The first u avoids a cumbersome (truena… | |
198 ;; At this point f should already be a tru… | |
199 ;; but isn't quite in CLISP, for it doesn'… | |
200 (and u (equal (truename* u) (truename* f))… | |
201 :when p :collect p) | |
202 :test 'pathname-equal) | |
203 entries)) | |
204 | |
205 (defun directory-files (directory &optional (pattern *wild-file-for-di… | |
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 implementa… | |
209 override the default at your own risk. | |
210 DIRECTORY-FILES tries NOT to resolve symlinks if the implementation pe… | |
211 but the behavior in presence of symlinks is not portable. Use IOlib to h… | |
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 pat… | |
217 (when (wild-pathname-p dir) | |
218 (parameter-error "~S: Invalid wild pattern in logical director… | |
219 'directory-files directory)) | |
220 (unless (member (pathname-directory pattern) '(() (:relative)) :… | |
221 (parameter-error "~S: Invalid file pattern ~S for logical dire… | |
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-lo… | |
231 :type (make-pathname-component-lo… | |
232 :version (make-pathname-component… | |
233 | |
234 (defun subdirectories (directory) | |
235 "Given a DIRECTORY pathname designator, return a list of the subdire… | |
236 The behavior in presence of symlinks is not portable. Use IOlib to handl… | |
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… | |
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:di… | |
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-direct… | |
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-… | |
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 (pathna… | |
265 '(:absolute)))) ; because allegro returns NIL f… | |
266 #'(lambda (d) | |
267 (let ((dir (normalize-pathname-directory-component (pathnam… | |
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-… | |
272 | |
273 (defun collect-sub*directories (directory collectp recursep collector) | |
274 "Given a DIRECTORY, when COLLECTP returns true when CALL-FUNCTION'ed… | |
275 call-function the COLLECTOR function designator on the directory, | |
276 and recurse each of its subdirectories on which the RECURSEP returns tru… | |
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 handl… | |
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 pathnam… | |
292 (let ((p pathname)) | |
293 (unless (absolute-pathname-p p) | |
294 (setf p (or (absolute-pathname-p (ensure-absolute-pathname p '… | |
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 (pathn… | |
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… | |
307 :name nil :type nil :v… | |
308 (if-let (simplified | |
309 (ignore-errors | |
310 (merge-pathnames* | |
311 (make-pathname :directory `(:relative ,@down-co… | |
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 partial… | |
320 #-allegro (truenamize path) | |
321 #+allegro | |
322 (if (physical-pathname-p path) | |
323 (or (ignore-errors (excl:pathname-resolve-symbolic-links path)) … | |
324 path)) | |
325 | |
326 (defvar *resolve-symlinks* t | |
327 "Determine whether or not ASDF resolves symlinks when defining syste… | |
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-sub… | |
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 co… | |
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 respe… | |
359 depending on the NAMESTRING argument being :UNIX, :LISP or :NATIVE respe… | |
360 or else by using CALL-FUNCTION on the NAMESTRING argument; | |
361 if :UNIX is specified (or NIL, the default, which specifies the same thi… | |
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 … | |
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, CER… | |
370 The boolean T is an alias for ERROR. | |
371 ERROR means that an error will be raised if the constraint is not satisf… | |
372 CERROR means that an continuable error will be raised if the constraint … | |
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… | |
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-… | |
393 WANT-RELATIVE checks that pathname has a relative directory component | |
394 WANT-ABSOLUTE checks that pathname does have an absolute directory compo… | |
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 componen… | |
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 pathnam… | |
406 ENSURE-DIRECTORIES-EXIST creates any parent directory with ENSURE-DIRECT… | |
407 TRUENAME replaces the pathname by its truename, or errors if not possibl… | |
408 RESOLVE-SYMLINKS replaces the pathname by a variant with symlinks resolv… | |
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) ,@ar… | |
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-rela… | |
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, no… | |
444 (return nil))) | |
445 (check want-logical (logical-pathname-p p) "Expected a logical… | |
446 (check want-physical (physical-pathname-p p) "Expected a physi… | |
447 (transform ensure-physical () (physicalize-pathname p)) | |
448 (check ensure-physical (physical-pathname-p p) "Could not tran… | |
449 (check want-relative (relative-pathname-p p) "Expected a relat… | |
450 (check want-absolute (absolute-pathname-p p) "Expected an abso… | |
451 (transform ensure-absolute (not (absolute-pathname-p p)) | |
452 (ensure-absolute-pathname p defaults (list #'report… | |
453 (check ensure-absolute (absolute-pathname-p p) | |
454 "Could not make into an absolute pathname even after me… | |
455 (check ensure-subpath (absolute-pathname-p defaults) | |
456 "cannot be checked to be a subpath of non-absolute path… | |
457 (check ensure-subpath (subpathp p defaults) "is not a sub path… | |
458 (check want-file (file-pathname-p p) "Expected a file pathname… | |
459 (check want-directory (directory-pathname-p p) "Expected a dir… | |
460 (transform ensure-directory (not (directory-pathname-p p)) (en… | |
461 (check want-non-wild (not (wild-pathname-p p)) "Expected a non… | |
462 (check want-wild (wild-pathname-p p) "Expected a wildcard path… | |
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-de… | |
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… | |
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 … | |
514 (os-cond ((os-unix-p) #\:) (t #\;))) | |
515 | |
516 (defun split-native-pathnames-string (string &rest constraints &key &a… | |
517 "Given a string of pathnames specified in native OS syntax, separate… | |
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 (i… | |
521 :collect (unless (emptyp namestring) (apply 'parse-native-name… | |
522 | |
523 (defun getenv-pathname (x &rest constraints &key ensure-directory want… | |
524 "Extract a pathname from a user-configured environment variable, as … | |
525 check constraints and normalize as per ENSURE-PATHNAME." | |
526 ;; For backward compatibility with ASDF 2, want-directory implies en… | |
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: ~*~… | |
531 constraints)) | |
532 (defun getenv-pathnames (x &rest constraints &key on-error &allow-othe… | |
533 "Extract a list of pathname from a user-configured environment varia… | |
534 check constraints and normalize each one as per ENSURE-PATHNAME. | |
535 Any empty entries in the environment variable X will be returned … | |
536 (unless (getf constraints :empty-is-nil t) | |
537 (parameter-error "Cannot have EMPTY-IS-NIL false for ~S" 'getenv-p… | |
538 (apply 'split-native-pathnames-string (getenvp x) | |
539 :on-error (or on-error | |
540 `(error "In (~S ~S), invalid pathname ~*~S: ~*~… | |
541 :empty-is-nil t | |
542 constraints)) | |
543 (defun getenv-absolute-directory (x) | |
544 "Extract an absolute directory pathname from a user-configured envir… | |
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 envir… | |
549 as per native OS. Any empty entries in the environment variable X will … | |
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 im… | |
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 (… | |
562 #+gcl system::*system-directory* | |
563 #+lispworks lispworks:*lispworks-directory* | |
564 #+sbcl (if-let (it (find-symbol* :sbcl-homedir-pathname :sb-… | |
565 (funcall it) | |
566 (getenv-pathname "SBCL_HOME" :ensure-directory t)) | |
567 #+scl (ignore-errors (pathname-parent-directory-pathname (tr… | |
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 implementa… | |
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 director… | |
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-phys… | |
602 (target (ensure-pathname target :namestring :lisp :ensure-phys… | |
603 #+clisp ;; in recent enough versions of CLISP, :if-exists :overwri… | |
604 (progn (funcall 'require "syscalls") | |
605 (symbol-call :posix :copy-file source target :method :renam… | |
606 #+(and sbcl os-windows) (delete-file-if-exists target) ;; not atom… | |
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-pat… | |
620 (unless ok | |
621 #+cmucl (error "Error number ~A when trying to de… | |
622 errno directory-pathname) | |
623 #+scl (error "~@<Error deleting ~S: ~A~@:>" | |
624 directory-pathname (unix:get-unix-er… | |
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… | |
633 #+xcl (symbol-call :uiop :run-program `("rmdir" ,(native-namestring … | |
634 #-(or abcl allegro clasp clisp clozure cmucl cormanlisp digitool ecl… | |
635 (not-implemented-error 'delete-empty-directory "(on your platform)")… | |
636 | |
637 (defun delete-directory-tree (directory-pathname &key (validate nil va… | |
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 specifie… | |
644 if it is :ERROR (the default), an error is signaled, whereas if it is :I… | |
645 | |
646 Furthermore, before any deletion is attempted, the DIRECTORY-PATHNAME mu… | |
647 the validation function designated (as per ENSURE-FUNCTION) by the VALID… | |
648 which in practice is thus compulsory, and validates by returning a non-N… | |
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… | |
653 :want-physical t :want-dir… | |
654 (cond | |
655 ((not validatep) | |
656 (parameter-error "~S was asked to delete ~S but was not provided … | |
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 ~… | |
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 e… | |
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 … | |
669 ;; except on implementations where we can prevent DIRECTORY from … | |
670 ;; instead spawn a standard external program to do the dirty work. | |
671 (symbol-call :uiop :run-program `("rm" "-rf" ,(native-namestring … | |
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-d… | |
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 SBC… | |
680 '(error "~S requires SBCL 1.0.44 or later" 'delete-dir… | |
681 ;; Outside Unix or on CMUCL and SCL that can avoid following syml… | |
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))))))) |