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

4 5
(uiop/package:define-package :uiop/filesystem
  (:use :uiop/common-lisp :uiop/package :uiop/utility :uiop/os :uiop/pathname)
6 7 8 9
  (:export
   ;; Native namestrings
   #:native-namestring #:parse-native-namestring
   ;; Probing the filesystem
10
   #:truename* #:safe-file-write-date #:probe-file* #:directory-exists-p #:file-exists-p
11 12 13 14 15 16 17 18 19 20
   #: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
21 22 23 24
   #:lisp-implementation-directory #:lisp-implementation-pathname-p
   ;; Simple filesystem operations
   #:ensure-all-directories-exist
   #: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 30 31 32 33 34
(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
35
        #+(or cmucl scl) (ext:unix-namestring p nil)
36
        #+sbcl (sb-ext:native-namestring p)
37
        #-(or clozure cmucl sbcl scl)
38 39 40
        (os-cond
         ((os-unix-p) (unix-namestring p))
         (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 46
    (check-type string (or string null))
    (let* ((pathname
47 48 49
             (when string
               (with-pathname-defaults ()
                 #+clozure (ccl:native-to-pathname string)
50
                 #+cmucl (uiop/os::parse-unix-namestring* string)
51
                 #+sbcl (sb-ext:parse-native-namestring string)
52 53
                 #+scl (lisp::parse-unix-namestring string)
                 #-(or clozure cmucl sbcl scl)
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 nil)) (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
probes the filesystem for a file or directory with given pathname.
dkim's avatar
dkim committed
93
If it exists, return its truename if TRUENAME is true,
94
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
    (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
138
             #+(or cmucl scl) (unix:unix-stat (ext:unix-namestring p))
Elias Pipping's avatar
Elias Pipping committed
139
             #+(and lispworks os-unix) (system:get-file-stat p)
140
             #+sbcl (sb-unix:unix-stat (sb-ext:native-namestring p))
Elias Pipping's avatar
Elias Pipping committed
141
             #-(or cmucl (and lispworks os-unix) sbcl scl) (file-write-date p)
142
             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
                               #+clisp '(:circle t :if-does-not-exist :ignore)
168
                               #+(or cmucl 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 177 178 179 180
    "If DIRECTORY isn't a logical pathname, return ENTRIES. If it is,
given ENTRIES in the DIRECTORY, remove the entries which are physical yet
when transformed by MERGER have a different TRUENAME.
Also remove duplicates as may appear with some translation rules.
This function is used as a helper to DIRECTORY-FILES to avoid invalid entries
when using logical-pathnames."
    (if (logical-pathname-p directory)
181
        (remove-duplicates ;; on CLISP, querying ~/ will return duplicates
182 183 184 185 186 187 188 189 190 191 192 193 194
         ;; 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)))
195 196 197
           :when p :collect p)
         :test 'pathname-equal)
        entries))
198

199
  (defun directory-files (directory &optional (pattern *wild-file-for-directory*))
200 201 202 203
    "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.
204 205
  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."
206 207 208 209 210 211 212 213 214 215
    (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))))
Robert Goldman's avatar
Robert Goldman committed
216
      (let* ((pat (merge-pathnames* pattern dir))
217
             (entries (ignore-errors (directory* pat))))
218
        (remove-if 'directory-pathname-p
219 220 221 222 223 224 225
                   (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)))))))))
226 227

  (defun subdirectories (directory)
228 229
    "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."
230 231 232
    (let* ((directory (ensure-directory-pathname directory))
           #-(or abcl cormanlisp genera xcl)
           (wild (merge-pathnames*
233
                  #-(or abcl allegro cmucl lispworks sbcl scl xcl)
234
                  *wild-directory*
235
                  #+(or abcl allegro cmucl lispworks sbcl scl xcl) "*.*"
236 237 238 239 240 241 242 243
                  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)
244
             #+genera (handler-case (fs:directory-list directory) (fs:directory-not-found () nil)))
245
           #+(or abcl allegro cmucl genera lispworks sbcl scl xcl)
246 247 248
           (dirs (loop :for x :in dirs
                       :for d = #+(or abcl xcl) (extensions:probe-directory x)
                       #+allegro (excl:probe-directory x)
249
                       #+(or cmucl sbcl scl) (directory-pathname-p x)
250 251
                       #+genera (getf (cdr x) :directory)
                       #+lispworks (lw:file-directory-p x)
252
                       :when d :collect #+(or abcl allegro xcl) (ensure-directory-pathname d)
253
                         #+genera (ensure-directory-pathname (first x))
254
                       #+(or cmucl lispworks sbcl scl) x)))
255
      (filter-logical-directory-results
256 257 258 259 260 261 262 263 264 265 266
       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)
267 268
    "Given a DIRECTORY, when COLLECTP returns true when CALL-FUNCTION'ed with the directory,
call-function the COLLECTOR function designator on the directory,
269 270 271 272
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."
273
    (when (call-function collectp directory)
274 275 276 277
      (call-function collector directory)
      (dolist (subdir (subdirectories directory))
        (when (call-function recursep subdir)
          (collect-sub*directories subdir collectp recursep collector))))))
278 279

;;; Resolving symlinks somewhat
280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296
(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
297 298
            (if-let (parent
                     (ignore-errors
299 300
                      (probe-file* (make-pathname :directory `(:absolute ,@(reverse up-components))
                                                  :name nil :type nil :version nil :defaults p))))
301 302 303
              (if-let (simplified
                       (ignore-errors
                        (merge-pathnames*
304 305
                         (make-pathname :directory `(:relative ,@down-components)
                                        :defaults p)
306 307 308 309
                         (ensure-directory-pathname parent))))
                (return simplified)))
            (push (pop up-components) down-components)
            :finally (return p))))))
310 311

  (defun resolve-symlinks (path)
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
312
    "Do a best effort at resolving symlinks in PATH, returning a partially or totally resolved PATH."
313 314 315 316 317 318 319 320
    #-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.
321 322
Defaults to T.")

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


;;; Check pathname constraints
331 332 333 334
(with-upgradability ()
  (defun ensure-pathname
      (pathname &key
                  on-error
335
                  defaults type dot-dot namestring
336
                  empty-is-nil
337 338 339 340 341 342 343 344 345
                  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,
346 347 348 349
optionally doing some transformations and checking specified constraints.

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

350 351 352 353 354 355 356 357 358 359 360
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.
361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379

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:

380
EMPTY-IS-NIL returns NIL if the argument is an empty string.
381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402
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."
403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419
    (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
420 421
             (when (and (emptyp p) empty-is-nil)
               (return-from ensure-pathname nil))
422 423 424 425 426 427 428 429 430 431 432 433 434 435 436 437
             (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)))
438 439
          (check want-logical (logical-pathname-p p) "Expected a logical pathname")
          (check want-physical (physical-pathname-p p) "Expected a physical pathname")
440
          (transform ensure-physical () (physicalize-pathname p))
441 442 443
          (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")
444 445
          (transform ensure-absolute (not (absolute-pathname-p p))
                     (ensure-absolute-pathname p defaults (list #'report-error :ensure-absolute "~@?")))
446 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
          (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)))))
472 473 474


;;; Pathname defaults
475 476
(with-upgradability ()
  (defun get-pathname-defaults (&optional (defaults *default-pathname-defaults*))
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
477 478
    "Find the actual DEFAULTS to use for pathnames, including
resolving them with respect to GETCWD if the DEFAULTS were relative"
479 480 481 482
    (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
483 484
    "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."
485 486
    (if dir
        (let* ((dir (resolve-symlinks* (get-pathname-defaults (pathname-directory-pathname dir))))
487 488
               (cwd (getcwd))
               (*default-pathname-defaults* dir))
489 490 491 492 493 494 495 496 497
          (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))))
498 499 500


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

506 507
  (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,
508
check constraints and normalize each one as per ENSURE-PATHNAME,
509
where an empty string denotes NIL."
510
    (loop :for namestring :in (split-string string :separator (string (inter-directory-separator)))
511
          :collect (unless (emptyp namestring) (apply 'parse-native-namestring namestring constraints))))
512

513
  (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
514 515
    "Extract a pathname from a user-configured environment variable, as per native OS,
check constraints and normalize as per ENSURE-PATHNAME."
516
    ;; For backward compatibility with ASDF 2, want-directory implies ensure-directory
517
    (apply 'parse-native-namestring (getenvp x)
518
           :ensure-directory (or ensure-directory want-directory)
519 520 521
           :on-error (or on-error
                         `(error "In (~S ~S), invalid pathname ~*~S: ~*~?" getenv-pathname ,x))
           constraints))
522
  (defun getenv-pathnames (x &rest constraints &key on-error &allow-other-keys)
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
523
    "Extract a list of pathname from a user-configured environment variable, as per native OS,
524 525 526 527
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."))
528 529 530
    (apply 'split-native-pathnames-string (getenvp x)
           :on-error (or on-error
                         `(error "In (~S ~S), invalid pathname ~*~S: ~*~?" getenv-pathnames ,x))
531
           :empty-is-nil t
532
           constraints))
533
  (defun getenv-absolute-directory (x)
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
534 535
    "Extract an absolute directory pathname from a user-configured environment variable,
as per native OS"
536
    (getenv-pathname x :want-absolute t :ensure-directory t))
537
  (defun getenv-absolute-directories (x)
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
538
    "Extract a list of absolute directories from a user-configured environment variable,
539 540 541
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))
542 543

  (defun lisp-implementation-directory (&key truename)
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
544
    "Where are the system files of the current installation of the CL implementation?"
545 546
    (declare (ignorable truename))
    (let ((dir
547 548
            #+abcl extensions:*lisp-home*
            #+(or allegro clasp ecl mkcl) #p"SYS:"
549
            #+clisp custom:*lib-directory*
550
            #+clozure #p"ccl:"
551
            #+cmucl (ignore-errors (pathname-parent-directory-pathname (truename #p"modules:")))
552 553 554 555 556 557 558
            #+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*))
559 560 561 562 563
      (if (and dir truename)
          (truename* dir)
          dir)))

  (defun lisp-implementation-pathname-p (pathname)
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
564
    "Is the PATHNAME under the current installation of the CL implementation?"
565 566 567 568 569 570 571 572 573
    ;; 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)))
574 575


576
;;; Simple filesystem operations
577 578
(with-upgradability ()
  (defun ensure-all-directories-exist (pathnames)
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
579
    "Ensure that for every pathname in PATHNAMES, we ensure its directories exist"
580
    (dolist (pathname pathnames)
581
      (when pathname
582
        (ensure-directories-exist (physicalize-pathname pathname)))))
583

584 585 586 587
  (defun delete-file-if-exists (x)
    "Delete a file X if it already exists"
    (when x (handler-case (delete-file x) (file-error () nil))))

588
  (defun rename-file-overwriting-target (source target)
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
589 590
    "Rename a file, overwriting any previous file with the TARGET name,
in an atomic way if the implementation allows."
591 592 593 594 595 596 597 598 599 600
    (let ((source (ensure-pathname source :namestring :lisp :ensure-physical t :want-file t))
          (target (ensure-pathname target :namestring :lisp :ensure-physical t :want-file t)))
      #+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))
      #+(and sbcl os-windows) (delete-file-if-exists target) ;; not atomic
      #-clisp
      (rename-file source target
                   #+(or clasp clozure ecl) :if-exists
                   #+clozure :rename-and-delete #+(or clasp ecl) t)))
601

602 603 604 605 606 607
  (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)
608
    #+(or cmucl scl) (multiple-value-bind (ok errno)
609 610
                       (unix:unix-rmdir (native-namestring directory-pathname))
                     (unless ok
611
                       #+cmucl (error "Error number ~A when trying to delete directory ~A"
612 613 614 615
                                    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
616
    #+(or clasp ecl) (si:rmdir directory-pathname)
617
    #+genera (fs:delete-directory directory-pathname)
618 619
    #+lispworks (lw:delete-directory directory-pathname)
    #+mkcl (mkcl:rmdir directory-pathname)
620 621 622
    #+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)))
623
    #+xcl (symbol-call :uiop :run-program `("rmdir" ,(native-namestring directory-pathname)))
624
    #-(or abcl allegro clasp clisp clozure cmucl cormanlisp digitool ecl gcl genera lispworks mkcl sbcl scl xcl)
625
    (not-implemented-error 'delete-empty-directory "(on your platform)")) ; genera
626 627 628 629 630 631 632 633 634 635 636 637 638 639 640 641 642 643 644

  (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"
645
              'delete-directory-tree directory-pathname))
646 647
      ((not validatep)
       (error "~S was asked to delete ~S but was not provided a validation predicate"
648
              'delete-directory-tree directory-pathname))
649 650
      ((not (call-function validate directory-pathname))
       (error "~S was asked to delete ~S but it is not valid ~@[according to ~S~]"
651
              'delete-directory-tree directory-pathname validate))
652 653 654 655
      ((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"
656
              'delete-directory-tree directory-pathname))
657
         (:ignore nil)))
658
      #-(or allegro cmucl clozure genera sbcl scl)
659 660 661 662 663 664 665 666 667
      ((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)
668
       #+genera (fs:delete-directory directory-pathname :confirm nil)
669 670 671
       #+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))
672 673 674 675 676 677 678 679 680
       ;; 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)))))))