pathname.lisp - clic - Clic is an command line interactive client for gopher wr… | |
git clone git://bitreich.org/clic/ git://enlrupgkhuxnvlhsf6lc3fziv5h2hhfrinws65… | |
Log | |
Files | |
Refs | |
Tags | |
README | |
LICENSE | |
--- | |
pathname.lisp (37872B) | |
--- | |
1 ;;;; -------------------------------------------------------------------… | |
2 ;;;; Portability layer around Common Lisp pathnames | |
3 ;; This layer allows for portable manipulation of pathname objects thems… | |
4 ;; which all is necessary prior to any access the filesystem or environm… | |
5 | |
6 (uiop/package:define-package :uiop/pathname | |
7 (:nicknames :asdf/pathname) ;; deprecated. Used by ceramic | |
8 (:use :uiop/common-lisp :uiop/package :uiop/utility :uiop/os) | |
9 (:export | |
10 ;; Making and merging pathnames, portably | |
11 #:normalize-pathname-directory-component #:denormalize-pathname-direc… | |
12 #:merge-pathname-directory-components #:*unspecific-pathname-type* #:… | |
13 #:make-pathname-component-logical #:make-pathname-logical | |
14 #:merge-pathnames* | |
15 #:nil-pathname #:*nil-pathname* #:with-pathname-defaults | |
16 ;; Predicates | |
17 #:pathname-equal #:logical-pathname-p #:physical-pathname-p #:physica… | |
18 #:absolute-pathname-p #:relative-pathname-p #:hidden-pathname-p #:fil… | |
19 ;; Directories | |
20 #:pathname-directory-pathname #:pathname-parent-directory-pathname | |
21 #:directory-pathname-p #:ensure-directory-pathname | |
22 ;; Parsing filenames | |
23 #:split-name-type #:parse-unix-namestring #:unix-namestring | |
24 #:split-unix-namestring-directory-components | |
25 ;; Absolute and relative pathnames | |
26 #:subpathname #:subpathname* | |
27 #:ensure-absolute-pathname | |
28 #:pathname-root #:pathname-host-pathname | |
29 #:subpathp #:enough-pathname #:with-enough-pathname #:call-with-enoug… | |
30 ;; Checking constraints | |
31 #:ensure-pathname ;; implemented in filesystem.lisp to accommodate fo… | |
32 ;; Wildcard pathnames | |
33 #:*wild* #:*wild-file* #:*wild-file-for-directory* #:*wild-directory* | |
34 #:*wild-inferiors* #:*wild-path* #:wilden | |
35 ;; Translate a pathname | |
36 #:relativize-directory-component #:relativize-pathname-directory | |
37 #:directory-separator-for-host #:directorize-pathname-host-device | |
38 #:translate-pathname* | |
39 #:*output-translation-function*)) | |
40 (in-package :uiop/pathname) | |
41 | |
42 ;;; Normalizing pathnames across implementations | |
43 | |
44 (with-upgradability () | |
45 (defun normalize-pathname-directory-component (directory) | |
46 "Convert the DIRECTORY component from a format usable by the underly… | |
47 implementation's MAKE-PATHNAME and other primitives to a CLHS-standard f… | |
48 that is a list and not a string." | |
49 (cond | |
50 #-(or cmucl sbcl scl) ;; these implementations already normalize d… | |
51 ((stringp directory) `(:absolute ,directory)) | |
52 ((or (null directory) | |
53 (and (consp directory) (member (first directory) '(:absolute … | |
54 directory) | |
55 #+gcl | |
56 ((consp directory) | |
57 (cons :relative directory)) | |
58 (t | |
59 (parameter-error (compatfmt "~@<~S: Unrecognized pathname directo… | |
60 'normalize-pathname-directory-component director… | |
61 | |
62 (defun denormalize-pathname-directory-component (directory-component) | |
63 "Convert the DIRECTORY-COMPONENT from a CLHS-standard format to a fo… | |
64 by the underlying implementation's MAKE-PATHNAME and other primitives" | |
65 directory-component) | |
66 | |
67 (defun merge-pathname-directory-components (specified defaults) | |
68 "Helper for MERGE-PATHNAMES* that handles directory components" | |
69 (let ((directory (normalize-pathname-directory-component specified))) | |
70 (ecase (first directory) | |
71 ((nil) defaults) | |
72 (:absolute specified) | |
73 (:relative | |
74 (let ((defdir (normalize-pathname-directory-component defaults)) | |
75 (reldir (cdr directory))) | |
76 (cond | |
77 ((null defdir) | |
78 directory) | |
79 ((not (eq :back (first reldir))) | |
80 (append defdir reldir)) | |
81 (t | |
82 (loop :with defabs = (first defdir) | |
83 :with defrev = (reverse (rest defdir)) | |
84 :while (and (eq :back (car reldir)) | |
85 (or (and (eq :absolute defabs) (null def… | |
86 (stringp (car defrev)))) | |
87 :do (pop reldir) (pop defrev) | |
88 :finally (return (cons defabs (append (reverse defre… | |
89 | |
90 ;; Giving :unspecific as :type argument to make-pathname is not portab… | |
91 ;; See CLHS make-pathname and 19.2.2.2.3. | |
92 ;; This will be :unspecific if supported, or NIL if not. | |
93 (defparameter *unspecific-pathname-type* | |
94 #+(or abcl allegro clozure cmucl lispworks sbcl scl) :unspecific | |
95 #+(or genera clasp clisp ecl mkcl gcl xcl #|These haven't been teste… | |
96 "Unspecific type component to use with the underlying implementation… | |
97 | |
98 (defun make-pathname* (&rest keys &key directory host device name type… | |
99 #+scl &allow-other-keys) | |
100 "Takes arguments like CL:MAKE-PATHNAME in the CLHS, and | |
101 tries hard to make a pathname that will actually behave as documented, | |
102 despite the peculiarities of each implementation. DEPRECATED: just us… | |
103 (declare (ignore host device directory name type version defaults)) | |
104 (apply 'make-pathname keys)) | |
105 | |
106 (defun make-pathname-component-logical (x) | |
107 "Make a pathname component suitable for use in a logical-pathname" | |
108 (typecase x | |
109 ((eql :unspecific) nil) | |
110 #+clisp (string (string-upcase x)) | |
111 #+clisp (cons (mapcar 'make-pathname-component-logical x)) | |
112 (t x))) | |
113 | |
114 (defun make-pathname-logical (pathname host) | |
115 "Take a PATHNAME's directory, name, type and version components, | |
116 and make a new pathname with corresponding components and specified logi… | |
117 (make-pathname | |
118 :host host | |
119 :directory (make-pathname-component-logical (pathname-directory pat… | |
120 :name (make-pathname-component-logical (pathname-name pathname)) | |
121 :type (make-pathname-component-logical (pathname-type pathname)) | |
122 :version (make-pathname-component-logical (pathname-version pathnam… | |
123 | |
124 (defun merge-pathnames* (specified &optional (defaults *default-pathna… | |
125 "MERGE-PATHNAMES* is like MERGE-PATHNAMES except that | |
126 if the SPECIFIED pathname does not have an absolute directory, | |
127 then the HOST and DEVICE both come from the DEFAULTS, whereas | |
128 if the SPECIFIED pathname does have an absolute directory, | |
129 then the HOST and DEVICE both come from the SPECIFIED pathname. | |
130 This is what users want on a modern Unix or Windows operating system, | |
131 unlike the MERGE-PATHNAMES behavior. | |
132 Also, if either argument is NIL, then the other argument is returned unm… | |
133 this is unlike MERGE-PATHNAMES which always merges with a pathname, | |
134 by default *DEFAULT-PATHNAME-DEFAULTS*, which cannot be NIL." | |
135 (when (null specified) (return-from merge-pathnames* defaults)) | |
136 (when (null defaults) (return-from merge-pathnames* specified)) | |
137 #+scl | |
138 (ext:resolve-pathname specified defaults) | |
139 #-scl | |
140 (let* ((specified (pathname specified)) | |
141 (defaults (pathname defaults)) | |
142 (directory (normalize-pathname-directory-component (pathname-… | |
143 (name (or (pathname-name specified) (pathname-name defaults))) | |
144 (type (or (pathname-type specified) (pathname-type defaults))) | |
145 (version (or (pathname-version specified) (pathname-version d… | |
146 (labels ((unspecific-handler (p) | |
147 (if (typep p 'logical-pathname) #'make-pathname-compone… | |
148 (multiple-value-bind (host device directory unspecific-handler) | |
149 (ecase (first directory) | |
150 ((:absolute) | |
151 (values (pathname-host specified) | |
152 (pathname-device specified) | |
153 directory | |
154 (unspecific-handler specified))) | |
155 ((nil :relative) | |
156 (values (pathname-host defaults) | |
157 (pathname-device defaults) | |
158 (merge-pathname-directory-components directory (p… | |
159 (unspecific-handler defaults)))) | |
160 (make-pathname :host host :device device :directory directory | |
161 :name (funcall unspecific-handler name) | |
162 :type (funcall unspecific-handler type) | |
163 :version (funcall unspecific-handler version)))… | |
164 | |
165 (defun logical-pathname-p (x) | |
166 "is X a logical-pathname?" | |
167 (typep x 'logical-pathname)) | |
168 | |
169 (defun physical-pathname-p (x) | |
170 "is X a pathname that is not a logical-pathname?" | |
171 (and (pathnamep x) (not (logical-pathname-p x)))) | |
172 | |
173 (defun physicalize-pathname (x) | |
174 "if X is a logical pathname, use translate-logical-pathname on it." | |
175 ;; Ought to be the same as translate-logical-pathname, except the la… | |
176 (let ((p (when x (pathname x)))) | |
177 (if (logical-pathname-p p) (translate-logical-pathname p) p))) | |
178 | |
179 (defun nil-pathname (&optional (defaults *default-pathname-defaults*)) | |
180 "A pathname that is as neutral as possible for use as defaults | |
181 when merging, making or parsing pathnames" | |
182 ;; 19.2.2.2.1 says a NIL host can mean a default host; | |
183 ;; see also "valid physical pathname host" in the CLHS glossary, tha… | |
184 ;; strings and lists of strings or :unspecific | |
185 ;; But CMUCL decides to die on NIL. | |
186 ;; MCL has issues with make-pathname, nil and defaulting | |
187 (declare (ignorable defaults)) | |
188 #.`(make-pathname :directory nil :name nil :type nil :version nil | |
189 :device (or #+(and mkcl os-unix) :unspecific) | |
190 :host (or #+cmucl lisp::*unix-host* #+(and mkcl os… | |
191 #+scl ,@'(:scheme nil :scheme-specific-part nil | |
192 :username nil :password nil :parameters … | |
193 ;; the default shouldn't matter, but we really wan… | |
194 #-mcl ,@'(:defaults defaults))) | |
195 | |
196 (defvar *nil-pathname* (nil-pathname (physicalize-pathname (user-homed… | |
197 "A pathname that is as neutral as possible for use as defaults | |
198 when merging, making or parsing pathnames") | |
199 | |
200 (defmacro with-pathname-defaults ((&optional defaults) &body body) | |
201 "Execute BODY in a context where the *DEFAULT-PATHNAME-DEFAULTS* is … | |
202 where leaving the defaults NIL or unspecified means a (NIL-PATHNAME), ex… | |
203 on ABCL, Genera and XCL, where it remains unchanged for it doubles as cu… | |
204 `(let ((*default-pathname-defaults* | |
205 ,(or defaults | |
206 #-(or abcl genera xcl) '*nil-pathname* | |
207 #+(or abcl genera xcl) '*default-pathname-defaults*))) | |
208 ,@body))) | |
209 | |
210 | |
211 ;;; Some pathname predicates | |
212 (with-upgradability () | |
213 (defun pathname-equal (p1 p2) | |
214 "Are the two pathnames P1 and P2 reasonably equal in the paths they … | |
215 (when (stringp p1) (setf p1 (pathname p1))) | |
216 (when (stringp p2) (setf p2 (pathname p2))) | |
217 (flet ((normalize-component (x) | |
218 (unless (member x '(nil :unspecific :newest (:relative)) :t… | |
219 x))) | |
220 (macrolet ((=? (&rest accessors) | |
221 (flet ((frob (x) | |
222 (reduce 'list (cons 'normalize-component acc… | |
223 :initial-value x :from-end t))) | |
224 `(equal ,(frob 'p1) ,(frob 'p2))))) | |
225 (or (and (null p1) (null p2)) | |
226 (and (pathnamep p1) (pathnamep p2) | |
227 (and (=? pathname-host) | |
228 #-(and mkcl os-unix) (=? pathname-device) | |
229 (=? normalize-pathname-directory-component pathnam… | |
230 (=? pathname-name) | |
231 (=? pathname-type) | |
232 #-mkcl (=? pathname-version))))))) | |
233 | |
234 (defun absolute-pathname-p (pathspec) | |
235 "If PATHSPEC is a pathname or namestring object that parses as a pat… | |
236 possessing an :ABSOLUTE directory component, return the (parsed) pathnam… | |
237 Otherwise return NIL" | |
238 (and pathspec | |
239 (typep pathspec '(or null pathname string)) | |
240 (let ((pathname (pathname pathspec))) | |
241 (and (eq :absolute (car (normalize-pathname-directory-compone… | |
242 (pathname-directory pathname)))) | |
243 pathname)))) | |
244 | |
245 (defun relative-pathname-p (pathspec) | |
246 "If PATHSPEC is a pathname or namestring object that parses as a pat… | |
247 possessing a :RELATIVE or NIL directory component, return the (parsed) p… | |
248 Otherwise return NIL" | |
249 (and pathspec | |
250 (typep pathspec '(or null pathname string)) | |
251 (let* ((pathname (pathname pathspec)) | |
252 (directory (normalize-pathname-directory-component | |
253 (pathname-directory pathname)))) | |
254 (when (or (null directory) (eq :relative (car directory))) | |
255 pathname)))) | |
256 | |
257 (defun hidden-pathname-p (pathname) | |
258 "Return a boolean that is true if the pathname is hidden as per Unix… | |
259 i.e. its name starts with a dot." | |
260 (and pathname (equal (first-char (pathname-name pathname)) #\.))) | |
261 | |
262 (defun file-pathname-p (pathname) | |
263 "Does PATHNAME represent a file, i.e. has a non-null NAME component? | |
264 | |
265 Accepts NIL, a string (converted through PARSE-NAMESTRING) or a PATHNAME. | |
266 | |
267 Note that this does _not_ check to see that PATHNAME points to an | |
268 actually-existing file. | |
269 | |
270 Returns the (parsed) PATHNAME when true" | |
271 (when pathname | |
272 (let ((pathname (pathname pathname))) | |
273 (unless (and (member (pathname-name pathname) '(nil :unspecific … | |
274 (member (pathname-type pathname) '(nil :unspecific … | |
275 pathname))))) | |
276 | |
277 | |
278 ;;; Directory pathnames | |
279 (with-upgradability () | |
280 (defun pathname-directory-pathname (pathname) | |
281 "Returns a new pathname with same HOST, DEVICE, DIRECTORY as PATHNAM… | |
282 and NIL NAME, TYPE and VERSION components" | |
283 (when pathname | |
284 (make-pathname :name nil :type nil :version nil :defaults pathname… | |
285 | |
286 (defun pathname-parent-directory-pathname (pathname) | |
287 "Returns a new pathname that corresponds to the parent of the curren… | |
288 i.e. removing one level of depth in the DIRECTORY component. e.g. if pat… | |
289 Unix pathname /foo/bar/baz/file.type then return /foo/bar/" | |
290 (when pathname | |
291 (make-pathname :name nil :type nil :version nil | |
292 :directory (merge-pathname-directory-components | |
293 '(:relative :back) (pathname-directory … | |
294 :defaults pathname))) | |
295 | |
296 (defun directory-pathname-p (pathname) | |
297 "Does PATHNAME represent a directory? | |
298 | |
299 A directory-pathname is a pathname _without_ a filename. The three | |
300 ways that the filename components can be missing are for it to be NIL, | |
301 :UNSPECIFIC or the empty string. | |
302 | |
303 Note that this does _not_ check to see that PATHNAME points to an | |
304 actually-existing directory." | |
305 (when pathname | |
306 ;; I tried using Allegro's excl:file-directory-p, but this cannot … | |
307 ;; because it rejects apparently legal pathnames as | |
308 ;; ill-formed. [2014/02/10:rpg] | |
309 (let ((pathname (pathname pathname))) | |
310 (flet ((check-one (x) | |
311 (member x '(nil :unspecific) :test 'equal))) | |
312 (and (not (wild-pathname-p pathname)) | |
313 (check-one (pathname-name pathname)) | |
314 (check-one (pathname-type pathname)) | |
315 t))))) | |
316 | |
317 (defun ensure-directory-pathname (pathspec &optional (on-error 'error)) | |
318 "Converts the non-wild pathname designator PATHSPEC to directory for… | |
319 (cond | |
320 ((stringp pathspec) | |
321 (ensure-directory-pathname (pathname pathspec))) | |
322 ((not (pathnamep pathspec)) | |
323 (call-function on-error (compatfmt "~@<Invalid pathname designato… | |
324 ((wild-pathname-p pathspec) | |
325 (call-function on-error (compatfmt "~@<Can't reliably convert wil… | |
326 ((directory-pathname-p pathspec) | |
327 pathspec) | |
328 (t | |
329 (handler-case | |
330 (make-pathname :directory (append (or (normalize-pathname-dir… | |
331 (pathname-directory pa… | |
332 (list :relative)) | |
333 (list #-genera (file-namest… | |
334 ;; On Genera's native… | |
335 ;; directories have a… | |
336 ;; which must be igno… | |
337 ;; to a directory pat… | |
338 #+genera (if (typep p… | |
339 (pathnam… | |
340 (file-na… | |
341 :name nil :type nil :version nil :defaults pat… | |
342 (error (c) (call-function on-error (compatfmt "~@<error while t… | |
343 | |
344 | |
345 ;;; Parsing filenames | |
346 (with-upgradability () | |
347 (declaim (ftype function ensure-pathname)) ; forward reference | |
348 | |
349 (defun split-unix-namestring-directory-components | |
350 (unix-namestring &key ensure-directory dot-dot) | |
351 "Splits the path string UNIX-NAMESTRING, returning four values: | |
352 A flag that is either :absolute or :relative, indicating | |
353 how the rest of the values are to be interpreted. | |
354 A directory path --- a list of strings and keywords, suitable for | |
355 use with MAKE-PATHNAME when prepended with the flag value. | |
356 Directory components with an empty name or the name . are removed. | |
357 Any directory named .. is read as DOT-DOT, or :BACK if it's NIL (not … | |
358 A last-component, either a file-namestring including type extension, | |
359 or NIL in the case of a directory pathname. | |
360 A flag that is true iff the unix-style-pathname was just | |
361 a file-namestring without / path specification. | |
362 ENSURE-DIRECTORY forces the namestring to be interpreted as a directory … | |
363 the third return value will be NIL, and final component of the namestring | |
364 will be treated as part of the directory path. | |
365 | |
366 An empty string is thus read as meaning a pathname object with all field… | |
367 | |
368 Note that colon characters #\: will NOT be interpreted as host specifica… | |
369 Absolute pathnames are only appropriate on Unix-style systems. | |
370 | |
371 The intention of this function is to support structured component names, | |
372 e.g., \(:file \"foo/bar\"\), which will be unpacked to relative pathname… | |
373 (check-type unix-namestring string) | |
374 (check-type dot-dot (member nil :back :up)) | |
375 (if (and (not (find #\/ unix-namestring)) (not ensure-directory) | |
376 (plusp (length unix-namestring))) | |
377 (values :relative () unix-namestring t) | |
378 (let* ((components (split-string unix-namestring :separator "/")) | |
379 (last-comp (car (last components)))) | |
380 (multiple-value-bind (relative components) | |
381 (if (equal (first components) "") | |
382 (if (equal (first-char unix-namestring) #\/) | |
383 (values :absolute (cdr components)) | |
384 (values :relative nil)) | |
385 (values :relative components)) | |
386 (setf components (remove-if #'(lambda (x) (member x '("" "."… | |
387 components)) | |
388 (setf components (substitute (or dot-dot :back) ".." compone… | |
389 (cond | |
390 ((equal last-comp "") | |
391 (values relative components nil nil)) ; "" already remove… | |
392 (ensure-directory | |
393 (values relative components nil nil)) | |
394 (t | |
395 (values relative (butlast components) last-comp nil))))))) | |
396 | |
397 (defun split-name-type (filename) | |
398 "Split a filename into two values NAME and TYPE that are returned. | |
399 We assume filename has no directory component. | |
400 The last . if any separates name and type from from type, | |
401 except that if there is only one . and it is in first position, | |
402 the whole filename is the NAME with an empty type. | |
403 NAME is always a string. | |
404 For an empty type, *UNSPECIFIC-PATHNAME-TYPE* is returned." | |
405 (check-type filename string) | |
406 (assert (plusp (length filename))) | |
407 (destructuring-bind (name &optional (type *unspecific-pathname-type*… | |
408 (split-string filename :max 2 :separator ".") | |
409 (if (equal name "") | |
410 (values filename *unspecific-pathname-type*) | |
411 (values name type)))) | |
412 | |
413 (defun parse-unix-namestring (name &rest keys &key type defaults dot-d… | |
414 &allow-other-keys) | |
415 "Coerce NAME into a PATHNAME using standard Unix syntax. | |
416 | |
417 Unix syntax is used whether or not the underlying system is Unix; | |
418 on such non-Unix systems it is reliably usable only for relative pathnam… | |
419 This function is especially useful to manipulate relative pathnames port… | |
420 where it is of crucial to possess a portable pathname syntax independent… | |
421 This is what PARSE-UNIX-NAMESTRING provides, and why we use it in ASDF. | |
422 | |
423 When given a PATHNAME object, just return it untouched. | |
424 When given NIL, just return NIL. | |
425 When given a non-null SYMBOL, first downcase its name and treat it as a … | |
426 When given a STRING, portably decompose it into a pathname as below. | |
427 | |
428 #\\/ separates directory components. | |
429 | |
430 The last #\\/-separated substring is interpreted as follows: | |
431 1- If TYPE is :DIRECTORY or ENSURE-DIRECTORY is true, | |
432 the string is made the last directory component, and NAME and TYPE are … | |
433 if the string is empty, it's the empty pathname with all slots NIL. | |
434 2- If TYPE is NIL, the substring is a file-namestring, and its NAME and … | |
435 are separated by SPLIT-NAME-TYPE. | |
436 3- If TYPE is a string, it is the given TYPE, and the whole string is th… | |
437 | |
438 Directory components with an empty name or the name \".\" are removed. | |
439 Any directory named \"..\" is read as DOT-DOT, | |
440 which must be one of :BACK or :UP and defaults to :BACK. | |
441 | |
442 HOST, DEVICE and VERSION components are taken from DEFAULTS, | |
443 which itself defaults to *NIL-PATHNAME*, also used if DEFAULTS is NIL. | |
444 No host or device can be specified in the string itself, | |
445 which makes it unsuitable for absolute pathnames outside Unix. | |
446 | |
447 For relative pathnames, these components (and hence the defaults) won't … | |
448 if you use MERGE-PATHNAMES* but will matter if you use MERGE-PATHNAMES, | |
449 which is an important reason to always use MERGE-PATHNAMES*. | |
450 | |
451 Arbitrary keys are accepted, and the parse result is passed to ENSURE-PA… | |
452 with those keys, removing TYPE DEFAULTS and DOT-DOT. | |
453 When you're manipulating pathnames that are supposed to make sense porta… | |
454 even though the OS may not be Unixish, we recommend you use :WANT-RELATI… | |
455 to throw an error if the pathname is absolute" | |
456 (block nil | |
457 (check-type type (or null string (eql :directory))) | |
458 (when ensure-directory | |
459 (setf type :directory)) | |
460 (etypecase name | |
461 ((or null pathname) (return name)) | |
462 (symbol | |
463 (setf name (string-downcase name))) | |
464 (string)) | |
465 (multiple-value-bind (relative path filename file-only) | |
466 (split-unix-namestring-directory-components | |
467 name :dot-dot dot-dot :ensure-directory (eq type :directory)) | |
468 (multiple-value-bind (name type) | |
469 (cond | |
470 ((or (eq type :directory) (null filename)) | |
471 (values nil nil)) | |
472 (type | |
473 (values filename type)) | |
474 (t | |
475 (split-name-type filename))) | |
476 (apply 'ensure-pathname | |
477 (make-pathname | |
478 :directory (unless file-only (cons relative path)) | |
479 :name name :type type | |
480 :defaults (or #-mcl defaults *nil-pathname*)) | |
481 (remove-plist-keys '(:type :dot-dot :defaults) keys))))… | |
482 | |
483 (defun unix-namestring (pathname) | |
484 "Given a non-wild PATHNAME, return a Unix-style namestring for it. | |
485 If the PATHNAME is NIL or a STRING, return it unchanged. | |
486 | |
487 This only considers the DIRECTORY, NAME and TYPE components of the pathn… | |
488 This is a portable solution for representing relative pathnames, | |
489 But unless you are running on a Unix system, it is not a general solution | |
490 to representing native pathnames. | |
491 | |
492 An error is signaled if the argument is not NULL, a STRING or a PATHNAME, | |
493 or if it is a PATHNAME but some of its components are not recognized." | |
494 (etypecase pathname | |
495 ((or null string) pathname) | |
496 (pathname | |
497 (with-output-to-string (s) | |
498 (flet ((err () (parameter-error "~S: invalid unix-namestring ~S" | |
499 'unix-namestring pathname))) | |
500 (let* ((dir (normalize-pathname-directory-component (pathname… | |
501 (name (pathname-name pathname)) | |
502 (name (and (not (eq name :unspecific)) name)) | |
503 (type (pathname-type pathname)) | |
504 (type (and (not (eq type :unspecific)) type))) | |
505 (cond | |
506 ((member dir '(nil :unspecific))) | |
507 ((eq dir '(:relative)) (princ "./" s)) | |
508 ((consp dir) | |
509 (destructuring-bind (relabs &rest dirs) dir | |
510 (or (member relabs '(:relative :absolute)) (err)) | |
511 (when (eq relabs :absolute) (princ #\/ s)) | |
512 (loop :for x :in dirs :do | |
513 (cond | |
514 ((member x '(:back :up)) (princ "../" s)) | |
515 ((equal x "") (err)) | |
516 ;;((member x '("." "..") :test 'equal) (err)) | |
517 ((stringp x) (format s "~A/" x)) | |
518 (t (err)))))) | |
519 (t (err))) | |
520 (cond | |
521 (name | |
522 (unless (and (stringp name) (or (null type) (stringp typ… | |
523 (format s "~A~@[.~A~]" name type)) | |
524 (t | |
525 (or (null type) (err))))))))))) | |
526 | |
527 ;;; Absolute and relative pathnames | |
528 (with-upgradability () | |
529 (defun subpathname (pathname subpath &key type) | |
530 "This function takes a PATHNAME and a SUBPATH and a TYPE. | |
531 If SUBPATH is already a PATHNAME object (not namestring), | |
532 and is an absolute pathname at that, it is returned unchanged; | |
533 otherwise, SUBPATH is turned into a relative pathname with given TYPE | |
534 as per PARSE-UNIX-NAMESTRING with :WANT-RELATIVE T :TYPE TYPE, | |
535 then it is merged with the PATHNAME-DIRECTORY-PATHNAME of PATHNAME." | |
536 (or (and (pathnamep subpath) (absolute-pathname-p subpath)) | |
537 (merge-pathnames* (parse-unix-namestring subpath :type type :wan… | |
538 (pathname-directory-pathname pathname)))) | |
539 | |
540 (defun subpathname* (pathname subpath &key type) | |
541 "returns NIL if the base pathname is NIL, otherwise like SUBPATHNAME… | |
542 (and pathname | |
543 (subpathname (ensure-directory-pathname pathname) subpath :type… | |
544 | |
545 (defun pathname-root (pathname) | |
546 "return the root directory for the host and device of given PATHNAME" | |
547 (make-pathname :directory '(:absolute) | |
548 :name nil :type nil :version nil | |
549 :defaults pathname ;; host device, and on scl, *some* | |
550 ;; scheme-specific parts: port username password, not… | |
551 . #.(or #+scl '(:parameters nil :query nil :fragment … | |
552 | |
553 (defun pathname-host-pathname (pathname) | |
554 "return a pathname with the same host as given PATHNAME, and all oth… | |
555 (make-pathname :directory nil | |
556 :name nil :type nil :version nil :device nil | |
557 :defaults pathname ;; host device, and on scl, *some* | |
558 ;; scheme-specific parts: port username password, not… | |
559 . #.(or #+scl '(:parameters nil :query nil :fragment … | |
560 | |
561 (defun ensure-absolute-pathname (path &optional defaults (on-error 'er… | |
562 "Given a pathname designator PATH, return an absolute pathname as sp… | |
563 considering the DEFAULTS, or, if not possible, use CALL-FUNCTION on the … | |
564 with a format control-string and other arguments as arguments" | |
565 (cond | |
566 ((absolute-pathname-p path)) | |
567 ((stringp path) (ensure-absolute-pathname (pathname path) defaults… | |
568 ((not (pathnamep path)) (call-function on-error "not a valid pathn… | |
569 ((let ((default-pathname (if (pathnamep defaults) defaults (call-f… | |
570 (or (if (absolute-pathname-p default-pathname) | |
571 (absolute-pathname-p (merge-pathnames* path default-pat… | |
572 (call-function on-error "Default pathname ~S is not an … | |
573 default-pathname)) | |
574 (call-function on-error "Failed to merge ~S with ~S into an… | |
575 path default-pathname)))) | |
576 (t (call-function on-error | |
577 "Cannot ensure ~S is evaluated as an absolute pa… | |
578 path defaults)))) | |
579 | |
580 (defun subpathp (maybe-subpath base-pathname) | |
581 "if MAYBE-SUBPATH is a pathname that is under BASE-PATHNAME, return … | |
582 when used with MERGE-PATHNAMES* with defaults BASE-PATHNAME, returns MAY… | |
583 (and (pathnamep maybe-subpath) (pathnamep base-pathname) | |
584 (absolute-pathname-p maybe-subpath) (absolute-pathname-p base-p… | |
585 (directory-pathname-p base-pathname) (not (wild-pathname-p base… | |
586 (pathname-equal (pathname-root maybe-subpath) (pathname-root ba… | |
587 (with-pathname-defaults (*nil-pathname*) | |
588 (let ((enough (enough-namestring maybe-subpath base-pathname)… | |
589 (and (relative-pathname-p enough) (pathname enough)))))) | |
590 | |
591 (defun enough-pathname (maybe-subpath base-pathname) | |
592 "if MAYBE-SUBPATH is a pathname that is under BASE-PATHNAME, return … | |
593 when used with MERGE-PATHNAMES* with defaults BASE-PATHNAME, returns MAY… | |
594 (let ((sub (when maybe-subpath (pathname maybe-subpath))) | |
595 (base (when base-pathname (ensure-absolute-pathname (pathname … | |
596 (or (and base (subpathp sub base)) sub))) | |
597 | |
598 (defun call-with-enough-pathname (maybe-subpath defaults-pathname thun… | |
599 "In a context where *DEFAULT-PATHNAME-DEFAULTS* is bound to DEFAULTS… | |
600 or else to its current value), call THUNK with ENOUGH-PATHNAME for MAYBE… | |
601 given DEFAULTS-PATHNAME as a base pathname." | |
602 (let ((enough (enough-pathname maybe-subpath defaults-pathname)) | |
603 (*default-pathname-defaults* (or defaults-pathname *default-pa… | |
604 (funcall thunk enough))) | |
605 | |
606 (defmacro with-enough-pathname ((pathname-var &key (pathname pathname-… | |
607 (defaults *default-pat… | |
608 &body body) | |
609 "Shorthand syntax for CALL-WITH-ENOUGH-PATHNAME" | |
610 `(call-with-enough-pathname ,pathname ,defaults #'(lambda (,pathname… | |
611 | |
612 | |
613 ;;; Wildcard pathnames | |
614 (with-upgradability () | |
615 (defparameter *wild* (or #+cormanlisp "*" :wild) | |
616 "Wild component for use with MAKE-PATHNAME") | |
617 (defparameter *wild-directory-component* (or :wild) | |
618 "Wild directory component for use with MAKE-PATHNAME") | |
619 (defparameter *wild-inferiors-component* (or :wild-inferiors) | |
620 "Wild-inferiors directory component for use with MAKE-PATHNAME") | |
621 (defparameter *wild-file* | |
622 (make-pathname :directory nil :name *wild* :type *wild* | |
623 :version (or #-(or allegro abcl xcl) *wild*)) | |
624 "A pathname object with wildcards for matching any file with TRANSLA… | |
625 (defparameter *wild-file-for-directory* | |
626 (make-pathname :directory nil :name *wild* :type (or #-(or clisp gcl… | |
627 :version (or #-(or allegro abcl clisp gcl xcl) *wild*… | |
628 "A pathname object with wildcards for matching any file with DIRECTO… | |
629 (defparameter *wild-directory* | |
630 (make-pathname :directory `(:relative ,*wild-directory-component*) | |
631 :name nil :type nil :version nil) | |
632 "A pathname object with wildcards for matching any subdirectory") | |
633 (defparameter *wild-inferiors* | |
634 (make-pathname :directory `(:relative ,*wild-inferiors-component*) | |
635 :name nil :type nil :version nil) | |
636 "A pathname object with wildcards for matching any recursive subdire… | |
637 (defparameter *wild-path* | |
638 (merge-pathnames* *wild-file* *wild-inferiors*) | |
639 "A pathname object with wildcards for matching any file in any recur… | |
640 | |
641 (defun wilden (path) | |
642 "From a pathname, return a wildcard pathname matching any file in an… | |
643 (merge-pathnames* *wild-path* path))) | |
644 | |
645 | |
646 ;;; Translate a pathname | |
647 (with-upgradability () | |
648 (defun relativize-directory-component (directory-component) | |
649 "Given the DIRECTORY-COMPONENT of a pathname, return an otherwise si… | |
650 (let ((directory (normalize-pathname-directory-component directory-c… | |
651 (cond | |
652 ((stringp directory) | |
653 (list :relative directory)) | |
654 ((eq (car directory) :absolute) | |
655 (cons :relative (cdr directory))) | |
656 (t | |
657 directory)))) | |
658 | |
659 (defun relativize-pathname-directory (pathspec) | |
660 "Given a PATHNAME, return a relative pathname with otherwise the sam… | |
661 (let ((p (pathname pathspec))) | |
662 (make-pathname | |
663 :directory (relativize-directory-component (pathname-directory p)) | |
664 :defaults p))) | |
665 | |
666 (defun directory-separator-for-host (&optional (pathname *default-path… | |
667 "Given a PATHNAME, return the character used to delimit directory na… | |
668 (let ((foo (make-pathname :directory '(:absolute "FOO") :defaults pa… | |
669 (last-char (namestring foo)))) | |
670 | |
671 #-scl | |
672 (defun directorize-pathname-host-device (pathname) | |
673 "Given a PATHNAME, return a pathname that has representations of its… | |
674 added to its DIRECTORY component. This is useful for output translations… | |
675 (os-cond | |
676 ((os-unix-p) | |
677 (when (physical-pathname-p pathname) | |
678 (return-from directorize-pathname-host-device pathname)))) | |
679 (let* ((root (pathname-root pathname)) | |
680 (wild-root (wilden root)) | |
681 (absolute-pathname (merge-pathnames* pathname root)) | |
682 (separator (directory-separator-for-host root)) | |
683 (root-namestring (namestring root)) | |
684 (root-string | |
685 (substitute-if #\/ | |
686 #'(lambda (x) (or (eql x #\:) | |
687 (eql x separator))) | |
688 root-namestring))) | |
689 (multiple-value-bind (relative path filename) | |
690 (split-unix-namestring-directory-components root-string :ensur… | |
691 (declare (ignore relative filename)) | |
692 (let ((new-base (make-pathname :defaults root :directory `(:abso… | |
693 (translate-pathname absolute-pathname wild-root (wilden new-ba… | |
694 | |
695 #+scl | |
696 (defun directorize-pathname-host-device (pathname) | |
697 (let ((scheme (ext:pathname-scheme pathname)) | |
698 (host (pathname-host pathname)) | |
699 (port (ext:pathname-port pathname)) | |
700 (directory (pathname-directory pathname))) | |
701 (flet ((specificp (x) (and x (not (eq x :unspecific))))) | |
702 (if (or (specificp port) | |
703 (and (specificp host) (plusp (length host))) | |
704 (specificp scheme)) | |
705 (let ((prefix "")) | |
706 (when (specificp port) | |
707 (setf prefix (format nil ":~D" port))) | |
708 (when (and (specificp host) (plusp (length host))) | |
709 (setf prefix (strcat host prefix))) | |
710 (setf prefix (strcat ":" prefix)) | |
711 (when (specificp scheme) | |
712 (setf prefix (strcat scheme prefix))) | |
713 (assert (and directory (eq (first directory) :absolute))) | |
714 (make-pathname :directory `(:absolute ,prefix ,@(rest dire… | |
715 :defaults pathname))) | |
716 pathname))) | |
717 | |
718 (defun* (translate-pathname*) (path absolute-source destination &optio… | |
719 "A wrapper around TRANSLATE-PATHNAME to be used by the ASDF output-t… | |
720 PATH is the pathname to be translated. | |
721 ABSOLUTE-SOURCE is an absolute pathname to use as source for translate-p… | |
722 DESTINATION is either a function, to be called with PATH and ABSOLUTE-SO… | |
723 or a relative pathname, to be merged with ROOT and used as destination f… | |
724 or an absolute pathname, to be used as destination for translate-pathnam… | |
725 In that last case, if ROOT is non-NIL, PATH is first transformated by DI… | |
726 (declare (ignore source)) | |
727 (cond | |
728 ((functionp destination) | |
729 (funcall destination path absolute-source)) | |
730 ((eq destination t) | |
731 path) | |
732 ((not (pathnamep destination)) | |
733 (parameter-error "~S: Invalid destination" 'translate-pathname*)) | |
734 ((not (absolute-pathname-p destination)) | |
735 (translate-pathname path absolute-source (merge-pathnames* destin… | |
736 (root | |
737 (translate-pathname (directorize-pathname-host-device path) absol… | |
738 (t | |
739 (translate-pathname path absolute-source destination)))) | |
740 | |
741 (defvar *output-translation-function* 'identity | |
742 "Hook for output translations. | |
743 | |
744 This function needs to be idempotent, so that actions can work | |
745 whether their inputs were translated or not, | |
746 which they will be if we are composing operations. e.g. if some | |
747 create-lisp-op creates a lisp file from some higher-level input, | |
748 you need to still be able to use compile-op on that lisp file.")) |