filesystem.lisp 34.9 KB
Newer Older
1
2
3
;;;; -------------------------------------------------------------------------
;;;; Portability layer around Common Lisp filesystem access

4
5
6
7
(uiop/package:define-package :uiop/filesystem
  (:nicknames :asdf/filesystem)
  (:recycle :uiop/filesystem :asdf/pathname :asdf)
  (:use :uiop/common-lisp :uiop/package :uiop/utility :uiop/os :uiop/pathname)
8
9
10
11
  (:export
   ;; Native namestrings
   #:native-namestring #:parse-native-namestring
   ;; Probing the filesystem
12
   #:truename* #:safe-file-write-date #:probe-file* #:directory-exists-p #:file-exists-p
13
14
15
16
17
18
19
20
21
22
   #:directory* #:filter-logical-directory-results #:directory-files #:subdirectories
   #:collect-sub*directories
   ;; Resolving symlinks somewhat
   #:truenamize #:resolve-symlinks #:*resolve-symlinks* #:resolve-symlinks*
   ;; merging with cwd
   #:get-pathname-defaults #:call-with-current-directory #:with-current-directory
   ;; Environment pathnames
   #:inter-directory-separator #:split-native-pathnames-string
   #:getenv-pathname #:getenv-pathnames
   #:getenv-absolute-directory #:getenv-absolute-directories
23
24
25
26
   #:lisp-implementation-directory #:lisp-implementation-pathname-p
   ;; Simple filesystem operations
   #:ensure-all-directories-exist
   #:rename-file-overwriting-target
27
   #:delete-file-if-exists #:delete-empty-directory #:delete-directory-tree))
28
(in-package :uiop/filesystem)
29
30

;;; Native namestrings, as seen by the operating system calls rather than Lisp
31
32
33
34
35
36
37
38
39
(with-upgradability ()
  (defun native-namestring (x)
    "From a non-wildcard CL pathname, a return namestring suitable for passing to the operating system"
    (when x
      (let ((p (pathname x)))
        #+clozure (with-pathname-defaults () (ccl:native-translated-namestring p)) ; see ccl bug 978
        #+(or cmu scl) (ext:unix-namestring p nil)
        #+sbcl (sb-ext:native-namestring p)
        #-(or clozure cmu sbcl scl)
40
41
42
        (os-cond
         ((os-unix-p) (unix-namestring p))
         (t (namestring p))))))
43

44
  (defun parse-native-namestring (string &rest constraints &key ensure-directory &allow-other-keys)
45
    "From a native namestring suitable for use by the operating system, return
46
a CL pathname satisfying all the specified constraints as per ENSURE-PATHNAME"
47
48
    (check-type string (or string null))
    (let* ((pathname
49
50
51
52
53
             (when string
               (with-pathname-defaults ()
                 #+clozure (ccl:native-to-pathname string)
                 #+sbcl (sb-ext:parse-native-namestring string)
                 #-(or clozure sbcl)
54
55
56
                 (os-cond
                  ((os-unix-p) (parse-unix-namestring string :ensure-directory ensure-directory))
                  (t (parse-namestring string))))))
57
58
59
60
61
           (pathname
             (if ensure-directory
                 (and pathname (ensure-directory-pathname pathname))
                 pathname)))
      (apply 'ensure-pathname pathname constraints))))
62
63
64


;;; Probing the filesystem
65
66
(with-upgradability ()
  (defun truename* (p)
67
68
69
70
71
    "Nicer variant of TRUENAME that plays well with NIL, avoids logical pathname contexts, and tries both files and directories"
    (when p
      (when (stringp p) (setf p (with-pathname-defaults () (parse-namestring p))))
      (values
       (or (ignore-errors (truename p))
Robert Goldman's avatar
Robert Goldman committed
72
73
           ;; this is here because trying to find the truename of a directory pathname WITHOUT supplying
           ;; a trailing directory separator, causes an error on some lisps.
74
           #+(or clisp gcl) (if-let (d (ensure-directory-pathname p)) (ignore-errors (truename d)))))))
75
76

  (defun safe-file-write-date (pathname)
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
77
    "Safe variant of FILE-WRITE-DATE that may return NIL rather than raise an error."
78
79
80
81
82
83
84
85
    ;; If FILE-WRITE-DATE returns NIL, it's possible that
    ;; the user or some other agent has deleted an input file.
    ;; Also, generated files will not exist at the time planning is done
    ;; and calls compute-action-stamp which calls safe-file-write-date.
    ;; So it is very possible that we can't get a valid file-write-date,
    ;; and we can survive and we will continue the planning
    ;; as if the file were very old.
    ;; (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
91

  (defun probe-file* (p &key truename)
    "when given a pathname P (designated by a string as per PARSE-NAMESTRING),
92
93
94
probes the filesystem for a file or directory with given pathname.
If it exists, return its truename is ENSURE-PATHNAME is true,
or the original (parsed) pathname if it is false (the default)."
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
    (values
     (ignore-errors
      (setf p (funcall 'ensure-pathname p
                       :namestring :lisp
                       :ensure-physical t
                       :ensure-absolute t :defaults 'get-pathname-defaults
                       :want-non-wild t
                       :on-error nil))
      (when p
        #+allegro
        (probe-file p :follow-symlinks truename)
        #+gcl
        (if truename
            (truename* p)
            (let ((kind (car (si::stat p))))
              (when (eq kind :link)
                (setf kind (ignore-errors (car (si::stat (truename* p))))))
              (ecase kind
                ((nil) nil)
                ((:file :link)
                 (cond
                   ((file-pathname-p p) p)
                   ((directory-pathname-p p)
                    (subpathname p (car (last (pathname-directory p)))))))
                (:directory (ensure-directory-pathname p)))))
        #+clisp
        #.(let* ((fs (or #-os-windows (find-symbol* '#:file-stat :posix nil)))
                 (pp (find-symbol* '#:probe-pathname :ext nil)))
            `(if truename
                 ,(if pp
                      `(values (,pp p))
                      '(or (truename* p)
                        (truename* (ignore-errors (ensure-directory-pathname p)))))
                 ,(cond
                    (fs `(and (,fs p) p))
                    (pp `(nth-value 1 (,pp p)))
                    (t '(or (and (truename* p) p)
                         (if-let (d (ensure-directory-pathname p))
                          (and (truename* d) d)))))))
        #-(or allegro clisp gcl)
        (if truename
            (probe-file p)
            (and
             #+(or cmu scl) (unix:unix-stat (ext:unix-namestring p))
             #+(and lispworks unix) (system:get-file-stat p)
             #+sbcl (sb-unix:unix-stat (sb-ext:native-namestring p))
             #-(or cmu (and lispworks unix) sbcl scl) (file-write-date p)
             p))))))
143

144
  (defun directory-exists-p (x)
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
145
    "Is X the name of a directory that exists on the filesystem?"
146
147
    #+allegro
    (excl:probe-directory x)
148
149
150
151
152
    #+clisp
    (handler-case (ext:probe-directory x)
           (sys::simple-file-error ()
             nil))
    #-(or allegro clisp)
153
154
155
156
    (let ((p (probe-file* x :truename t)))
      (and (directory-pathname-p p) p)))

  (defun file-exists-p (x)
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
157
    "Is X the name of a file that exists on the filesystem?"
158
159
160
    (let ((p (probe-file* x :truename t)))
      (and (file-pathname-p p) p)))

161
  (defun directory* (pathname-spec &rest keys &key &allow-other-keys)
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
162
163
    "Return a list of the entries in a directory by calling DIRECTORY.
Try to override the defaults to not resolving symlinks, if implementation allows."
164
165
    (apply 'directory pathname-spec
           (append keys '#.(or #+allegro '(:directories-are-files nil :follow-symbolic-links nil)
166
                               #+(or clozure digitool) '(:follow-links nil)
167
168
                               #+clisp '(:circle t :if-does-not-exist :ignore)
                               #+(or cmu scl) '(:follow-links nil :truenamep nil)
169
                               #+lispworks '(:link-transparency nil)
170
171
172
173
                               #+sbcl (when (find-symbol* :resolve-symlinks '#:sb-impl nil)
                                        '(:resolve-symlinks nil))))))

  (defun filter-logical-directory-results (directory entries merger)
174
175
176
    "Given ENTRIES in a DIRECTORY, remove if the directory is logical
the entries which are physical yet when transformed by MERGER have a different TRUENAME.
This function is used as a helper to DIRECTORY-FILES to avoid invalid entries when using logical-pathnames."
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
    (remove-duplicates ;; on CLISP, querying ~/ will return duplicates
     (if (logical-pathname-p directory)
         ;; Try hard to not resolve logical-pathname into physical pathnames;
         ;; otherwise logical-pathname users/lovers will be disappointed.
         ;; If directory* could use some implementation-dependent magic,
         ;; we will have logical pathnames already; otherwise,
         ;; we only keep pathnames for which specifying the name and
         ;; translating the LPN commute.
         (loop :for f :in entries
               :for p = (or (and (logical-pathname-p f) f)
                            (let* ((u (ignore-errors (call-function merger f))))
                              ;; The first u avoids a cumbersome (truename u) error.
                              ;; At this point f should already be a truename,
                              ;; but isn't quite in CLISP, for it doesn't have :version :newest
                              (and u (equal (truename* u) (truename* f)) u)))
               :when p :collect p)
         entries)
     :test 'pathname-equal))

196
197

  (defun directory-files (directory &optional (pattern *wild-file*))
198
199
200
201
    "Return a list of the files in a directory according to the PATTERN.
Subdirectories should NOT be returned.
  PATTERN defaults to a pattern carefully chosen based on the implementation;
override the default at your own risk.
202
203
  DIRECTORY-FILES tries NOT to resolve symlinks if the implementation permits this,
but the behavior in presence of symlinks is not portable. Use IOlib to handle such situations."
204
205
206
207
208
209
210
211
212
213
    (let ((dir (pathname directory)))
      (when (logical-pathname-p dir)
        ;; Because of the filtering we do below,
        ;; logical pathnames have restrictions on wild patterns.
        ;; Not that the results are very portable when you use these patterns on physical pathnames.
        (when (wild-pathname-p dir)
          (error "Invalid wild pattern in logical directory ~S" directory))
        (unless (member (pathname-directory pattern) '(() (:relative)) :test 'equal)
          (error "Invalid file pattern ~S for logical directory ~S" pattern directory))
        (setf pattern (make-pathname-logical pattern (pathname-host dir))))
214
215
      (let* ((pat (merge-pathnames* pattern dir))
             (entries (append (ignore-errors (directory* pat))
216
                              #+(or clisp gcl)
217
218
                              (when (equal :wild (pathname-type pattern))
                                (ignore-errors (directory* (make-pathname :type nil :defaults pat)))))))
219
        (remove-if 'directory-pathname-p
220
221
222
223
224
225
226
                   (filter-logical-directory-results
                    directory entries
                    #'(lambda (f)
                        (make-pathname :defaults dir
                                       :name (make-pathname-component-logical (pathname-name f))
                                       :type (make-pathname-component-logical (pathname-type f))
                                       :version (make-pathname-component-logical (pathname-version f)))))))))
227
228

  (defun subdirectories (directory)
229
230
    "Given a DIRECTORY pathname designator, return a list of the subdirectories under it.
The behavior in presence of symlinks is not portable. Use IOlib to handle such situations."
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
    (let* ((directory (ensure-directory-pathname directory))
           #-(or abcl cormanlisp genera xcl)
           (wild (merge-pathnames*
                  #-(or abcl allegro cmu lispworks sbcl scl xcl)
                  *wild-directory*
                  #+(or abcl allegro cmu lispworks sbcl scl xcl) "*.*"
                  directory))
           (dirs
             #-(or abcl cormanlisp genera xcl)
             (ignore-errors
              (directory* wild . #.(or #+clozure '(:directories t :files nil)
                                       #+mcl '(:directories t))))
             #+(or abcl xcl) (system:list-directory directory)
             #+cormanlisp (cl::directory-subdirs directory)
             #+genera (fs:directory-list directory))
           #+(or abcl allegro cmu genera lispworks sbcl scl xcl)
           (dirs (loop :for x :in dirs
                       :for d = #+(or abcl xcl) (extensions:probe-directory x)
                       #+allegro (excl:probe-directory x)
                       #+(or cmu sbcl scl) (directory-pathname-p x)
                       #+genera (getf (cdr x) :directory)
                       #+lispworks (lw:file-directory-p x)
                       :when d :collect #+(or abcl allegro xcl) d
                         #+genera (ensure-directory-pathname (first x))
                       #+(or cmu lispworks sbcl scl) x)))
256
      (filter-logical-directory-results
257
258
259
260
261
262
263
264
265
266
267
       directory dirs
       (let ((prefix (or (normalize-pathname-directory-component (pathname-directory directory))
                         '(:absolute)))) ; because allegro returns NIL for #p"FOO:"
         #'(lambda (d)
             (let ((dir (normalize-pathname-directory-component (pathname-directory d))))
               (and (consp dir) (consp (cdr dir))
                    (make-pathname
                     :defaults directory :name nil :type nil :version nil
                     :directory (append prefix (make-pathname-component-logical (last dir)))))))))))

  (defun collect-sub*directories (directory collectp recursep collector)
268
269
    "Given a DIRECTORY, when COLLECTP returns true when CALL-FUNCTION'ed with the directory,
call-function the COLLECTOR function designator on the directory,
270
271
272
273
and recurse each of its subdirectories on which the RECURSEP returns true when CALL-FUNCTION'ed with them.
This function will thus let you traverse a filesystem hierarchy,
superseding the functionality of CL-FAD:WALK-DIRECTORY.
The behavior in presence of symlinks is not portable. Use IOlib to handle such situations."
274
    (when (call-function collectp directory)
275
276
277
278
      (call-function collector directory)
      (dolist (subdir (subdirectories directory))
        (when (call-function recursep subdir)
          (collect-sub*directories subdir collectp recursep collector))))))
279
280

;;; Resolving symlinks somewhat
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
(with-upgradability ()
  (defun truenamize (pathname)
    "Resolve as much of a pathname as possible"
    (block nil
      (when (typep pathname '(or null logical-pathname)) (return pathname))
      (let ((p pathname))
        (unless (absolute-pathname-p p)
          (setf p (or (absolute-pathname-p (ensure-absolute-pathname p 'get-pathname-defaults nil))
                      (return p))))
        (when (logical-pathname-p p) (return p))
        (let ((found (probe-file* p :truename t)))
          (when found (return found)))
        (let* ((directory (normalize-pathname-directory-component (pathname-directory p)))
               (up-components (reverse (rest directory)))
               (down-components ()))
          (assert (eq :absolute (first directory)))
          (loop :while up-components :do
298
299
300
301
302
303
304
305
306
307
308
309
310
            (if-let (parent
                     (ignore-errors
                      (probe-file* (make-pathname* :directory `(:absolute ,@(reverse up-components))
                                                   :name nil :type nil :version nil :defaults p))))
              (if-let (simplified
                       (ignore-errors
                        (merge-pathnames*
                         (make-pathname* :directory `(:relative ,@down-components)
                                         :defaults p)
                         (ensure-directory-pathname parent))))
                (return simplified)))
            (push (pop up-components) down-components)
            :finally (return p))))))
311
312

  (defun resolve-symlinks (path)
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
313
    "Do a best effort at resolving symlinks in PATH, returning a partially or totally resolved PATH."
314
315
316
317
318
319
320
321
    #-allegro (truenamize path)
    #+allegro
    (if (physical-pathname-p path)
        (or (ignore-errors (excl:pathname-resolve-symbolic-links path)) path)
        path))

  (defvar *resolve-symlinks* t
    "Determine whether or not ASDF resolves symlinks when defining systems.
322
323
Defaults to T.")

324
  (defun resolve-symlinks* (path)
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
325
    "RESOLVE-SYMLINKS in PATH iff *RESOLVE-SYMLINKS* is T (the default)."
326
327
328
    (if *resolve-symlinks*
        (and path (resolve-symlinks path))
        path)))
329
330
331


;;; Check pathname constraints
332
333
334
335
(with-upgradability ()
  (defun ensure-pathname
      (pathname &key
                  on-error
336
                  defaults type dot-dot namestring
337
                  empty-is-nil
338
339
340
341
342
343
344
345
346
                  want-pathname
                  want-logical want-physical ensure-physical
                  want-relative want-absolute ensure-absolute ensure-subpath
                  want-non-wild want-wild wilden
                  want-file want-directory ensure-directory
                  want-existing ensure-directories-exist
                  truename resolve-symlinks truenamize
       &aux (p pathname)) ;; mutable working copy, preserve original
    "Coerces its argument into a PATHNAME,
347
348
349
350
optionally doing some transformations and checking specified constraints.

If the argument is NIL, then NIL is returned unless the WANT-PATHNAME constraint is specified.

351
352
353
354
355
356
357
358
359
360
361
If the argument is a STRING, it is first converted to a pathname via
PARSE-UNIX-NAMESTRING, PARSE-NAMESTRING or PARSE-NATIVE-NAMESTRING respectively
depending on the NAMESTRING argument being :UNIX, :LISP or :NATIVE respectively,
or else by using CALL-FUNCTION on the NAMESTRING argument;
if :UNIX is specified (or NIL, the default, which specifies the same thing),
then PARSE-UNIX-NAMESTRING it is called with the keywords
DEFAULTS TYPE DOT-DOT ENSURE-DIRECTORY WANT-RELATIVE, and
the result is optionally merged into the DEFAULTS if ENSURE-ABSOLUTE is true.

The pathname passed or resulting from parsing the string
is then subjected to all the checks and transformations below are run.
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380

Each non-nil constraint argument can be one of the symbols T, ERROR, CERROR or IGNORE.
The boolean T is an alias for ERROR.
ERROR means that an error will be raised if the constraint is not satisfied.
CERROR means that an continuable error will be raised if the constraint is not satisfied.
IGNORE means just return NIL instead of the pathname.

The ON-ERROR argument, if not NIL, is a function designator (as per CALL-FUNCTION)
that will be called with the the following arguments:
a generic format string for ensure pathname, the pathname,
the keyword argument corresponding to the failed check or transformation,
a format string for the reason ENSURE-PATHNAME failed,
and a list with arguments to that format string.
If ON-ERROR is NIL, ERROR is used instead, which does the right thing.
You could also pass (CERROR \"CONTINUE DESPITE FAILED CHECK\").

The transformations and constraint checks are done in this order,
which is also the order in the lambda-list:

381
EMPTY-IS-NIL returns NIL if the argument is an empty string.
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
WANT-PATHNAME checks that pathname (after parsing if needed) is not null.
Otherwise, if the pathname is NIL, ensure-pathname returns NIL.
WANT-LOGICAL checks that pathname is a LOGICAL-PATHNAME
WANT-PHYSICAL checks that pathname is not a LOGICAL-PATHNAME
ENSURE-PHYSICAL ensures that pathname is physical via TRANSLATE-LOGICAL-PATHNAME
WANT-RELATIVE checks that pathname has a relative directory component
WANT-ABSOLUTE checks that pathname does have an absolute directory component
ENSURE-ABSOLUTE merges with the DEFAULTS, then checks again
that the result absolute is an absolute pathname indeed.
ENSURE-SUBPATH checks that the pathname is a subpath of the DEFAULTS.
WANT-FILE checks that pathname has a non-nil FILE component
WANT-DIRECTORY checks that pathname has nil FILE and TYPE components
ENSURE-DIRECTORY uses ENSURE-DIRECTORY-PATHNAME to interpret
any file and type components as being actually a last directory component.
WANT-NON-WILD checks that pathname is not a wild pathname
WANT-WILD checks that pathname is a wild pathname
WILDEN merges the pathname with **/*.*.* if it is not wild
WANT-EXISTING checks that a file (or directory) exists with that pathname.
ENSURE-DIRECTORIES-EXIST creates any parent directory with ENSURE-DIRECTORIES-EXIST.
TRUENAME replaces the pathname by its truename, or errors if not possible.
RESOLVE-SYMLINKS replaces the pathname by a variant with symlinks resolved by RESOLVE-SYMLINKS.
TRUENAMIZE uses TRUENAMIZE to resolve as many symlinks as possible."
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
    (block nil
      (flet ((report-error (keyword description &rest arguments)
               (call-function (or on-error 'error)
                              "Invalid pathname ~S: ~*~?"
                              pathname keyword description arguments)))
        (macrolet ((err (constraint &rest arguments)
                     `(report-error ',(intern* constraint :keyword) ,@arguments))
                   (check (constraint condition &rest arguments)
                     `(when ,constraint
                        (unless ,condition (err ,constraint ,@arguments))))
                   (transform (transform condition expr)
                     `(when ,transform
                        (,@(if condition `(when ,condition) '(progn))
                         (setf p ,expr)))))
          (etypecase p
            ((or null pathname))
            (string
421
422
             (when (and (emptyp p) empty-is-nil)
               (return-from ensure-pathname nil))
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
             (setf p (case namestring
                       ((:unix nil)
                        (parse-unix-namestring
                         p :defaults defaults :type type :dot-dot dot-dot
                           :ensure-directory ensure-directory :want-relative want-relative))
                       ((:native)
                        (parse-native-namestring p))
                       ((:lisp)
                        (parse-namestring p))
                       (t
                        (call-function namestring p))))))
          (etypecase p
            (pathname)
            (null
             (check want-pathname (pathnamep p) "Expected a pathname, not NIL")
             (return nil)))
439
440
          (check want-logical (logical-pathname-p p) "Expected a logical pathname")
          (check want-physical (physical-pathname-p p) "Expected a physical pathname")
441
          (transform ensure-physical () (physicalize-pathname p))
442
443
444
          (check ensure-physical (physical-pathname-p p) "Could not translate to a physical pathname")
          (check want-relative (relative-pathname-p p) "Expected a relative pathname")
          (check want-absolute (absolute-pathname-p p) "Expected an absolute pathname")
445
446
          (transform ensure-absolute (not (absolute-pathname-p p))
                     (ensure-absolute-pathname p defaults (list #'report-error :ensure-absolute "~@?")))
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
          (check ensure-absolute (absolute-pathname-p p)
                 "Could not make into an absolute pathname even after merging with ~S" defaults)
          (check ensure-subpath (absolute-pathname-p defaults)
                 "cannot be checked to be a subpath of non-absolute pathname ~S" defaults)
          (check ensure-subpath (subpathp p defaults) "is not a sub pathname of ~S" defaults)
          (check want-file (file-pathname-p p) "Expected a file pathname")
          (check want-directory (directory-pathname-p p) "Expected a directory pathname")
          (transform ensure-directory (not (directory-pathname-p p)) (ensure-directory-pathname p))
          (check want-non-wild (not (wild-pathname-p p)) "Expected a non-wildcard pathname")
          (check want-wild (wild-pathname-p p) "Expected a wildcard pathname")
          (transform wilden (not (wild-pathname-p p)) (wilden p))
          (when want-existing
            (let ((existing (probe-file* p :truename truename)))
              (if existing
                  (when truename
                    (return existing))
                  (err want-existing "Expected an existing pathname"))))
          (when ensure-directories-exist (ensure-directories-exist p))
          (when truename
            (let ((truename (truename* p)))
              (if truename
                  (return truename)
                  (err truename "Can't get a truename for pathname"))))
          (transform resolve-symlinks () (resolve-symlinks p))
          (transform truenamize () (truenamize p))
          p)))))
473
474
475


;;; Pathname defaults
476
477
(with-upgradability ()
  (defun get-pathname-defaults (&optional (defaults *default-pathname-defaults*))
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
478
479
    "Find the actual DEFAULTS to use for pathnames, including
resolving them with respect to GETCWD if the DEFAULTS were relative"
480
481
482
483
    (or (absolute-pathname-p defaults)
        (merge-pathnames* defaults (getcwd))))

  (defun call-with-current-directory (dir thunk)
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
484
485
    "call the THUNK in a context where the current directory was changed to DIR, if not NIL.
Note that this operation is usually NOT thread-safe."
486
487
    (if dir
        (let* ((dir (resolve-symlinks* (get-pathname-defaults (pathname-directory-pathname dir))))
488
489
               (cwd (getcwd))
               (*default-pathname-defaults* dir))
490
491
492
493
494
495
496
497
498
          (chdir dir)
          (unwind-protect
               (funcall thunk)
            (chdir cwd)))
        (funcall thunk)))

  (defmacro with-current-directory ((&optional dir) &body body)
    "Call BODY while the POSIX current working directory is set to DIR"
    `(call-with-current-directory ,dir #'(lambda () ,@body))))
499
500
501


;;; Environment pathnames
502
503
(with-upgradability ()
  (defun inter-directory-separator ()
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
504
    "What character does the current OS conventionally uses to separate directories?"
505
    (os-cond ((os-unix-p) #\:) (t #\;)))
506

507
508
  (defun split-native-pathnames-string (string &rest constraints &key &allow-other-keys)
    "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)
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
515
516
    "Extract a pathname from a user-configured environment variable, as per native OS,
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
521
522
           :on-error (or on-error
                         `(error "In (~S ~S), invalid pathname ~*~S: ~*~?" getenv-pathname ,x))
           constraints))
523
  (defun getenv-pathnames (x &rest constraints &key on-error &allow-other-keys)
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
524
    "Extract a list of pathname from a user-configured environment variable, as per native OS,
525
526
527
528
check constraints and normalize each one as per ENSURE-PATHNAME.
       Any empty entries in the environment variable X will be returned as NILs."
    (unless (getf constraints :empty-is-nil t)
      (error "Cannot have EMPTY-IS-NIL false for GETENV-PATHNAMES."))
529
530
531
    (apply 'split-native-pathnames-string (getenvp x)
           :on-error (or on-error
                         `(error "In (~S ~S), invalid pathname ~*~S: ~*~?" getenv-pathnames ,x))
532
           :empty-is-nil t
533
           constraints))
534
  (defun getenv-absolute-directory (x)
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
535
536
    "Extract an absolute directory pathname from a user-configured environment variable,
as per native OS"
537
    (getenv-pathname x :want-absolute t :ensure-directory t))
538
  (defun getenv-absolute-directories (x)
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
539
    "Extract a list of absolute directories from a user-configured environment variable,
540
541
542
as per native OS.  Any empty entries in the environment variable X will be returned as
NILs."
    (getenv-pathnames x :want-absolute t :ensure-directory t))
543
544

  (defun lisp-implementation-directory (&key truename)
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
545
    "Where are the system files of the current installation of the CL implementation?"
546
547
    (declare (ignorable truename))
    (let ((dir
548
549
550
551
552
553
554
555
556
557
558
559
            #+abcl extensions:*lisp-home*
            #+(or allegro clasp ecl mkcl) #p"SYS:"
            ;;#+clisp custom:*lib-directory* ; causes failure in asdf-pathname-test(!)
            #+clozure #p"ccl:"
            #+cmu (ignore-errors (pathname-parent-directory-pathname (truename #p"modules:")))
            #+gcl system::*system-directory*
            #+lispworks lispworks:*lispworks-directory*
            #+sbcl (if-let (it (find-symbol* :sbcl-homedir-pathname :sb-int nil))
                     (funcall it)
                     (getenv-pathname "SBCL_HOME" :ensure-directory t))
            #+scl (ignore-errors (pathname-parent-directory-pathname (truename #p"file://modules/")))
            #+xcl ext:*xcl-home*))
560
561
562
563
564
      (if (and dir truename)
          (truename* dir)
          dir)))

  (defun lisp-implementation-pathname-p (pathname)
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
565
    "Is the PATHNAME under the current installation of the CL implementation?"
566
567
568
569
570
571
572
573
574
    ;; Other builtin systems are those under the implementation directory
    (and (when pathname
           (if-let (impdir (lisp-implementation-directory))
             (or (subpathp pathname impdir)
                 (when *resolve-symlinks*
                   (if-let (truename (truename* pathname))
                     (if-let (trueimpdir (truename* impdir))
                       (subpathp truename trueimpdir)))))))
         t)))
575
576


577
;;; Simple filesystem operations
578
579
(with-upgradability ()
  (defun ensure-all-directories-exist (pathnames)
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
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
586
587
588
  (defun delete-file-if-exists (x)
    "Delete a file X if it already exists"
    (when x (handler-case (delete-file x) (file-error () nil))))

589
  (defun rename-file-overwriting-target (source target)
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
590
591
    "Rename a file, overwriting any previous file with the TARGET name,
in an atomic way if the implementation allows."
592
593
594
    #+clisp ;; in recent enough versions of CLISP, :if-exists :overwrite would make it atomic
    (progn (funcall 'require "syscalls")
           (symbol-call :posix :copy-file source target :method :rename))
595
    #+(and sbcl os-windows) (delete-file-if-exists target) ;; not atomic
596
597
    #-clisp
    (rename-file source target
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
598
                 #+(or clasp clozure ecl) :if-exists #+clozure :rename-and-delete #+(or clasp ecl) t))
599

600
601
602
603
604
605
606
607
608
609
610
611
612
613
  (defun delete-empty-directory (directory-pathname)
    "Delete an empty directory"
    #+(or abcl digitool gcl) (delete-file directory-pathname)
    #+allegro (excl:delete-directory directory-pathname)
    #+clisp (ext:delete-directory directory-pathname)
    #+clozure (ccl::delete-empty-directory directory-pathname)
    #+(or cmu scl) (multiple-value-bind (ok errno)
                       (unix:unix-rmdir (native-namestring directory-pathname))
                     (unless ok
                       #+cmu (error "Error number ~A when trying to delete directory ~A"
                                    errno directory-pathname)
                       #+scl (error "~@<Error deleting ~S: ~A~@:>"
                                    directory-pathname (unix:get-unix-error-msg errno))))
    #+cormanlisp (win32:delete-directory directory-pathname)
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
614
    #+(or clasp ecl) (si:rmdir directory-pathname)
615
    #+genera (fs:delete-directory directory-pathname)
616
617
    #+lispworks (lw:delete-directory directory-pathname)
    #+mkcl (mkcl:rmdir directory-pathname)
618
619
620
    #+sbcl #.(if-let (dd (find-symbol* :delete-directory :sb-ext nil))
               `(,dd directory-pathname) ;; requires SBCL 1.0.44 or later
               `(progn (require :sb-posix) (symbol-call :sb-posix :rmdir directory-pathname)))
621
    #+xcl (symbol-call :uiop :run-program `("rmdir" ,(native-namestring directory-pathname)))
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
622
    #-(or abcl allegro clasp clisp clozure cmu cormanlisp digitool ecl gcl genera lispworks mkcl sbcl scl xcl)
623
    (error "~S not implemented on ~S" 'delete-empty-directory (implementation-type))) ; genera
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642

  (defun delete-directory-tree (directory-pathname &key (validate nil validatep) (if-does-not-exist :error))
    "Delete a directory including all its recursive contents, aka rm -rf.

To reduce the risk of infortunate mistakes, DIRECTORY-PATHNAME must be
a physical non-wildcard directory pathname (not namestring).

If the directory does not exist, the IF-DOES-NOT-EXIST argument specifies what happens:
if it is :ERROR (the default), an error is signaled, whereas if it is :IGNORE, nothing is done.

Furthermore, before any deletion is attempted, the DIRECTORY-PATHNAME must pass
the validation function designated (as per ENSURE-FUNCTION) by the VALIDATE keyword argument
which in practice is thus compulsory, and validates by returning a non-NIL result.
If you're suicidal or extremely confident, just use :VALIDATE T."
    (check-type if-does-not-exist (member :error :ignore))
    (cond
      ((not (and (pathnamep directory-pathname) (directory-pathname-p directory-pathname)
                 (physical-pathname-p directory-pathname) (not (wild-pathname-p directory-pathname))))
       (error "~S was asked to delete ~S but it is not a physical non-wildcard directory pathname"
643
              'delete-directory-tree directory-pathname))
644
645
      ((not validatep)
       (error "~S was asked to delete ~S but was not provided a validation predicate"
646
              'delete-directory-tree directory-pathname))
647
648
      ((not (call-function validate directory-pathname))
       (error "~S was asked to delete ~S but it is not valid ~@[according to ~S~]"
649
              'delete-directory-tree directory-pathname validate))
650
651
652
653
      ((not (directory-exists-p directory-pathname))
       (ecase if-does-not-exist
         (:error
          (error "~S was asked to delete ~S but the directory does not exist"
654
              'delete-directory-tree directory-pathname))
655
         (:ignore nil)))
656
      #-(or allegro cmu clozure genera sbcl scl)
657
658
659
660
661
662
663
664
665
      ((os-unix-p) ;; On Unix, don't recursively walk the directory and delete everything in Lisp,
       ;; except on implementations where we can prevent DIRECTORY from following symlinks;
       ;; instead spawn a standard external program to do the dirty work.
       (symbol-call :uiop :run-program `("rm" "-rf" ,(native-namestring directory-pathname))))
      (t
       ;; On supported implementation, call supported system functions
       #+allegro (symbol-call :excl.osi :delete-directory-and-files
                              directory-pathname :if-does-not-exist if-does-not-exist)
       #+clozure (ccl:delete-directory directory-pathname)
666
       #+genera (fs:delete-directory directory-pathname :confirm nil)
667
668
669
       #+sbcl #.(if-let (dd (find-symbol* :delete-directory :sb-ext nil))
                  `(,dd directory-pathname :recursive t) ;; requires SBCL 1.0.44 or later
                  '(error "~S requires SBCL 1.0.44 or later" 'delete-directory-tree))
670
671
672
673
674
675
676
677
678
       ;; Outside Unix or on CMUCL and SCL that can avoid following symlinks,
       ;; do things the hard way.
       #-(or allegro clozure genera sbcl)
       (let ((sub*directories
               (while-collecting (c)
                 (collect-sub*directories directory-pathname t t #'c))))
             (dolist (d (nreverse sub*directories))
               (map () 'delete-file (directory-files d))
               (delete-empty-directory d)))))))