pathname.lisp 29.6 KB
Newer Older
1 2
;;;; -------------------------------------------------------------------------
;;;; Portability layer around Common Lisp pathnames
3 4
;; This layer allows for portable manipulation of pathname objects themselves,
;; which all is necessary prior to any access the filesystem or environment.
5 6 7

(asdf/package:define-package :asdf/pathname
  (:recycle :asdf/pathname :asdf)
8
  (:use :asdf/common-lisp :asdf/package :asdf/utility :asdf/os)
9
  (:export
10
   ;; Making and merging pathnames, portably
11
   #:normalize-pathname-directory-component #:denormalize-pathname-directory-component
12
   #:merge-pathname-directory-components #:*unspecific-pathname-type* #:make-pathname*
13 14
   #:make-pathname-component-logical #:make-pathname-logical
   #:merge-pathnames*
15
   #:nil-pathname #:*nil-pathname* #:with-pathname-defaults
16 17 18
   ;; Predicates
   #:pathname-equal #:logical-pathname-p #:physical-pathname-p
   #:absolute-pathname-p #:relative-pathname-p #:hidden-pathname-p #:file-pathname-p
19 20
   ;; Directories
   #:pathname-directory-pathname #:pathname-parent-directory-pathname
21 22
   #:directory-pathname-p #:ensure-directory-pathname
   ;; Parsing filenames
23
   #:component-name-to-pathname-components
24
   #:split-name-type #:parse-unix-namestring #:unix-namestring
25
   #:split-unix-namestring-directory-components
26
   ;; Absolute and relative pathnames
27
   #:subpathname #:subpathname*
28
   #:ensure-absolute-pathname
29 30
   #:pathname-root #:pathname-host-pathname
   #:subpathp
31
   ;; Checking constraints
32 33 34
   #:ensure-pathname ;; implemented in filesystem.lisp to accommodate for existence constraints
   ;; Wildcard pathnames
   #:*wild* #:*wild-file* #:*wild-directory* #:*wild-inferiors* #:*wild-path* #:wilden
35 36 37 38
   ;; Translate a pathname
   #:relativize-directory-component #:relativize-pathname-directory
   #:directory-separator-for-host #:directorize-pathname-host-device
   #:translate-pathname*
39
   #:*output-translation-function*))
40 41
(in-package :asdf/pathname)

42
;;; Normalizing pathnames across implementations
43 44 45

(defun* normalize-pathname-directory-component (directory)
  "Given a pathname directory component, return an equivalent form that is a list"
46
  #+gcl2.6 (setf directory (substitute :back :parent directory))
47 48 49
  (cond
    #-(or cmu sbcl scl) ;; these implementations already normalize directory components.
    ((stringp directory) `(:absolute ,directory))
50
    #+gcl2.6
51 52 53 54 55
    ((and (consp directory) (eq :root (first directory)))
     `(:absolute ,@(rest directory)))
    ((or (null directory)
         (and (consp directory) (member (first directory) '(:absolute :relative))))
     directory)
56
    #+gcl2.6
57 58 59 60 61 62
    ((consp directory)
     `(:relative ,@directory))
    (t
     (error (compatfmt "~@<Unrecognized pathname directory component ~S~@:>") directory))))

(defun* denormalize-pathname-directory-component (directory-component)
63 64
  #-gcl2.6 directory-component
  #+gcl2.6
65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94
  (let ((d (substitute-if :parent (lambda (x) (member x '(:up :back)))
                          directory-component)))
    (cond
      ((and (consp d) (eq :relative (first d))) (rest d))
      ((and (consp d) (eq :absolute (first d))) `(:root ,@(rest d)))
      (t d))))

(defun* merge-pathname-directory-components (specified defaults)
  ;; Helper for merge-pathnames* that handles directory components.
  (let ((directory (normalize-pathname-directory-component specified)))
    (ecase (first directory)
      ((nil) defaults)
      (:absolute specified)
      (:relative
       (let ((defdir (normalize-pathname-directory-component defaults))
             (reldir (cdr directory)))
         (cond
           ((null defdir)
            directory)
           ((not (eq :back (first reldir)))
            (append defdir reldir))
           (t
            (loop :with defabs = (first defdir)
              :with defrev = (reverse (rest defdir))
              :while (and (eq :back (car reldir))
                          (or (and (eq :absolute defabs) (null defrev))
                              (stringp (car defrev))))
              :do (pop reldir) (pop defrev)
              :finally (return (cons defabs (append (reverse defrev) reldir)))))))))))

95 96 97 98 99 100 101
;; Giving :unspecific as :type argument to make-pathname is not portable.
;; See CLHS make-pathname and 19.2.2.2.3.
;; This will be :unspecific if supported, or NIL if not.
(defparameter *unspecific-pathname-type*
  #+(or abcl allegro clozure cmu gcl genera lispworks mkcl sbcl scl xcl) :unspecific
  #+(or clisp ecl #|These haven't been tested:|# cormanlisp mcl) nil)

102 103
(defun* make-pathname* (&rest keys &key (directory nil #+gcl2.6 directoryp)
                              host (device () #+allegro devicep) name type version defaults
104
                              #+scl &allow-other-keys)
105 106 107
  "Takes arguments like CL:MAKE-PATHNAME in the CLHS, and
   tries hard to make a pathname that will actually behave as documented,
   despite the peculiarities of each implementation"
108
  (declare (ignorable host device directory name type version defaults))
109
  (apply 'make-pathname
110
         (append
111
          #+allegro (when (and devicep (null device)) `(:device :unspecific))
112
          #+gcl2.6
113 114 115
          (when directoryp
            `(:directory ,(denormalize-pathname-directory-component directory)))
          keys)))
116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134

(defun* make-pathname-component-logical (x)
  "Make a pathname component suitable for use in a logical-pathname"
  (typecase x
    ((eql :unspecific) nil)
    #+clisp (string (string-upcase x))
    #+clisp (cons (mapcar 'make-pathname-component-logical x))
    (t x)))

(defun* make-pathname-logical (pathname host)
  "Take a PATHNAME's directory, name, type and version components,
and make a new pathname with corresponding components and specified logical HOST"
  (make-pathname*
   :host host
   :directory (make-pathname-component-logical (pathname-directory pathname))
   :name (make-pathname-component-logical (pathname-name pathname))
   :type (make-pathname-component-logical (pathname-type pathname))
   :version (make-pathname-component-logical (pathname-version pathname))))

135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175
(defun* merge-pathnames* (specified &optional (defaults *default-pathname-defaults*))
  "MERGE-PATHNAMES* is like MERGE-PATHNAMES except that
if the SPECIFIED pathname does not have an absolute directory,
then the HOST and DEVICE both come from the DEFAULTS, whereas
if the SPECIFIED pathname does have an absolute directory,
then the HOST and DEVICE both come from the SPECIFIED.
This is what users want on a modern Unix or Windows operating system,
unlike the MERGE-PATHNAME behavior.
Also, if either argument is NIL, then the other argument is returned unmodified;
this is unlike MERGE-PATHNAME which always merges with a pathname,
by default *DEFAULT-PATHNAME-DEFAULTS*, which cannot be NIL."
  (when (null specified) (return-from merge-pathnames* defaults))
  (when (null defaults) (return-from merge-pathnames* specified))
  #+scl
  (ext:resolve-pathname specified defaults)
  #-scl
  (let* ((specified (pathname specified))
         (defaults (pathname defaults))
         (directory (normalize-pathname-directory-component (pathname-directory specified)))
         (name (or (pathname-name specified) (pathname-name defaults)))
         (type (or (pathname-type specified) (pathname-type defaults)))
         (version (or (pathname-version specified) (pathname-version defaults))))
    (labels ((unspecific-handler (p)
               (if (typep p 'logical-pathname) #'make-pathname-component-logical #'identity)))
      (multiple-value-bind (host device directory unspecific-handler)
          (ecase (first directory)
            ((:absolute)
             (values (pathname-host specified)
                     (pathname-device specified)
                     directory
                     (unspecific-handler specified)))
            ((nil :relative)
             (values (pathname-host defaults)
                     (pathname-device defaults)
                     (merge-pathname-directory-components directory (pathname-directory defaults))
                     (unspecific-handler defaults))))
        (make-pathname* :host host :device device :directory directory
                        :name (funcall unspecific-handler name)
                        :type (funcall unspecific-handler type)
                        :version (funcall unspecific-handler version))))))

176 177 178 179 180 181 182
(defun* nil-pathname (&optional (defaults *default-pathname-defaults*))
  "A pathname that is as neutral as possible for use as defaults
   when merging, making or parsing pathnames"
  ;; 19.2.2.2.1 says a NIL host can mean a default host;
  ;; see also "valid physical pathname host" in the CLHS glossary, that suggests
  ;; strings and lists of strings or :unspecific
  ;; But CMUCL decides to die on NIL.
183 184 185 186 187 188
  #.`(make-pathname* :directory nil :name nil :type nil :version nil :device nil
                     :host (or #+cmu lisp::*unix-host*)
                     #+scl ,@'(:scheme nil :scheme-specific-part nil
                               :username nil :password nil :parameters nil :query nil :fragment nil)
                     ;; the default shouldn't matter, but we really want something physical
                     :defaults defaults))
189 190 191 192 193 194

(defvar *nil-pathname* (nil-pathname (translate-logical-pathname (user-homedir-pathname))))

(defmacro with-pathname-defaults ((&optional defaults) &body body)
  `(let ((*default-pathname-defaults* ,(or defaults '*nil-pathname*))) ,@body))

195

196 197
;;; Some pathname predicates

198 199 200 201
(defun* pathname-equal (p1 p2)
  (when (stringp p1) (setf p1 (pathname p1)))
  (when (stringp p2) (setf p2 (pathname p2)))
  (flet ((normalize-component (x)
202 203
           (unless (member x '(nil :unspecific :newest (:relative)) :test 'equal)
             x)))
204 205 206 207 208
    (macrolet ((=? (&rest accessors)
                 (flet ((frob (x)
                          (reduce 'list (cons 'normalize-component accessors)
                                  :initial-value x :from-end t)))
                   `(equal ,(frob 'p1) ,(frob 'p2)))))
209
      (or (and (null p1) (null p2))
210
          (and (pathnamep p1) (pathnamep p2)
211 212 213 214 215 216
               (and (=? pathname-host)
                    (=? pathname-device)
                    (=? normalize-pathname-directory-component pathname-directory)
                    (=? pathname-name)
                    (=? pathname-type)
                    (=? pathname-version)))))))
217

218 219 220 221 222
(defun* logical-pathname-p (x)
  (typep x 'logical-pathname))

(defun* physical-pathname-p (x)
  (and (pathnamep x) (not (logical-pathname-p x))))
223

224 225 226 227 228 229 230 231 232 233 234
(defun* absolute-pathname-p (pathspec)
  "If PATHSPEC is a pathname or namestring object that parses as a pathname
possessing an :ABSOLUTE directory component, return the (parsed) pathname.
Otherwise return NIL"
  (and pathspec
       (typep pathspec '(or null pathname string))
       (let ((pathname (pathname pathspec)))
         (and (eq :absolute (car (normalize-pathname-directory-component
                                  (pathname-directory pathname))))
              pathname))))

235 236 237 238 239 240 241 242 243 244 245 246
(defun* relative-pathname-p (pathspec)
  "If PATHSPEC is a pathname or namestring object that parses as a pathname
possessing a :RELATIVE or NIL directory component, return the (parsed) pathname.
Otherwise return NIL"
  (and pathspec
       (typep pathspec '(or null pathname string))
       (let* ((pathname (pathname pathspec))
              (directory (normalize-pathname-directory-component
                          (pathname-directory pathname))))
         (when (or (null directory) (eq :relative (car directory)))
           pathname))))

247
(defun* hidden-pathname-p (pathname)
248 249
  "Return a boolean that is true if the pathname is hidden as per Unix style,
i.e. its name starts with a dot."
250 251
  (and pathname (equal (first-char (pathname-name pathname)) #\.)))

252 253
(defun* file-pathname-p (pathname)
  "Does PATHNAME represent a file, i.e. has a non-null NAME component?
254

255 256 257 258 259 260 261 262 263 264 265
Accepts NIL, a string (converted through PARSE-NAMESTRING) or a PATHNAME.

Note that this does _not_ check to see that PATHNAME points to an
actually-existing file.

Returns the (parsed) PATHNAME when true"
  (when pathname
    (let* ((pathname (pathname pathname))
           (name (pathname-name pathname)))
      (when (not (member name '(nil :unspecific "") :test 'equal))
        pathname))))
266

267 268

;;; Directory pathnames
269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301
(defun* pathname-directory-pathname (pathname)
  "Returns a new pathname with same HOST, DEVICE, DIRECTORY as PATHNAME,
and NIL NAME, TYPE and VERSION components"
  (when pathname
    (make-pathname :name nil :type nil :version nil :defaults pathname)))

(defun* pathname-parent-directory-pathname (pathname)
  "Returns a new pathname with same HOST, DEVICE, DIRECTORY as PATHNAME,
and NIL NAME, TYPE and VERSION components"
  (when pathname
    (make-pathname* :name nil :type nil :version nil
                    :directory (merge-pathname-directory-components
                                '(:relative :back) (pathname-directory pathname))
                    :defaults pathname)))

(defun* directory-pathname-p (pathname)
  "Does PATHNAME represent a directory?

A directory-pathname is a pathname _without_ a filename. The three
ways that the filename components can be missing are for it to be NIL,
:UNSPECIFIC or the empty string.

Note that this does _not_ check to see that PATHNAME points to an
actually-existing directory."
  (when pathname
    (let ((pathname (pathname pathname)))
      (flet ((check-one (x)
               (member x '(nil :unspecific "") :test 'equal)))
        (and (not (wild-pathname-p pathname))
             (check-one (pathname-name pathname))
             (check-one (pathname-type pathname))
             t)))))

302
(defun* ensure-directory-pathname (pathspec &optional (on-error 'error))
303 304 305 306 307
  "Converts the non-wild pathname designator PATHSPEC to directory form."
  (cond
   ((stringp pathspec)
    (ensure-directory-pathname (pathname pathspec)))
   ((not (pathnamep pathspec))
308
    (call-function on-error (compatfmt "~@<Invalid pathname designator ~S~@:>") pathspec))
309
   ((wild-pathname-p pathspec)
310
    (call-function on-error (compatfmt "~@<Can't reliably convert wild pathname ~3i~_~S~@:>") pathspec))
311 312 313 314 315 316 317 318 319 320
   ((directory-pathname-p pathspec)
    pathspec)
   (t
    (make-pathname* :directory (append (or (normalize-pathname-directory-component
                                            (pathname-directory pathspec))
                                           (list :relative))
                                       (list (file-namestring pathspec)))
                    :name nil :type nil :version nil :defaults pathspec))))


321
;;; Parsing filenames
322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337
(defun* split-unix-namestring-directory-components
    (unix-namestring &key ensure-directory dot-dot)
  "Splits the path string UNIX-NAMESTRING, returning four values:
A flag that is either :absolute or :relative, indicating
   how the rest of the values are to be interpreted.
A directory path --- a list of strings and keywords, suitable for
   use with MAKE-PATHNAME when prepended with the flag value.
   Directory components with an empty name or the name . are removed.
   Any directory named .. is read as DOT-DOT, or :BACK if it's NIL (not :UP).
A last-component, either a file-namestring including type extension,
   or NIL in the case of a directory pathname.
A flag that is true iff the unix-style-pathname was just
   a file-namestring without / path specification.
ENSURE-DIRECTORY forces the namestring to be interpreted as a directory pathname:
the third return value will be NIL, and final component of the namestring
will be treated as part of the directory path.
338

339
An empty string is thus read as meaning a pathname object with all fields nil.
340

341 342
Note that : characters will NOT be interpreted as host specification.
Absolute pathnames are only appropriate on Unix-style systems.
343

344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368
The intention of this function is to support structured component names,
e.g., \(:file \"foo/bar\"\), which will be unpacked to relative pathnames."
  (check-type unix-namestring string)
  (check-type dot-dot (member nil :back :up))
  (if (and (not (find #\/ unix-namestring)) (not ensure-directory)
           (plusp (length unix-namestring)))
      (values :relative () unix-namestring t)
      (let* ((components (split-string unix-namestring :separator "/"))
             (last-comp (car (last components))))
        (multiple-value-bind (relative components)
            (if (equal (first components) "")
                (if (equal (first-char unix-namestring) #\/)
                    (values :absolute (cdr components))
                    (values :relative nil))
                (values :relative components))
          (setf components (remove-if #'(lambda (x) (member x '("" ".") :test #'equal))
                                      components))
          (setf components (substitute (or dot-dot :back) ".." components :test #'equal))
          (cond
            ((equal last-comp "")
             (values relative components nil nil)) ; "" already removed from components
            (ensure-directory
             (values relative components nil nil))
            (t
             (values relative (butlast components) last-comp nil)))))))
369 370

(defun* split-name-type (filename)
371 372 373 374 375 376 377 378 379 380 381 382 383 384 385
  "Split a filename into two values NAME and TYPE that are returned.
We assume filename has no directory component.
The last . if any separates name and type from from type,
except that if there is only one . and it is in first position,
the whole filename is the NAME with an empty type.
NAME is always a string.
For an empty type, *UNSPECIFIC-PATHNAME-TYPE* is returned."
  (check-type filename string)
  (assert (plusp (length filename)))
  (destructuring-bind (name &optional (type *unspecific-pathname-type*))
      (split-string filename :max 2 :separator ".")
    (if (equal name "")
        (values filename *unspecific-pathname-type*)
        (values name type))))

386
(defun* parse-unix-namestring (name &rest keys &key type defaults dot-dot ensure-directory
387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403
                                    &allow-other-keys)
  "Coerce NAME into a PATHNAME using standard Unix syntax.

Unix syntax is used whether or not the underlying system is Unix;
on such non-Unix systems it is only usable but for relative pathnames;
but especially to manipulate relative pathnames portably, it is of crucial
to possess a portable pathname syntax independent of the underlying OS.
This is what PARSE-UNIX-NAMESTRING provides, and why we use it in ASDF.

When given a PATHNAME object, just return it untouched.
When given NIL, just return NIL.
When given a non-null SYMBOL, first downcase its name and treat it as a string.
When given a STRING, portably decompose it into a pathname as below.

#\\/ separates directory components.

The last #\\/-separated substring is interpreted as follows:
404 405 406 407 408 409
1- If TYPE is :DIRECTORY or ENSURE-DIRECTORY is true,
 the string is made the last directory component, and NAME and TYPE are NIL.
 if the string is empty, it's the empty pathname with all slots NIL.
2- If TYPE is NIL, the substring is file-namestring, and its NAME and TYPE
 are separated by SPLIT-NAME-TYPE.
3- If TYPE is a string, it is the given TYPE, and the whole string is the NAME.
410 411

Directory components with an empty name the name . are removed.
412 413
Any directory named .. is read as DOT-DOT,
which must be one of :BACK or :UP and defaults to :BACK.
414 415

HOST, DEVICE and VERSION components are taken from DEFAULTS,
416
which itself defaults to *NIL-PATHNAME*, also used if DEFAULTS in NIL.
417
No host or device can be specified in the string itself,
418
which makes it unsuitable for absolute pathnames outside Unix.
419

420 421 422
For relative pathnames, these components (and hence the defaults) won't matter
if you use MERGE-PATHNAMES* but will matter if you use MERGE-PATHNAMES,
which is an important reason to always use MERGE-PATHNAMES*.
423

424 425 426 427 428
Arbitrary keys are accepted, and the parse result is passed to ENSURE-PATHNAME
with those keys, removing TYPE DEFAULTS and DOT-DOT.
When you're manipulating pathnames that are supposed to make sense portably
even though the OS may not be Unixish, we recommend you use :WANT-RELATIVE T
to throw an error if the pathname is absolute"
429 430
  (block nil
    (check-type type (or null string (eql :directory)))
431 432
    (when ensure-directory
      (setf type :directory))
433 434 435 436 437 438
    (etypecase name
      ((or null pathname) (return name))
      (symbol
       (setf name (string-downcase name)))
      (string))
    (multiple-value-bind (relative path filename file-only)
439
        (split-unix-namestring-directory-components
440
         name :dot-dot dot-dot :ensure-directory (eq type :directory))
441 442
      (multiple-value-bind (name type)
          (cond
443
            ((or (eq type :directory) (null filename))
444 445 446 447 448 449 450 451 452
             (values nil nil))
            (type
             (values filename type))
            (t
             (split-name-type filename)))
        (apply 'ensure-pathname
               (make-pathname*
                :directory (unless file-only (cons relative path))
                :name name :type type
453
                :defaults (or defaults *nil-pathname*))
454
               (remove-plist-keys '(:type :dot-dot :defaults) keys))))))
455 456 457 458 459 460 461 462 463 464 465 466 467 468 469 470 471 472 473 474 475

(defun* unix-namestring (pathname)
  "Given a non-wild PATHNAME, return a Unix-style namestring for it.
If the PATHNAME is NIL or a STRING, return it unchanged.

This only considers the DIRECTORY, NAME and TYPE components of the pathname.
This is a portable solution for representing relative pathnames,
But unless you are running on a Unix system, it is not a general solution
to representing native pathnames.

An error is signaled if the argument is not NULL, a STRING or a PATHNAME,
or if it is a PATHNAME but some of its components are not recognized."
  (etypecase pathname
    ((or null string) pathname)
    (pathname
     (with-output-to-string (s)
       (flet ((err () (error "Not a valid unix-namestring ~S" pathname)))
         (let* ((dir (normalize-pathname-directory-component (pathname-directory pathname)))
                (name (pathname-name pathname))
                (type (pathname-type pathname))
                (type (and (not (eq type :unspecific)) type)))
476
           (cond
477 478 479 480 481 482 483 484 485 486 487 488 489 490 491 492 493 494
             ((eq dir ()))
             ((eq dir '(:relative)) (princ "./" s))
             ((consp dir)
              (destructuring-bind (relabs &rest dirs) dir
                (or (member relabs '(:relative :absolute)) (err))
                (when (eq relabs :absolute) (princ #\/ s))
                (loop :for x :in dirs :do
                  (cond
                    ((member x '(:back :up)) (princ "../" s))
                    ((equal x "") (err))
                    ;;((member x '("." "..") :test 'equal) (err))
                    ((stringp x) (format s "~A/" x))
                    (t (err))))))
             (t (err)))
           (cond
             (name
              (or (and (stringp name) (or (null type) (stringp type))) (err))
              (format s "~A~@[.~A~]" name type))
495
             (t
496
              (or (null type) (err))))))))))
497

498
;;; Absolute and relative pathnames
499
(defun* subpathname (pathname subpath &key type)
500 501 502 503 504 505 506 507 508
  "This function takes a PATHNAME and a SUBPATH and a TYPE.
If SUBPATH is already a PATHNAME object (not namestring),
and is an absolute pathname at that, it is returned unchanged;
otherwise, SUBPATH is turned into a relative pathname with given TYPE
as per PARSE-UNIX-NAMESTRING with :WANT-RELATIVE T :TYPE TYPE,
then it is merged with the PATHNAME-DIRECTORY-PATHNAME of PATHNAME."
  (or (and (pathnamep subpath) (absolute-pathname-p subpath))
      (merge-pathnames* (parse-unix-namestring subpath :type type :want-relative t)
                        (pathname-directory-pathname pathname))))
509 510

(defun* subpathname* (pathname subpath &key type)
511
  "returns NIL if the base pathname is NIL, otherwise like SUBPATHNAME."
512 513 514
  (and pathname
       (subpathname (ensure-directory-pathname pathname) subpath :type type)))

515

516 517 518 519 520 521 522 523
;;; Pathname host and its root
(defun* pathname-root (pathname)
  (make-pathname* :directory '(:absolute)
                  :name nil :type nil :version nil
                  :defaults pathname ;; host device, and on scl, *some*
                  ;; scheme-specific parts: port username password, not others:
                  . #.(or #+scl '(:parameters nil :query nil :fragment nil))))

524
(defun* pathname-host-pathname (pathname)
525 526 527
  (make-pathname* :directory nil
                  :name nil :type nil :version nil :device nil
                  :defaults pathname ;; host device, and on scl, *some*
528 529 530
                  ;; scheme-specific parts: port username password, not others:
                  . #.(or #+scl '(:parameters nil :query nil :fragment nil))))

531 532 533 534 535 536 537 538 539
(defun* subpathp (maybe-subpath base-pathname)
  (and (pathnamep maybe-subpath) (pathnamep base-pathname)
       (absolute-pathname-p maybe-subpath) (absolute-pathname-p base-pathname)
       (directory-pathname-p base-pathname) (not (wild-pathname-p base-pathname))
       (pathname-equal (pathname-root maybe-subpath) (pathname-root base-pathname))
       (with-pathname-defaults ()
         (let ((enough (enough-namestring maybe-subpath base-pathname)))
           (and (relative-pathname-p enough) (pathname enough))))))

540
(defun* ensure-absolute-pathname (path &optional defaults (on-error 'error))
541 542
  (cond
    ((absolute-pathname-p path))
543
    ((stringp path) (ensure-absolute-pathname (pathname path) defaults on-error))
544 545 546 547 548 549 550 551 552 553 554 555
    ((not (pathnamep path)) (call-function on-error "not a valid pathname designator ~S" path))
    ((let ((default-pathname (if (pathnamep defaults) defaults (call-function defaults))))
       (or (if (absolute-pathname-p default-pathname)
               (absolute-pathname-p (merge-pathnames* path default-pathname))
               (call-function on-error "Default pathname ~S is not an absolute pathname"
                              default-pathname))
           (call-function on-error "Failed to merge ~S with ~S into an absolute pathname"
                          path default-pathname))))
    (t (call-function on-error
                      "Cannot ensure ~S is evaluated as an absolute pathname with defaults ~S"
                      path defaults))))

556

557 558 559 560 561 562 563 564 565 566 567 568 569 570 571 572 573 574
;;; Wildcard pathnames
(defparameter *wild* (or #+cormanlisp "*" :wild))
(defparameter *wild-directory-component* (or #+gcl2.6 "*" :wild))
(defparameter *wild-inferiors-component* (or #+gcl2.6 "**" :wild-inferiors))
(defparameter *wild-file*
  (make-pathname :directory nil :name *wild* :type *wild*
                 :version (or #-(or allegro abcl xcl) *wild*)))
(defparameter *wild-directory*
  (make-pathname* :directory `(:relative ,*wild-directory-component*)
                  :name nil :type nil :version nil))
(defparameter *wild-inferiors*
  (make-pathname* :directory `(:relative ,*wild-inferiors-component*)
                  :name nil :type nil :version nil))
(defparameter *wild-path*
  (merge-pathnames* *wild-file* *wild-inferiors*))

(defun* wilden (path)
  (merge-pathnames* *wild-path* path))
575 576 577 578 579 580 581 582 583 584 585 586 587 588 589 590 591 592 593 594 595 596 597 598 599 600 601 602 603 604 605 606 607 608 609 610 611 612 613 614 615 616 617 618


;;; Translate a pathname
(defun relativize-directory-component (directory-component)
  (let ((directory (normalize-pathname-directory-component directory-component)))
    (cond
      ((stringp directory)
       (list :relative directory))
      ((eq (car directory) :absolute)
       (cons :relative (cdr directory)))
      (t
       directory))))

(defun* relativize-pathname-directory (pathspec)
  (let ((p (pathname pathspec)))
    (make-pathname*
     :directory (relativize-directory-component (pathname-directory p))
     :defaults p)))

(defun* directory-separator-for-host (&optional (pathname *default-pathname-defaults*))
  (let ((foo (make-pathname* :directory '(:absolute "FOO") :defaults pathname)))
    (last-char (namestring foo))))

#-scl
(defun* directorize-pathname-host-device (pathname)
  #+(or unix abcl)
  (when (and #+abcl (os-unix-p) (physical-pathname-p pathname))
    (return-from directorize-pathname-host-device pathname))
  (let* ((root (pathname-root pathname))
         (wild-root (wilden root))
         (absolute-pathname (merge-pathnames* pathname root))
         (separator (directory-separator-for-host root))
         (root-namestring (namestring root))
         (root-string
          (substitute-if #\/
                         #'(lambda (x) (or (eql x #\:)
                                           (eql x separator)))
                         root-namestring)))
    (multiple-value-bind (relative path filename)
        (split-unix-namestring-directory-components root-string :ensure-directory t)
      (declare (ignore relative filename))
      (let ((new-base
             (make-pathname* :defaults root :directory `(:absolute ,@path))))
        (translate-pathname absolute-pathname wild-root (wilden new-base))))))
619

620 621 622 623 624 625 626 627 628 629 630 631 632 633 634 635 636 637 638 639 640 641 642 643 644 645 646 647 648 649 650 651 652 653 654 655 656 657
#+scl
(defun* directorize-pathname-host-device (pathname)
  (let ((scheme (ext:pathname-scheme pathname))
        (host (pathname-host pathname))
        (port (ext:pathname-port pathname))
        (directory (pathname-directory pathname)))
    (flet ((specificp (x) (and x (not (eq x :unspecific)))))
      (if (or (specificp port)
              (and (specificp host) (plusp (length host)))
              (specificp scheme))
        (let ((prefix ""))
          (when (specificp port)
            (setf prefix (format nil ":~D" port)))
          (when (and (specificp host) (plusp (length host)))
            (setf prefix (strcat host prefix)))
          (setf prefix (strcat ":" prefix))
          (when (specificp scheme)
            (setf prefix (strcat scheme prefix)))
          (assert (and directory (eq (first directory) :absolute)))
          (make-pathname* :directory `(:absolute ,prefix ,@(rest directory))
                          :defaults pathname)))
    pathname)))

(defun* (translate-pathname*) (path absolute-source destination &optional root source)
  (declare (ignore source))
  (cond
    ((functionp destination)
     (funcall destination path absolute-source))
    ((eq destination t)
     path)
    ((not (pathnamep destination))
     (error "Invalid destination"))
    ((not (absolute-pathname-p destination))
     (translate-pathname path absolute-source (merge-pathnames* destination root)))
    (root
     (translate-pathname (directorize-pathname-host-device path) absolute-source destination))
    (t
     (translate-pathname path absolute-source destination))))
658

659
(defvar *output-translation-function* 'identity) ; Hook for output translations
660 661