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

43
;;; Normalizing pathnames across implementations
44

45
46
47
48
(with-upgradability ()
  (defun normalize-pathname-directory-component (directory)
    "Given a pathname directory component, return an equivalent form that is a list"
    #+gcl2.6 (setf directory (substitute :back :parent directory))
49
    (cond
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
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
95
96
97
98
99
100
101
102
103
104
105
106
107
      #-(or cmu sbcl scl) ;; these implementations already normalize directory components.
      ((stringp directory) `(:absolute ,directory))
      #+gcl2.6
      ((and (consp directory) (eq :root (first directory)))
       `(:absolute ,@(rest directory)))
      ((or (null directory)
           (and (consp directory) (member (first directory) '(:absolute :relative))))
       directory)
      #+gcl2.6
      ((consp directory)
       `(:relative ,@directory))
      (t
       (error (compatfmt "~@<Unrecognized pathname directory component ~S~@:>") directory))))

  (defun denormalize-pathname-directory-component (directory-component)
    #-gcl2.6 directory-component
    #+gcl2.6
    (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)))))))))))

  ;; 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)

  (defun make-pathname* (&rest keys &key (directory nil #+gcl2.6 directoryp)
                                      host (device () #+allegro devicep) name type version defaults
                                      #+scl &allow-other-keys)
    "Takes arguments like CL:MAKE-PATHNAME in the CLHS, and
108
109
   tries hard to make a pathname that will actually behave as documented,
   despite the peculiarities of each implementation"
110
    ;; TODO: reimplement defaulting for MCL, whereby an explicit NIL should override the defaults.
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
    (declare (ignorable host device directory name type version defaults))
    (apply 'make-pathname
           (append
            #+allegro (when (and devicep (null device)) `(:device :unspecific))
            #+gcl2.6
            (when directoryp
              `(:directory ,(denormalize-pathname-directory-component directory)))
            keys)))

  (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,
130
and make a new pathname with corresponding components and specified logical HOST"
131
132
133
134
135
136
137
138
139
    (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))))

  (defun merge-pathnames* (specified &optional (defaults *default-pathname-defaults*))
    "MERGE-PATHNAMES* is like MERGE-PATHNAMES except that
140
141
142
143
144
145
146
147
148
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."
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
176
177
178
179
180
    (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))))))

  (defun nil-pathname (&optional (defaults *default-pathname-defaults*))
    "A pathname that is as neutral as possible for use as defaults
181
   when merging, making or parsing pathnames"
182
183
184
185
    ;; 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.
186
187
    ;; MCL has issues with make-pathname, nil and defaulting
    (declare (ignorable defaults))
188
189
190
191
192
    #.`(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
193
                       #-mcl ,@'(:defaults defaults)))
194

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

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

200

201
;;; Some pathname predicates
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
(with-upgradability ()
  (defun pathname-equal (p1 p2)
    (when (stringp p1) (setf p1 (pathname p1)))
    (when (stringp p2) (setf p2 (pathname p2)))
    (flet ((normalize-component (x)
             (unless (member x '(nil :unspecific :newest (:relative)) :test 'equal)
               x)))
      (macrolet ((=? (&rest accessors)
                   (flet ((frob (x)
                            (reduce 'list (cons 'normalize-component accessors)
                                    :initial-value x :from-end t)))
                     `(equal ,(frob 'p1) ,(frob 'p2)))))
        (or (and (null p1) (null p2))
            (and (pathnamep p1) (pathnamep p2)
                 (and (=? pathname-host)
                      (=? pathname-device)
                      (=? normalize-pathname-directory-component pathname-directory)
                      (=? pathname-name)
                      (=? pathname-type)
                      (=? pathname-version)))))))

  (defun logical-pathname-p (x)
    (typep x 'logical-pathname))

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

  (defun absolute-pathname-p (pathspec)
    "If PATHSPEC is a pathname or namestring object that parses as a pathname
231
232
possessing an :ABSOLUTE directory component, return the (parsed) pathname.
Otherwise return NIL"
233
234
235
236
237
238
239
240
241
    (and pathspec
         (typep pathspec '(or null pathname string))
         (let ((pathname (pathname pathspec)))
           (and (eq :absolute (car (normalize-pathname-directory-component
                                    (pathname-directory pathname))))
                pathname))))

  (defun relative-pathname-p (pathspec)
    "If PATHSPEC is a pathname or namestring object that parses as a pathname
242
243
possessing a :RELATIVE or NIL directory component, return the (parsed) pathname.
Otherwise return NIL"
244
245
246
247
248
249
250
251
252
253
    (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))))

  (defun hidden-pathname-p (pathname)
    "Return a boolean that is true if the pathname is hidden as per Unix style,
254
i.e. its name starts with a dot."
255
    (and pathname (equal (first-char (pathname-name pathname)) #\.)))
256

257
258
  (defun file-pathname-p (pathname)
    "Does PATHNAME represent a file, i.e. has a non-null NAME component?
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"
266
267
268
269
270
    (when pathname
      (let* ((pathname (pathname pathname))
             (name (pathname-name pathname)))
        (when (not (member name '(nil :unspecific "") :test 'equal))
          pathname)))))
271

272
273

;;; Directory pathnames
274
275
276
(with-upgradability ()
  (defun pathname-directory-pathname (pathname)
    "Returns a new pathname with same HOST, DEVICE, DIRECTORY as PATHNAME,
277
and NIL NAME, TYPE and VERSION components"
278
279
    (when pathname
      (make-pathname :name nil :type nil :version nil :defaults pathname)))
280

281
282
  (defun pathname-parent-directory-pathname (pathname)
    "Returns a new pathname that corresponds to the parent of the current pathname's directory,
283
284
i.e. removing one level of depth in the DIRECTORY component. e.g. if pathname is
Unix pathname /foo/bar/baz/file.type then return /foo/bar/"
285
286
287
288
289
    (when pathname
      (make-pathname* :name nil :type nil :version nil
                      :directory (merge-pathname-directory-components
                                  '(:relative :back) (pathname-directory pathname))
                      :defaults pathname)))
290

291
292
  (defun directory-pathname-p (pathname)
    "Does PATHNAME represent a directory?
293
294
295
296
297
298
299

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."
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
    (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)))))

  (defun ensure-directory-pathname (pathspec &optional (on-error 'error))
    "Converts the non-wild pathname designator PATHSPEC to directory form."
    (cond
      ((stringp pathspec)
       (ensure-directory-pathname (pathname pathspec)))
      ((not (pathnamep pathspec))
       (call-function on-error (compatfmt "~@<Invalid pathname designator ~S~@:>") pathspec))
      ((wild-pathname-p pathspec)
       (call-function on-error (compatfmt "~@<Can't reliably convert wild pathname ~3i~_~S~@:>") pathspec))
      ((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)))))
326
327


328
;;; Parsing filenames
329
330
331
332
(with-upgradability ()
  (defun split-unix-namestring-directory-components
      (unix-namestring &key ensure-directory dot-dot)
    "Splits the path string UNIX-NAMESTRING, returning four values:
333
334
335
336
337
338
339
340
341
342
343
344
345
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.
346

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

349
350
Note that : characters will NOT be interpreted as host specification.
Absolute pathnames are only appropriate on Unix-style systems.
351

352
353
The intention of this function is to support structured component names,
e.g., \(:file \"foo/bar\"\), which will be unpacked to relative pathnames."
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
    (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)))))))

  (defun split-name-type (filename)
    "Split a filename into two values NAME and TYPE that are returned.
380
381
382
383
384
385
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."
386
387
388
389
390
391
392
393
394
395
396
    (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))))

  (defun parse-unix-namestring (name &rest keys &key type defaults dot-dot ensure-directory
                                &allow-other-keys)
    "Coerce NAME into a PATHNAME using standard Unix syntax.
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411

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:
412
413
414
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.
415
2- If TYPE is NIL, the substring is a file-namestring, and its NAME and TYPE
416
417
 are separated by SPLIT-NAME-TYPE.
3- If TYPE is a string, it is the given TYPE, and the whole string is the NAME.
418
419

Directory components with an empty name the name . are removed.
420
421
Any directory named .. is read as DOT-DOT,
which must be one of :BACK or :UP and defaults to :BACK.
422
423

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

428
429
430
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*.
431

432
433
434
435
436
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"
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
    (block nil
      (check-type type (or null string (eql :directory)))
      (when ensure-directory
        (setf type :directory))
      (etypecase name
        ((or null pathname) (return name))
        (symbol
         (setf name (string-downcase name)))
        (string))
      (multiple-value-bind (relative path filename file-only)
          (split-unix-namestring-directory-components
           name :dot-dot dot-dot :ensure-directory (eq type :directory))
        (multiple-value-bind (name type)
            (cond
              ((or (eq type :directory) (null filename))
               (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
461
                  :defaults (or #-mcl defaults *nil-pathname*))
462
463
464
465
                 (remove-plist-keys '(:type :dot-dot :defaults) keys))))))

  (defun unix-namestring (pathname)
    "Given a non-wild PATHNAME, return a Unix-style namestring for it.
466
467
468
469
470
471
472
473
474
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."
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
    (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)))
             (cond
               ((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))
               (t
                (or (null type) (err)))))))))))
505

506
;;; Absolute and relative pathnames
507
508
509
(with-upgradability ()
  (defun subpathname (pathname subpath &key type)
    "This function takes a PATHNAME and a SUBPATH and a TYPE.
510
511
512
513
514
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."
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
    (or (and (pathnamep subpath) (absolute-pathname-p subpath))
        (merge-pathnames* (parse-unix-namestring subpath :type type :want-relative t)
                          (pathname-directory-pathname pathname))))

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

  (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))))

  (defun pathname-host-pathname (pathname)
    (make-pathname* :directory nil
                    :name nil :type nil :version nil :device 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))))

  (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))))))

  (defun ensure-absolute-pathname (path &optional defaults (on-error 'error))
    (cond
      ((absolute-pathname-p path))
      ((stringp path) (ensure-absolute-pathname (pathname path) defaults on-error))
      ((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)))))
562

563

564
;;; Wildcard pathnames
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
(with-upgradability ()
  (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)))
583
584
585


;;; Translate a pathname
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
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
(with-upgradability ()
  (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))))))

  #+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))
654
    (cond
655
656
657
658
659
660
661
662
663
664
      ((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))
665
      (t
666
       (translate-pathname path absolute-source destination))))
667

668
669
670
671
672
673
674
675
  (defvar *output-translation-function* 'identity
    "Hook for output translations.

This function needs to be idempotent, so that actions can work
whether their inputs were translated or not,
which they will be if we are composing operations. e.g. if some
create-lisp-op creates a lisp file from some higher-level input,
you need to still be able to use compile-op on that lisp file."))
676