1 ;;;; machine/filesystem-independent pathname functions
3 ;;;; This software is part of the SBCL system. See the README file for
6 ;;;; This software is derived from the CMU CL system, which was
7 ;;;; written at Carnegie Mellon University and released into the
8 ;;;; public domain. The software is in the public domain and is
9 ;;;; provided with absolutely no warranty. See the COPYING and CREDITS
10 ;;;; files for more information.
12 (in-package "SB!IMPL")
14 #!-sb-fluid
(declaim (freeze-type logical-pathname logical-host
))
16 ;;; To be initialized in unix/win32-pathname.lisp
17 (defvar *physical-host
*)
19 ;;; Return a value suitable, e.g., for preinitializing
20 ;;; *DEFAULT-PATHNAME-DEFAULTS* before *DEFAULT-PATHNAME-DEFAULTS* is
21 ;;; initialized (at which time we can't safely call e.g. #'PATHNAME).
22 (defun make-trivial-default-pathname ()
23 (%make-pathname
*physical-host
* nil nil nil nil
:newest
))
27 (defmethod print-object ((pathname pathname
) stream
)
28 (let ((namestring (handler-case (namestring pathname
)
32 (if (or *print-readably
* *print-escape
*)
35 (coerce namestring
'(simple-array character
(*))))
36 (print-unreadable-object (pathname stream
:type t
)
38 "~@<(with no namestring) ~_:HOST ~S ~_:DEVICE ~S ~_:DIRECTORY ~S ~
39 ~_:NAME ~S ~_:TYPE ~S ~_:VERSION ~S~:>"
40 (%pathname-host pathname
)
41 (%pathname-device pathname
)
42 (%pathname-directory pathname
)
43 (%pathname-name pathname
)
44 (%pathname-type pathname
)
45 (%pathname-version pathname
))))))
47 (defmethod make-load-form ((pathname pathname
) &optional environment
)
48 (make-load-form-saving-slots pathname
:environment environment
))
50 ;;; A pathname is logical if the host component is a logical host.
51 ;;; This constructor is used to make an instance of the correct type
52 ;;; from parsed arguments.
53 (defun %make-maybe-logical-pathname
(host device directory name type version
)
54 ;; We canonicalize logical pathname components to uppercase. ANSI
55 ;; doesn't strictly require this, leaving it up to the implementor;
56 ;; but the arguments given in the X3J13 cleanup issue
57 ;; PATHNAME-LOGICAL:ADD seem compelling: we should canonicalize the
58 ;; case, and uppercase is the ordinary way to do that.
59 (flet ((upcase-maybe (x) (typecase x
(string (logical-word-or-lose x
)) (t x
))))
60 (if (typep host
'logical-host
)
61 (%make-logical-pathname host
63 (mapcar #'upcase-maybe directory
)
68 (aver (eq host
*physical-host
*))
69 (%make-pathname host device directory name type version
)))))
71 ;;; Hash table searching maps a logical pathname's host to its
72 ;;; physical pathname translation.
73 (defvar *logical-hosts
* (make-hash-table :test
'equal
:synchronized t
))
77 (defmethod make-load-form ((pattern pattern
) &optional environment
)
78 (make-load-form-saving-slots pattern
:environment environment
))
80 (defmethod print-object ((pattern pattern
) stream
)
81 (print-unreadable-object (pattern stream
:type t
)
83 (let ((*print-escape
* t
))
84 (pprint-fill stream
(pattern-pieces pattern
) nil
))
85 (prin1 (pattern-pieces pattern
) stream
))))
87 (defun pattern= (pattern1 pattern2
)
88 (declare (type pattern pattern1 pattern2
))
89 (let ((pieces1 (pattern-pieces pattern1
))
90 (pieces2 (pattern-pieces pattern2
)))
91 (and (= (length pieces1
) (length pieces2
))
92 (every (lambda (piece1 piece2
)
95 (and (simple-string-p piece2
)
96 (string= piece1 piece2
)))
99 (eq (car piece1
) (car piece2
))
100 (string= (cdr piece1
) (cdr piece2
))))
102 (eq piece1 piece2
))))
106 ;;; If the string matches the pattern returns the multiple values T
107 ;;; and a list of the matched strings.
108 (defun pattern-matches (pattern string
)
109 (declare (type pattern pattern
)
110 (type simple-string string
))
111 (let ((len (length string
)))
112 (labels ((maybe-prepend (subs cur-sub chars
)
114 (let* ((len (length chars
))
115 (new (make-string len
))
118 (setf (schar new
(decf index
)) char
))
121 (matches (pieces start subs cur-sub chars
)
124 (values t
(maybe-prepend subs cur-sub chars
))
126 (let ((piece (car pieces
)))
129 (let ((end (+ start
(length piece
))))
131 (string= piece string
132 :start2 start
:end2 end
)
133 (matches (cdr pieces
) end
134 (maybe-prepend subs cur-sub chars
)
140 (let ((char (schar string start
)))
141 (if (find char
(cdr piece
) :test
#'char
=)
142 (matches (cdr pieces
) (1+ start
) subs t
143 (cons char chars
))))))))
144 ((member :single-char-wild
)
146 (matches (cdr pieces
) (1+ start
) subs t
147 (cons (schar string start
) chars
))))
148 ((member :multi-char-wild
)
149 (multiple-value-bind (won new-subs
)
150 (matches (cdr pieces
) start subs t chars
)
154 (matches pieces
(1+ start
) subs t
155 (cons (schar string start
)
157 (multiple-value-bind (won subs
)
158 (matches (pattern-pieces pattern
) 0 nil nil nil
)
159 (values won
(reverse subs
))))))
161 ;;; PATHNAME-MATCH-P for directory components
162 (defun directory-components-match (thing wild
)
165 ;; If THING has a null directory, assume that it matches
166 ;; (:ABSOLUTE :WILD-INFERIORS) or (:RELATIVE :WILD-INFERIORS).
169 (member (first wild
) '(:absolute
:relative
))
170 (eq (second wild
) :wild-inferiors
))
172 (let ((wild1 (first wild
)))
173 (if (eq wild1
:wild-inferiors
)
174 (let ((wild-subdirs (rest wild
)))
175 (or (null wild-subdirs
)
177 (when (directory-components-match thing wild-subdirs
)
180 (unless thing
(return nil
)))))
182 (components-match (first thing
) wild1
)
183 (directory-components-match (rest thing
)
186 ;;; Return true if pathname component THING is matched by WILD. (not
188 (defun components-match (thing wild
)
189 (declare (type (or pattern symbol simple-string integer
) thing wild
))
194 ;; String is matched by itself, a matching pattern or :WILD.
197 (values (pattern-matches wild thing
)))
199 (string= thing wild
))))
201 ;; A pattern is only matched by an identical pattern.
202 (and (pattern-p wild
) (pattern= thing wild
)))
204 ;; An integer (version number) is matched by :WILD or the
205 ;; same integer. This branch will actually always be NIL as
206 ;; long as the version is a fixnum.
209 ;;; a predicate for comparing two pathname slot component sub-entries
210 (defun compare-component (this that
)
214 (and (simple-string-p that
)
215 (string= this that
)))
217 (and (pattern-p that
)
218 (pattern= this that
)))
221 (compare-component (car this
) (car that
))
222 (compare-component (cdr this
) (cdr that
)))))))
224 ;;;; pathname functions
226 (defun pathname= (pathname1 pathname2
)
227 (declare (type pathname pathname1
)
228 (type pathname pathname2
))
229 (or (eq pathname1 pathname2
)
230 (and (eq (%pathname-host pathname1
)
231 (%pathname-host pathname2
))
232 (compare-component (%pathname-device pathname1
)
233 (%pathname-device pathname2
))
234 (compare-component (%pathname-directory pathname1
)
235 (%pathname-directory pathname2
))
236 (compare-component (%pathname-name pathname1
)
237 (%pathname-name pathname2
))
238 (compare-component (%pathname-type pathname1
)
239 (%pathname-type pathname2
))
240 (or (eq (%pathname-host pathname1
) *physical-host
*)
241 (compare-component (%pathname-version pathname1
)
242 (%pathname-version pathname2
))))))
244 ;;; Convert PATHNAME-DESIGNATOR (a pathname, or string, or
245 ;;; stream), into a pathname in pathname.
247 ;;; FIXME: was rewritten, should be tested (or rewritten again, this
248 ;;; time using ONCE-ONLY, *then* tested)
249 (eval-when (:compile-toplevel
:execute
)
250 (sb!xc
:defmacro with-pathname
((pathname pathname-designator
) &body body
)
251 (let ((pd0 (gensym)))
252 `(let* ((,pd0
,pathname-designator
)
253 (,pathname
(etypecase ,pd0
255 (string (parse-namestring ,pd0
))
256 (file-stream (file-name ,pd0
)))))
259 (sb!xc
:defmacro with-native-pathname
((pathname pathname-designator
) &body body
)
260 (let ((pd0 (gensym)))
261 `(let* ((,pd0
,pathname-designator
)
262 (,pathname
(etypecase ,pd0
264 (string (parse-native-namestring ,pd0
))
267 (file-stream (file-name ,pd0
)))))
270 (sb!xc
:defmacro with-host
((host host-designator
) &body body
)
271 ;; Generally, redundant specification of information in software,
272 ;; whether in code or in comments, is bad. However, the ANSI spec
273 ;; for this is messy enough that it's hard to hold in short-term
274 ;; memory, so I've recorded these redundant notes on the
275 ;; implications of the ANSI spec.
277 ;; According to the ANSI spec, HOST can be a valid pathname host, or
278 ;; a logical host, or NIL.
280 ;; A valid pathname host can be a valid physical pathname host or a
281 ;; valid logical pathname host.
283 ;; A valid physical pathname host is "any of a string, a list of
284 ;; strings, or the symbol :UNSPECIFIC, that is recognized by the
285 ;; implementation as the name of a host". In SBCL as of 0.6.9.8,
286 ;; that means :UNSPECIFIC: though someday we might want to
287 ;; generalize it to allow strings like "RTFM.MIT.EDU" or lists like
288 ;; '("RTFM" "MIT" "EDU"), that's not supported now.
290 ;; A valid logical pathname host is a string which has been defined as
291 ;; the name of a logical host, as with LOAD-LOGICAL-PATHNAME-TRANSLATIONS.
293 ;; A logical host is an object of implementation-dependent nature. In
294 ;; SBCL, it's a member of the HOST class (a subclass of STRUCTURE-OBJECT).
295 (let ((hd0 (gensym)))
296 `(let* ((,hd0
,host-designator
)
297 (,host
(etypecase ,hd0
299 ;; This is a special host. It's not valid as a
300 ;; logical host, so it is a sensible thing to
301 ;; designate the physical host object. So we do
305 ;; In general ANSI-compliant Common Lisps, a
306 ;; string might also be a physical pathname
307 ;; host, but ANSI leaves this up to the
308 ;; implementor, and in SBCL we don't do it, so
309 ;; it must be a logical host.
310 (find-logical-host ,hd0
))
311 ((or null
(member :unspecific
))
312 ;; CLHS says that HOST=:UNSPECIFIC has
313 ;; implementation-defined behavior. We
314 ;; just turn it into NIL.
317 ;; ANSI also allows LISTs to designate hosts,
318 ;; but leaves its interpretation
319 ;; implementation-defined. Our interpretation
320 ;; is that it's unsupported.:-|
321 (error "A LIST representing a pathname host is not ~
322 supported in this implementation:~% ~S"
328 (defun find-host (host-designator &optional
(errorp t
))
329 (with-host (host host-designator
)
330 (when (and errorp
(not host
))
331 (error "Couldn't find host: ~S" host-designator
))
334 (defun pathname (pathspec)
336 "Convert PATHSPEC (a pathname designator) into a pathname."
337 (declare (type pathname-designator pathspec
))
338 (with-pathname (pathname pathspec
)
341 (defun native-pathname (pathspec)
343 "Convert PATHSPEC (a pathname designator) into a pathname, assuming
344 the operating system native pathname conventions."
345 (with-native-pathname (pathname pathspec
)
348 ;;; Change the case of thing if DIDDLE-P.
349 (defun maybe-diddle-case (thing diddle-p
)
350 (if (and diddle-p
(not (or (symbolp thing
) (integerp thing
))))
351 (labels ((check-for (pred in
)
354 (dolist (piece (pattern-pieces in
))
355 (when (typecase piece
357 (check-for pred piece
))
361 (check-for pred
(cdr piece
))))))
365 (when (check-for pred x
)
368 (dotimes (i (length in
))
369 (when (funcall pred
(schar in i
))
372 (diddle-with (fun thing
)
376 (mapcar (lambda (piece)
384 (funcall fun
(cdr piece
))))
389 (pattern-pieces thing
))))
396 (let ((any-uppers (check-for #'upper-case-p thing
))
397 (any-lowers (check-for #'lower-case-p thing
)))
398 (cond ((and any-uppers any-lowers
)
399 ;; mixed case, stays the same
402 ;; all uppercase, becomes all lower case
403 (diddle-with (lambda (x) (if (stringp x
)
407 ;; all lowercase, becomes all upper case
408 (diddle-with (lambda (x) (if (stringp x
)
412 ;; no letters? I guess just leave it.
416 (defun merge-directories (dir1 dir2 diddle-case
)
417 (if (or (eq (car dir1
) :absolute
)
422 (if (and (eq dir
:back
)
424 (typep (car results
) '(or string pattern
425 (member :wild
:wild-inferiors
))))
427 (push dir results
))))
428 (dolist (dir (maybe-diddle-case dir2 diddle-case
))
430 (dolist (dir (cdr dir1
))
434 (defun merge-pathnames (pathname
436 (defaults *default-pathname-defaults
*)
437 (default-version :newest
))
439 "Construct a filled in pathname by completing the unspecified components
441 (declare (type pathname-designator pathname
)
442 (type pathname-designator defaults
)
444 (with-pathname (defaults defaults
)
445 (let ((pathname (let ((*default-pathname-defaults
* defaults
))
446 (pathname pathname
))))
447 (let* ((default-host (%pathname-host defaults
))
448 (pathname-host (%pathname-host pathname
))
450 (and default-host pathname-host
451 (not (eq (host-customary-case default-host
)
452 (host-customary-case pathname-host
)))))
453 (directory (merge-directories (%pathname-directory pathname
)
454 (%pathname-directory defaults
)
456 (%make-maybe-logical-pathname
457 (or pathname-host default-host
)
458 (and ;; The device of ~/ shouldn't be merged,
459 ;; because the expansion may have a different device
460 (not (and (>= (length directory
) 2)
461 (eql (car directory
) :absolute
)
462 (eql (cadr directory
) :home
)))
463 (or (%pathname-device pathname
)
464 (maybe-diddle-case (%pathname-device defaults
)
467 (or (%pathname-name pathname
)
468 (maybe-diddle-case (%pathname-name defaults
)
470 (or (%pathname-type pathname
)
471 (maybe-diddle-case (%pathname-type defaults
)
473 (or (%pathname-version pathname
)
474 (and (not (%pathname-name pathname
)) (%pathname-version defaults
))
475 default-version
))))))
477 (defun import-directory (directory diddle-case
)
480 ((member :wild
) '(:absolute
:wild-inferiors
))
481 ((member :unspecific
) '(:relative
))
483 (let ((root (pop directory
))
485 (if (member root
'(:relative
:absolute
))
487 (error "List of directory components must start with ~S or ~S."
488 :absolute
:relative
))
490 (let ((next (car directory
)))
491 (when (or (eq :home next
)
492 (typep next
'(cons (eql :home
) (cons string null
))))
493 (push (pop directory
) results
)))
494 (dolist (piece directory
)
496 ((member :wild
:wild-inferiors
:up
)
497 (push piece results
))
499 (if (typep (car results
) '(or string pattern
500 (member :wild
:wild-inferiors
)))
502 (push piece results
)))
503 ((or simple-string pattern
)
504 (push (maybe-diddle-case piece diddle-case
) results
))
506 (push (maybe-diddle-case (coerce piece
'simple-string
)
507 diddle-case
) results
))
510 (error "~S is not allowed as a directory component." piece
)))))
513 `(:absolute
,(maybe-diddle-case directory diddle-case
)))
516 ,(maybe-diddle-case (coerce directory
'simple-string
) diddle-case
)))))
518 (defun make-pathname (&key host
523 (version nil versionp
)
527 "Makes a new pathname from the component arguments. Note that host is
528 a host-structure or string."
529 (declare (type (or string host pathname-component-tokens
) host
)
530 (type (or string pathname-component-tokens
) device
)
531 (type (or list string pattern pathname-component-tokens
) directory
)
532 (type (or string pattern pathname-component-tokens
) name type
)
533 (type (or integer pathname-component-tokens
(member :newest
))
535 (type (or pathname-designator null
) defaults
)
536 (type (member :common
:local
) case
))
537 (let* ((defaults (when defaults
538 (with-pathname (defaults defaults
) defaults
)))
539 (default-host (if defaults
540 (%pathname-host defaults
)
541 (pathname-host *default-pathname-defaults
*)))
542 ;; Raymond Toy writes: CLHS says make-pathname can take a
543 ;; string (as a logical-host) for the host part. We map that
544 ;; string into the corresponding logical host structure.
546 ;; Paul Werkowski writes:
547 ;; HyperSpec says for the arg to MAKE-PATHNAME;
548 ;; "host---a valid physical pathname host. ..."
549 ;; where it probably means -- a valid pathname host.
550 ;; "valid pathname host n. a valid physical pathname host or
551 ;; a valid logical pathname host."
553 ;; "valid physical pathname host n. any of a string,
554 ;; a list of strings, or the symbol :unspecific,
555 ;; that is recognized by the implementation as the name of a host."
556 ;; "valid logical pathname host n. a string that has been defined
557 ;; as the name of a logical host. ..."
558 ;; HS is silent on what happens if the :HOST arg is NOT one of these.
559 ;; It seems an error message is appropriate.
560 (host (or (find-host host nil
) default-host
))
561 (diddle-args (and (eq (host-customary-case host
) :lower
)
564 (not (eq (host-customary-case host
)
565 (host-customary-case default-host
))))
566 (dev (if devp device
(if defaults
(%pathname-device defaults
))))
567 (dir (import-directory directory diddle-args
))
570 (defaults (%pathname-version defaults
))
572 (when (and defaults
(not dirp
))
574 (merge-directories dir
575 (%pathname-directory defaults
)
578 (macrolet ((pick (var varp field
)
579 `(cond ((or (simple-string-p ,var
)
581 (maybe-diddle-case ,var diddle-args
))
583 (maybe-diddle-case (coerce ,var
'simple-string
)
586 (maybe-diddle-case ,var diddle-args
))
588 (maybe-diddle-case (,field defaults
)
592 (%make-maybe-logical-pathname host
593 dev
; forced to :UNSPECIFIC when logical
595 (pick name namep %pathname-name
)
596 (pick type typep %pathname-type
)
599 (defun pathname-host (pathname &key
(case :local
))
601 "Return PATHNAME's host."
602 (declare (type pathname-designator pathname
)
603 (type (member :local
:common
) case
)
606 (with-pathname (pathname pathname
)
607 (%pathname-host pathname
)))
609 (defun pathname-device (pathname &key
(case :local
))
611 "Return PATHNAME's device."
612 (declare (type pathname-designator pathname
)
613 (type (member :local
:common
) case
))
614 (with-pathname (pathname pathname
)
615 (maybe-diddle-case (%pathname-device pathname
)
616 (and (eq case
:common
)
617 (eq (host-customary-case
618 (%pathname-host pathname
))
621 (defun pathname-directory (pathname &key
(case :local
))
623 "Return PATHNAME's directory."
624 (declare (type pathname-designator pathname
)
625 (type (member :local
:common
) case
))
626 (with-pathname (pathname pathname
)
627 (maybe-diddle-case (%pathname-directory pathname
)
628 (and (eq case
:common
)
629 (eq (host-customary-case
630 (%pathname-host pathname
))
632 (defun pathname-name (pathname &key
(case :local
))
634 "Return PATHNAME's name."
635 (declare (type pathname-designator pathname
)
636 (type (member :local
:common
) case
))
637 (with-pathname (pathname pathname
)
638 (maybe-diddle-case (%pathname-name pathname
)
639 (and (eq case
:common
)
640 (eq (host-customary-case
641 (%pathname-host pathname
))
644 (defun pathname-type (pathname &key
(case :local
))
646 "Return PATHNAME's type."
647 (declare (type pathname-designator pathname
)
648 (type (member :local
:common
) case
))
649 (with-pathname (pathname pathname
)
650 (maybe-diddle-case (%pathname-type pathname
)
651 (and (eq case
:common
)
652 (eq (host-customary-case
653 (%pathname-host pathname
))
656 (defun pathname-version (pathname)
658 "Return PATHNAME's version."
659 (declare (type pathname-designator pathname
))
660 (with-pathname (pathname pathname
)
661 (%pathname-version pathname
)))
665 ;;; Handle the case for PARSE-NAMESTRING parsing a potentially
666 ;;; syntactically valid logical namestring with an explicit host.
668 ;;; This then isn't fully general -- we are relying on the fact that
669 ;;; we will only pass to parse-namestring namestring with an explicit
670 ;;; logical host, so that we can pass the host return from
671 ;;; parse-logical-namestring through to %PARSE-NAMESTRING as a truth
672 ;;; value. Yeah, this is probably a KLUDGE - CSR, 2002-04-18
673 (defun parseable-logical-namestring-p (namestr start end
)
676 ((namestring-parse-error (lambda (c)
679 (let ((colon (position #\
: namestr
:start start
:end end
)))
681 (let ((potential-host
682 (logical-word-or-lose (subseq namestr start colon
))))
683 ;; depending on the outcome of CSR comp.lang.lisp post
684 ;; "can PARSE-NAMESTRING create logical hosts", we may need
685 ;; to do things with potential-host (create it
686 ;; temporarily, parse the namestring and unintern the
687 ;; logical host potential-host on failure.
688 (declare (ignore potential-host
))
691 ((simple-type-error (lambda (c)
694 (parse-logical-namestring namestr start end
))))
695 ;; if we got this far, we should have an explicit host
696 ;; (first return value of parse-logical-namestring)
700 ;;; Handle the case where PARSE-NAMESTRING is actually parsing a
701 ;;; namestring. We pick off the :JUNK-ALLOWED case then find a host to
702 ;;; use for parsing, call the parser, then check whether the host matches.
703 (defun %parse-namestring
(namestr host defaults start end junk-allowed
)
704 (declare (type (or host null
) host
)
705 (type string namestr
)
707 (type (or index null
) end
))
711 (%parse-namestring namestr host defaults start end nil
)
712 (namestring-parse-error (condition)
713 (values nil
(namestring-parse-error-offset condition
)))))
715 (let* ((end (%check-vector-sequence-bounds namestr start end
)))
716 (multiple-value-bind (new-host device directory file type version
)
717 ;; Comments below are quotes from the HyperSpec
718 ;; PARSE-NAMESTRING entry, reproduced here to demonstrate
719 ;; that we actually have to do things this way rather than
720 ;; some possibly more logical way. - CSR, 2002-04-18
722 ;; "If host is a logical host then thing is parsed as a
723 ;; logical pathname namestring on the host."
724 (host (funcall (host-parse host
) namestr start end
))
725 ;; "If host is nil and thing is a syntactically valid
726 ;; logical pathname namestring containing an explicit
727 ;; host, then it is parsed as a logical pathname
729 ((parseable-logical-namestring-p namestr start end
)
730 (parse-logical-namestring namestr start end
))
731 ;; "If host is nil, default-pathname is a logical
732 ;; pathname, and thing is a syntactically valid logical
733 ;; pathname namestring without an explicit host, then it
734 ;; is parsed as a logical pathname namestring on the
735 ;; host that is the host component of default-pathname."
737 ;; "Otherwise, the parsing of thing is
738 ;; implementation-defined."
740 ;; Both clauses are handled here, as the default
741 ;; *DEFAULT-PATHNAME-DEFAULTS* has a SB-IMPL::UNIX-HOST
743 ((pathname-host defaults
)
744 (funcall (host-parse (pathname-host defaults
))
748 ;; I don't think we should ever get here, as the default
749 ;; host will always have a non-null HOST, given that we
750 ;; can't create a new pathname without going through
751 ;; *DEFAULT-PATHNAME-DEFAULTS*, which has a non-null
753 (t (bug "Fallen through COND in %PARSE-NAMESTRING")))
754 (when (and host new-host
(not (eq new-host host
)))
755 (error 'simple-type-error
757 ;; Note: ANSI requires that this be a TYPE-ERROR,
758 ;; but there seems to be no completely correct
759 ;; value to use for TYPE-ERROR-EXPECTED-TYPE.
760 ;; Instead, we return a sort of "type error allowed
761 ;; type", trying to say "it would be OK if you
762 ;; passed NIL as the host value" but not mentioning
763 ;; that a matching string would be OK too.
766 "The host in the namestring, ~S,~@
767 does not match the explicit HOST argument, ~S."
768 :format-arguments
(list new-host host
)))
769 (let ((pn-host (or new-host host
(pathname-host defaults
))))
770 (values (%make-maybe-logical-pathname
771 pn-host device directory file type version
)
774 ;;; If NAMESTR begins with a colon-terminated, defined, logical host,
775 ;;; then return that host, otherwise return NIL.
776 (defun extract-logical-host-prefix (namestr start end
)
777 (declare (type simple-string namestr
)
778 (type index start end
)
779 (values (or logical-host null
)))
780 (let ((colon-pos (position #\
: namestr
:start start
:end end
)))
782 (values (gethash (nstring-upcase (subseq namestr start colon-pos
))
786 (defun parse-namestring (thing
789 (defaults *default-pathname-defaults
*)
790 &key
(start 0) end junk-allowed
)
791 (declare (type pathname-designator thing defaults
)
792 (type (or list host string
(member :unspecific
)) host
)
794 (type (or index null
) end
)
795 (type (or t null
) junk-allowed
)
796 (values (or null pathname
) (or null index
)))
797 (declare (ftype (function * (values (or null pathname
) (or null index
)))
798 %parse-native-namestring
))
799 (with-host (found-host host
)
800 (let (;; According to ANSI defaults may be any valid pathname designator
801 (defaults (etypecase defaults
805 (aver (pathnamep *default-pathname-defaults
*))
806 (parse-namestring defaults
))
808 (truename defaults
)))))
809 (declare (type pathname defaults
))
812 (%parse-namestring thing found-host defaults start end junk-allowed
))
814 (%parse-namestring
(coerce thing
'simple-string
)
815 found-host defaults start end junk-allowed
))
817 (let ((defaulted-host (or found-host
(%pathname-host defaults
))))
818 (declare (type host defaulted-host
))
819 (unless (eq defaulted-host
(%pathname-host thing
))
820 (error "The HOST argument doesn't match the pathname host:~% ~
822 defaulted-host
(%pathname-host thing
))))
823 (values thing start
))
825 (let ((name (file-name thing
)))
827 (error "can't figure out the file associated with stream:~% ~S"
829 (values name nil
)))))))
831 (defun %parse-native-namestring
(namestr host defaults start end junk-allowed
833 (declare (type (or host null
) host
)
834 (type string namestr
)
836 (type (or index null
) end
))
840 (%parse-native-namestring namestr host defaults start end nil as-directory
)
841 (namestring-parse-error (condition)
842 (values nil
(namestring-parse-error-offset condition
)))))
844 (let* ((end (%check-vector-sequence-bounds namestr start end
)))
845 (multiple-value-bind (new-host device directory file type version
)
848 (funcall (host-parse-native host
) namestr start end as-directory
))
849 ((pathname-host defaults
)
850 (funcall (host-parse-native (pathname-host defaults
))
855 ;; I don't think we should ever get here, as the default
856 ;; host will always have a non-null HOST, given that we
857 ;; can't create a new pathname without going through
858 ;; *DEFAULT-PATHNAME-DEFAULTS*, which has a non-null
860 (t (bug "Fallen through COND in %PARSE-NAMESTRING")))
861 (when (and host new-host
(not (eq new-host host
)))
862 (error 'simple-type-error
864 :expected-type
`(or null
(eql ,host
))
866 "The host in the namestring, ~S,~@
867 does not match the explicit HOST argument, ~S."
868 :format-arguments
(list new-host host
)))
869 (let ((pn-host (or new-host host
(pathname-host defaults
))))
870 (values (%make-pathname
871 pn-host device directory file type version
)
874 (defun parse-native-namestring (thing
877 (defaults *default-pathname-defaults
*)
878 &key
(start 0) end junk-allowed
881 "Convert THING into a pathname, using the native conventions
882 appropriate for the pathname host HOST, or if not specified the
883 host of DEFAULTS. If THING is a string, the parse is bounded by
884 START and END, and error behaviour is controlled by JUNK-ALLOWED,
885 as with PARSE-NAMESTRING. For file systems whose native
886 conventions allow directories to be indicated as files, if
887 AS-DIRECTORY is true, return a pathname denoting THING as a
889 (declare (type pathname-designator thing defaults
)
890 (type (or list host string
(member :unspecific
)) host
)
892 (type (or index null
) end
)
893 (type (or t null
) junk-allowed
)
894 (values (or null pathname
) (or null index
)))
895 (declare (ftype (function * (values (or null pathname
) (or null index
)))
896 %parse-native-namestring
))
897 (with-host (found-host host
)
898 (let ((defaults (etypecase defaults
902 (aver (pathnamep *default-pathname-defaults
*))
903 (parse-native-namestring defaults
))
905 (truename defaults
)))))
906 (declare (type pathname defaults
))
909 (%parse-native-namestring
910 thing found-host defaults start end junk-allowed as-directory
))
912 (%parse-native-namestring
(coerce thing
'simple-string
)
913 found-host defaults start end junk-allowed
916 (let ((defaulted-host (or found-host
(%pathname-host defaults
))))
917 (declare (type host defaulted-host
))
918 (unless (eq defaulted-host
(%pathname-host thing
))
919 (error "The HOST argument doesn't match the pathname host:~% ~
921 defaulted-host
(%pathname-host thing
))))
922 (values thing start
))
925 (let ((name (file-name thing
)))
927 (error "can't figure out the file associated with stream:~% ~S"
929 (values name nil
)))))))
931 (defun namestring (pathname)
933 "Construct the full (name)string form of the pathname."
934 (declare (type pathname-designator pathname
))
935 (with-pathname (pathname pathname
)
937 (let ((host (%pathname-host pathname
)))
939 (error "can't determine the namestring for pathnames with no ~
940 host:~% ~S" pathname
))
941 (funcall (host-unparse host
) pathname
)))))
943 (defun native-namestring (pathname &key as-file
)
945 "Construct the full native (name)string form of PATHNAME. For
946 file systems whose native conventions allow directories to be
947 indicated as files, if AS-FILE is true and the name, type, and
948 version components of PATHNAME are all NIL or :UNSPECIFIC,
949 construct a string that names the directory according to the file
950 system's syntax for files."
951 (declare (type pathname-designator pathname
))
952 (with-native-pathname (pathname pathname
)
954 (let ((host (%pathname-host pathname
)))
956 (error "can't determine the native namestring for pathnames with no ~
957 host:~% ~S" pathname
))
958 (funcall (host-unparse-native host
) pathname as-file
)))))
960 (defun host-namestring (pathname)
962 "Return a string representation of the name of the host in the pathname."
963 (declare (type pathname-designator pathname
))
964 (with-pathname (pathname pathname
)
965 (let ((host (%pathname-host pathname
)))
967 (funcall (host-unparse-host host
) pathname
)
969 "can't determine the namestring for pathnames with no host:~% ~S"
972 (defun directory-namestring (pathname)
974 "Return a string representation of the directories used in the pathname."
975 (declare (type pathname-designator pathname
))
976 (with-pathname (pathname pathname
)
977 (let ((host (%pathname-host pathname
)))
979 (funcall (host-unparse-directory host
) pathname
)
981 "can't determine the namestring for pathnames with no host:~% ~S"
984 (defun file-namestring (pathname)
986 "Return a string representation of the name used in the pathname."
987 (declare (type pathname-designator pathname
))
988 (with-pathname (pathname pathname
)
989 (let ((host (%pathname-host pathname
)))
991 (funcall (host-unparse-file host
) pathname
)
993 "can't determine the namestring for pathnames with no host:~% ~S"
996 (defun enough-namestring (pathname
998 (defaults *default-pathname-defaults
*))
1000 "Return an abbreviated pathname sufficient to identify the pathname relative
1002 (declare (type pathname-designator pathname
))
1003 (with-pathname (pathname pathname
)
1004 (let ((host (%pathname-host pathname
)))
1006 (with-pathname (defaults defaults
)
1007 (funcall (host-unparse-enough host
) pathname defaults
))
1009 "can't determine the namestring for pathnames with no host:~% ~S"
1014 (defun wild-pathname-p (pathname &optional field-key
)
1016 "Predicate for determining whether pathname contains any wildcards."
1017 (declare (type pathname-designator pathname
)
1018 (type (member nil
:host
:device
:directory
:name
:type
:version
)
1020 (with-pathname (pathname pathname
)
1022 (or (pattern-p x
) (member x
'(:wild
:wild-inferiors
)))))
1025 (or (wild-pathname-p pathname
:host
)
1026 (wild-pathname-p pathname
:device
)
1027 (wild-pathname-p pathname
:directory
)
1028 (wild-pathname-p pathname
:name
)
1029 (wild-pathname-p pathname
:type
)
1030 (wild-pathname-p pathname
:version
)))
1031 (:host
(frob (%pathname-host pathname
)))
1032 (:device
(frob (%pathname-host pathname
)))
1033 (:directory
(some #'frob
(%pathname-directory pathname
)))
1034 (:name
(frob (%pathname-name pathname
)))
1035 (:type
(frob (%pathname-type pathname
)))
1036 (:version
(frob (%pathname-version pathname
)))))))
1038 (defun pathname-match-p (in-pathname in-wildname
)
1040 "Pathname matches the wildname template?"
1041 (declare (type pathname-designator in-pathname
))
1042 (with-pathname (pathname in-pathname
)
1043 (with-pathname (wildname in-wildname
)
1044 (macrolet ((frob (field &optional
(op 'components-match
))
1045 `(or (null (,field wildname
))
1046 (,op
(,field pathname
) (,field wildname
)))))
1047 (and (or (null (%pathname-host wildname
))
1048 (eq (%pathname-host wildname
) (%pathname-host pathname
)))
1049 (frob %pathname-device
)
1050 (frob %pathname-directory directory-components-match
)
1051 (frob %pathname-name
)
1052 (frob %pathname-type
)
1053 (or (eq (%pathname-host wildname
) *physical-host
*)
1054 (frob %pathname-version
)))))))
1056 ;;; Place the substitutions into the pattern and return the string or pattern
1057 ;;; that results. If DIDDLE-CASE is true, we diddle the result case as well,
1058 ;;; in case we are translating between hosts with difference conventional case.
1059 ;;; The second value is the tail of subs with all of the values that we used up
1060 ;;; stripped off. Note that PATTERN-MATCHES matches all consecutive wildcards
1061 ;;; as a single string, so we ignore subsequent contiguous wildcards.
1062 (defun substitute-into (pattern subs diddle-case
)
1063 (declare (type pattern pattern
)
1065 (values (or simple-string pattern
) list
))
1066 (let ((in-wildcard nil
)
1069 (dolist (piece (pattern-pieces pattern
))
1070 (cond ((simple-string-p piece
)
1071 (push piece strings
)
1072 (setf in-wildcard nil
))
1075 (setf in-wildcard t
)
1077 (error "not enough wildcards in FROM pattern to match ~
1080 (let ((sub (pop subs
)))
1084 (push (apply #'concatenate
'simple-string
1087 (dolist (piece (pattern-pieces sub
))
1088 (push piece pieces
)))
1092 (error "can't substitute this into the middle of a word:~
1097 (push (apply #'concatenate
'simple-string
(nreverse strings
))
1101 (if (and pieces
(simple-string-p (car pieces
)) (null (cdr pieces
)))
1103 (make-pattern (nreverse pieces
)))
1107 ;;; Called when we can't see how source and from matched.
1108 (defun didnt-match-error (source from
)
1109 (error "Pathname components from SOURCE and FROM args to TRANSLATE-PATHNAME~@
1110 did not match:~% ~S ~S"
1113 ;;; Do TRANSLATE-COMPONENT for all components except host, directory
1115 (defun translate-component (source from to diddle-case
)
1122 (if (pattern= from source
)
1124 (didnt-match-error source from
)))
1126 (multiple-value-bind (won subs
) (pattern-matches from source
)
1128 (values (substitute-into to subs diddle-case
))
1129 (didnt-match-error source from
))))
1131 (maybe-diddle-case source diddle-case
))))
1133 (values (substitute-into to
(list source
) diddle-case
)))
1135 (if (components-match source from
)
1136 (maybe-diddle-case source diddle-case
)
1137 (didnt-match-error source from
)))))
1139 (maybe-diddle-case source diddle-case
))
1141 (if (components-match source from
)
1143 (didnt-match-error source from
)))))
1145 ;;; Return a list of all the things that we want to substitute into the TO
1146 ;;; pattern (the things matched by from on source.) When From contains
1147 ;;; :WILD-INFERIORS, the result contains a sublist of the matched source
1149 (defun compute-directory-substitutions (orig-source orig-from
)
1150 (let ((source orig-source
)
1155 (unless (every (lambda (x) (eq x
:wild-inferiors
)) from
)
1156 (didnt-match-error orig-source orig-from
))
1159 (unless from
(didnt-match-error orig-source orig-from
))
1160 (let ((from-part (pop from
))
1161 (source-part (pop source
)))
1164 (typecase source-part
1166 (if (pattern= from-part source-part
)
1168 (didnt-match-error orig-source orig-from
)))
1170 (multiple-value-bind (won new-subs
)
1171 (pattern-matches from-part source-part
)
1173 (dolist (sub new-subs
)
1175 (didnt-match-error orig-source orig-from
))))
1177 (didnt-match-error orig-source orig-from
))))
1180 ((member :wild-inferiors
)
1181 (let ((remaining-source (cons source-part source
)))
1184 (when (directory-components-match remaining-source from
)
1186 (unless remaining-source
1187 (didnt-match-error orig-source orig-from
))
1188 (res (pop remaining-source
)))
1190 (setq source remaining-source
))))
1192 (unless (and (simple-string-p source-part
)
1193 (string= from-part source-part
))
1194 (didnt-match-error orig-source orig-from
)))
1196 (didnt-match-error orig-source orig-from
)))))
1199 ;;; This is called by TRANSLATE-PATHNAME on the directory components
1200 ;;; of its argument pathnames to produce the result directory
1201 ;;; component. If this leaves the directory NIL, we return the source
1202 ;;; directory. The :RELATIVE or :ABSOLUTE is taken from the source
1203 ;;; directory, except if TO is :ABSOLUTE, in which case the result
1204 ;;; will be :ABSOLUTE.
1205 (defun translate-directories (source from to diddle-case
)
1206 (if (not (and source to from
))
1207 (or (and to
(null source
) (remove :wild-inferiors to
))
1208 (mapcar (lambda (x) (maybe-diddle-case x diddle-case
)) source
))
1210 ;; If TO is :ABSOLUTE, the result should still be :ABSOLUTE.
1211 (res (if (eq (first to
) :absolute
)
1214 (let ((subs-left (compute-directory-substitutions (rest source
)
1216 (dolist (to-part (rest to
))
1220 (let ((match (pop subs-left
)))
1222 (error ":WILD-INFERIORS is not paired in from and to ~
1223 patterns:~% ~S ~S" from to
))
1224 (res (maybe-diddle-case match diddle-case
))))
1225 ((member :wild-inferiors
)
1227 (let ((match (pop subs-left
)))
1228 (unless (listp match
)
1229 (error ":WILD-INFERIORS not paired in from and to ~
1230 patterns:~% ~S ~S" from to
))
1232 (res (maybe-diddle-case x diddle-case
)))))
1234 (multiple-value-bind
1236 (substitute-into to-part subs-left diddle-case
)
1237 (setf subs-left new-subs-left
)
1239 (t (res to-part
)))))
1242 (defun translate-pathname (source from-wildname to-wildname
&key
)
1244 "Use the source pathname to translate the from-wildname's wild and
1245 unspecified elements into a completed to-pathname based on the to-wildname."
1246 (declare (type pathname-designator source from-wildname to-wildname
))
1247 (with-pathname (source source
)
1248 (with-pathname (from from-wildname
)
1249 (with-pathname (to to-wildname
)
1250 (let* ((source-host (%pathname-host source
))
1251 (from-host (%pathname-host from
))
1252 (to-host (%pathname-host to
))
1254 (and source-host to-host
1255 (not (eq (host-customary-case source-host
)
1256 (host-customary-case to-host
))))))
1257 (macrolet ((frob (field &optional
(op 'translate-component
))
1258 `(let ((result (,op
(,field source
)
1262 (if (eq result
:error
)
1263 (error "~S doesn't match ~S." source from
)
1265 (%make-maybe-logical-pathname
1266 (or to-host source-host
)
1267 (frob %pathname-device
)
1268 (frob %pathname-directory translate-directories
)
1269 (frob %pathname-name
)
1270 (frob %pathname-type
)
1271 (if (eq from-host
*physical-host
*)
1272 (if (or (eq (%pathname-version to
) :wild
)
1273 (eq (%pathname-version to
) nil
))
1274 (%pathname-version source
)
1275 (%pathname-version to
))
1276 (frob %pathname-version
)))))))))
1278 ;;;; logical pathname support. ANSI 92-102 specification.
1280 ;;;; As logical-pathname translations are loaded they are
1281 ;;;; canonicalized as patterns to enable rapid efficient translation
1282 ;;;; into physical pathnames.
1286 (defun simplify-namestring (namestring &optional host
)
1287 (funcall (host-simplify-namestring
1289 (pathname-host (sane-default-pathname-defaults))))
1292 ;;; Canonicalize a logical pathname word by uppercasing it checking that it
1293 ;;; contains only legal characters.
1294 (defun logical-word-or-lose (word)
1295 (declare (string word
))
1296 (when (string= word
"")
1297 (error 'namestring-parse-error
1298 :complaint
"Attempted to treat invalid logical hostname ~
1299 as a logical host:~% ~S"
1301 :namestring word
:offset
0))
1302 (let ((word (string-upcase word
)))
1303 (dotimes (i (length word
))
1304 (let ((ch (schar word i
)))
1305 (unless (and (typep ch
'standard-char
)
1306 (or (alpha-char-p ch
) (digit-char-p ch
) (char= ch
#\-
)))
1307 (error 'namestring-parse-error
1308 :complaint
"logical namestring character which ~
1309 is not alphanumeric or hyphen:~% ~S"
1311 :namestring word
:offset i
))))
1312 (coerce word
'string
))) ; why not simple-string?
1314 ;;; Given a logical host or string, return a logical host. If ERROR-P
1315 ;;; is NIL, then return NIL when no such host exists.
1316 (defun find-logical-host (thing &optional
(errorp t
))
1319 (let ((found (gethash (logical-word-or-lose thing
)
1321 (if (or found
(not errorp
))
1323 ;; This is the error signalled from e.g.
1324 ;; LOGICAL-PATHNAME-TRANSLATIONS when host is not a defined
1325 ;; host, and ANSI specifies that that's a TYPE-ERROR.
1326 (error 'simple-type-error
1328 ;; God only knows what ANSI expects us to use for
1329 ;; the EXPECTED-TYPE here. Maybe this will be OK..
1331 '(and string
(satisfies logical-pathname-translations
))
1332 :format-control
"logical host not yet defined: ~S"
1333 :format-arguments
(list thing
)))))
1334 (logical-host thing
)))
1336 ;;; Given a logical host name or host, return a logical host, creating
1337 ;;; a new one if necessary.
1338 (defun intern-logical-host (thing)
1339 (with-locked-system-table (*logical-hosts
*)
1340 (or (find-logical-host thing nil
)
1341 (let* ((name (logical-word-or-lose thing
))
1342 (new (make-logical-host :name name
)))
1343 (setf (gethash name
*logical-hosts
*) new
)
1346 ;;;; logical pathname parsing
1348 ;;; Deal with multi-char wildcards in a logical pathname token.
1349 (defun maybe-make-logical-pattern (namestring chunks
)
1350 (let ((chunk (caar chunks
)))
1351 (collect ((pattern))
1353 (len (length chunk
)))
1354 (declare (fixnum last-pos
))
1356 (when (= last-pos len
) (return))
1357 (let ((pos (or (position #\
* chunk
:start last-pos
) len
)))
1358 (if (= pos last-pos
)
1360 (error 'namestring-parse-error
1361 :complaint
"double asterisk inside of logical ~
1364 :namestring namestring
1365 :offset
(+ (cdar chunks
) pos
)))
1366 (pattern (subseq chunk last-pos pos
)))
1369 (pattern :multi-char-wild
))
1370 (setq last-pos
(1+ pos
)))))
1373 (make-pattern (pattern))
1374 (let ((x (car (pattern))))
1375 (if (eq x
:multi-char-wild
)
1379 ;;; Return a list of conses where the CDR is the start position and
1380 ;;; the CAR is a string (token) or character (punctuation.)
1381 (defun logical-chunkify (namestr start end
)
1383 (do ((i start
(1+ i
))
1387 (chunks (cons (nstring-upcase (subseq namestr prev end
)) prev
))))
1388 (let ((ch (schar namestr i
)))
1389 (unless (or (alpha-char-p ch
) (digit-char-p ch
)
1390 (member ch
'(#\-
#\
*)))
1392 (chunks (cons (nstring-upcase (subseq namestr prev i
)) prev
)))
1394 (unless (member ch
'(#\
; #\: #\.))
1395 (error 'namestring-parse-error
1396 :complaint
"illegal character for logical pathname:~% ~S"
1400 (chunks (cons ch i
)))))
1403 ;;; Break up a logical-namestring, always a string, into its
1404 ;;; constituent parts.
1405 (defun parse-logical-namestring (namestr start end
)
1406 (declare (type simple-string namestr
)
1407 (type index start end
))
1408 (collect ((directory))
1413 (labels ((expecting (what chunks
)
1414 (unless (and chunks
(simple-string-p (caar chunks
)))
1415 (error 'namestring-parse-error
1416 :complaint
"expecting ~A, got ~:[nothing~;~S~]."
1417 :args
(list what
(caar chunks
) (caar chunks
))
1419 :offset
(if chunks
(cdar chunks
) end
)))
1421 (parse-host (chunks)
1422 (case (caadr chunks
)
1425 (find-logical-host (expecting "a host name" chunks
)))
1426 (parse-relative (cddr chunks
)))
1428 (parse-relative chunks
))))
1429 (parse-relative (chunks)
1432 (directory :relative
)
1433 (parse-directory (cdr chunks
)))
1435 (directory :absolute
) ; Assumption! Maybe revoked later.
1436 (parse-directory chunks
))))
1437 (parse-directory (chunks)
1438 (case (caadr chunks
)
1441 (let ((res (expecting "a directory name" chunks
)))
1442 (cond ((string= res
"..") :up
)
1443 ((string= res
"**") :wild-inferiors
)
1445 (maybe-make-logical-pattern namestr chunks
)))))
1446 (parse-directory (cddr chunks
)))
1448 (parse-name chunks
))))
1449 (parse-name (chunks)
1451 (expecting "a file name" chunks
)
1452 (setq name
(maybe-make-logical-pattern namestr chunks
))
1453 (expecting-dot (cdr chunks
))))
1454 (expecting-dot (chunks)
1456 (unless (eql (caar chunks
) #\.
)
1457 (error 'namestring-parse-error
1458 :complaint
"expecting a dot, got ~S."
1459 :args
(list (caar chunks
))
1461 :offset
(cdar chunks
)))
1463 (parse-version (cdr chunks
))
1464 (parse-type (cdr chunks
)))))
1465 (parse-type (chunks)
1466 (expecting "a file type" chunks
)
1467 (setq type
(maybe-make-logical-pattern namestr chunks
))
1468 (expecting-dot (cdr chunks
)))
1469 (parse-version (chunks)
1470 (let ((str (expecting "a positive integer, * or NEWEST"
1473 ((string= str
"*") (setq version
:wild
))
1474 ((string= str
"NEWEST") (setq version
:newest
))
1476 (multiple-value-bind (res pos
)
1477 (parse-integer str
:junk-allowed t
)
1478 (unless (and res
(plusp res
))
1479 (error 'namestring-parse-error
1480 :complaint
"expected a positive integer, ~
1484 :offset
(+ pos
(cdar chunks
))))
1485 (setq version res
)))))
1487 (error 'namestring-parse-error
1488 :complaint
"extra stuff after end of file name"
1490 :offset
(cdadr chunks
)))))
1491 (parse-host (logical-chunkify namestr start end
)))
1492 (values host
:unspecific
(directory) name type version
))))
1494 ;;; We can't initialize this yet because not all host methods are
1496 (defvar *logical-pathname-defaults
*)
1498 (defun logical-namestring-p (x)
1501 (typep (pathname x
) 'logical-pathname
))))
1503 (deftype logical-namestring
()
1504 `(satisfies logical-namestring-p
))
1506 (defun logical-pathname (pathspec)
1508 "Converts the pathspec argument to a logical-pathname and returns it."
1509 (declare (type (or logical-pathname string stream
) pathspec
)
1510 (values logical-pathname
))
1511 (if (typep pathspec
'logical-pathname
)
1513 (flet ((oops (problem)
1514 (error 'simple-type-error
1516 :expected-type
'logical-namestring
1517 :format-control
"~S is not a valid logical namestring:~% ~A"
1518 :format-arguments
(list pathspec problem
))))
1519 (let ((res (handler-case
1520 (parse-namestring pathspec nil
*logical-pathname-defaults
*)
1521 (error (e) (oops e
)))))
1522 (when (eq (%pathname-host res
)
1523 (%pathname-host
*logical-pathname-defaults
*))
1524 (oops "no host specified"))
1527 ;;;; logical pathname unparsing
1529 (defun unparse-logical-directory (pathname)
1530 (declare (type pathname pathname
))
1532 (let ((directory (%pathname-directory pathname
)))
1534 (ecase (pop directory
)
1535 (:absolute
) ; nothing special
1536 (:relative
(pieces ";")))
1537 (dolist (dir directory
)
1538 (cond ((or (stringp dir
) (pattern-p dir
))
1539 (pieces (unparse-logical-piece dir
))
1543 ((eq dir
:wild-inferiors
)
1546 (error "invalid directory component: ~S" dir
))))))
1547 (apply #'concatenate
'simple-string
(pieces))))
1549 (defun unparse-logical-piece (thing)
1551 ((member :wild
) "*")
1552 (simple-string thing
)
1554 (collect ((strings))
1555 (dolist (piece (pattern-pieces thing
))
1557 (simple-string (strings piece
))
1559 (cond ((eq piece
:wild-inferiors
)
1561 ((eq piece
:multi-char-wild
)
1563 (t (error "invalid keyword: ~S" piece
))))))
1564 (apply #'concatenate
'simple-string
(strings))))))
1566 (defun unparse-logical-file (pathname)
1567 (declare (type pathname pathname
))
1568 (collect ((strings))
1569 (let* ((name (%pathname-name pathname
))
1570 (type (%pathname-type pathname
))
1571 (version (%pathname-version pathname
))
1572 (type-supplied (not (or (null type
) (eq type
:unspecific
))))
1573 (version-supplied (not (or (null version
)
1574 (eq version
:unspecific
)))))
1576 (when (and (null type
)
1577 (typep name
'string
)
1578 (position #\. name
:start
1))
1579 (error "too many dots in the name: ~S" pathname
))
1580 (strings (unparse-logical-piece name
)))
1583 (error "cannot specify the type without a file: ~S" pathname
))
1584 (when (typep type
'string
)
1585 (when (position #\. type
)
1586 (error "type component can't have a #\. inside: ~S" pathname
)))
1588 (strings (unparse-logical-piece type
)))
1589 (when version-supplied
1590 (unless type-supplied
1591 (error "cannot specify the version without a type: ~S" pathname
))
1593 ((member :newest
) (strings ".NEWEST"))
1594 ((member :wild
) (strings ".*"))
1595 (fixnum (strings ".") (strings (format nil
"~D" version
))))))
1596 (apply #'concatenate
'simple-string
(strings))))
1598 ;;; Unparse a logical pathname string.
1599 (defun unparse-enough-namestring (pathname defaults
)
1600 (let* ((path-directory (pathname-directory pathname
))
1601 (def-directory (pathname-directory defaults
))
1603 ;; Go down the directory lists to see what matches. What's
1604 ;; left is what we want, more or less.
1605 (cond ((and (eq (first path-directory
) (first def-directory
))
1606 (eq (first path-directory
) :absolute
))
1607 ;; Both paths are :ABSOLUTE, so find where the
1608 ;; common parts end and return what's left
1609 (do* ((p (rest path-directory
) (rest p
))
1610 (d (rest def-directory
) (rest d
)))
1611 ((or (endp p
) (endp d
)
1612 (not (equal (first p
) (first d
))))
1615 ;; At least one path is :RELATIVE, so just return the
1616 ;; original path. If the original path is :RELATIVE,
1617 ;; then that's the right one. If PATH-DIRECTORY is
1618 ;; :ABSOLUTE, we want to return that except when
1619 ;; DEF-DIRECTORY is :ABSOLUTE, as handled above. so return
1620 ;; the original directory.
1622 (unparse-logical-namestring
1623 (make-pathname :host
(pathname-host pathname
)
1624 :directory enough-directory
1625 :name
(pathname-name pathname
)
1626 :type
(pathname-type pathname
)
1627 :version
(pathname-version pathname
)))))
1629 (defun unparse-logical-namestring (pathname)
1630 (declare (type logical-pathname pathname
))
1631 (concatenate 'simple-string
1632 (logical-host-name (%pathname-host pathname
)) ":"
1633 (unparse-logical-directory pathname
)
1634 (unparse-logical-file pathname
)))
1636 ;;;; logical pathname translations
1638 ;;; Verify that the list of translations consists of lists and prepare
1639 ;;; canonical translations. (Parse pathnames and expand out wildcards
1641 (defun canonicalize-logical-pathname-translations (translation-list host
)
1642 (declare (type list translation-list
) (type host host
)
1644 (mapcar (lambda (translation)
1645 (destructuring-bind (from to
) translation
1646 (list (if (typep from
'logical-pathname
)
1648 (parse-namestring from host
))
1652 (defun logical-pathname-translations (host)
1654 "Return the (logical) host object argument's list of translations."
1655 (declare (type (or string logical-host
) host
)
1657 (logical-host-translations (find-logical-host host
)))
1659 (defun (setf logical-pathname-translations
) (translations host
)
1661 "Set the translations list for the logical host argument."
1662 (declare (type (or string logical-host
) host
)
1663 (type list translations
)
1665 (let ((host (intern-logical-host host
)))
1666 (setf (logical-host-canon-transls host
)
1667 (canonicalize-logical-pathname-translations translations host
))
1668 (setf (logical-host-translations host
) translations
)))
1670 (defun translate-logical-pathname (pathname &key
)
1672 "Translate PATHNAME to a physical pathname, which is returned."
1673 (declare (type pathname-designator pathname
)
1674 (values (or null pathname
)))
1677 (dolist (x (logical-host-canon-transls (%pathname-host pathname
))
1678 (error 'simple-file-error
1680 :format-control
"no translation for ~S"
1681 :format-arguments
(list pathname
)))
1682 (destructuring-bind (from to
) x
1683 (when (pathname-match-p pathname from
)
1684 (return (translate-logical-pathname
1685 (translate-pathname pathname from to
)))))))
1687 (t (translate-logical-pathname (pathname pathname
)))))
1689 (defvar *logical-pathname-defaults
*
1690 (%make-logical-pathname
1691 (make-logical-host :name
(logical-word-or-lose "BOGUS"))
1692 :unspecific nil nil nil nil
))
1694 (defun load-logical-pathname-translations (host)
1696 "Reads logical pathname translations from SYS:SITE;HOST.TRANSLATIONS.NEWEST,
1697 with HOST replaced by the supplied parameter. Returns T on success.
1699 If HOST is already defined as logical pathname host, no file is loaded and NIL
1702 The file should contain a single form, suitable for use with
1703 \(SETF LOGICAL-PATHNAME-TRANSLATIONS).
1705 Note: behaviour of this function is highly implementation dependent, and
1706 historically it used to be a no-op in SBCL -- the current approach is somewhat
1707 experimental and subject to change."
1708 (declare (type string host
)
1709 (values (member t nil
)))
1710 (if (find-logical-host host nil
)
1711 ;; This host is already defined, all is well and good.
1713 ;; ANSI: "The specific nature of the search is
1714 ;; implementation-defined."
1716 (setf (logical-pathname-translations host
)
1717 (with-open-file (lpt (make-pathname :host
"SYS"
1718 :directory
'(:absolute
"SITE")
1720 :type
"TRANSLATIONS"
1724 (defun !pathname-cold-init
()
1725 (let* ((sys *default-pathname-defaults
*)
1728 (make-pathname :directory
'(:relative
"src" :wild-inferiors
)
1729 :name
:wild
:type
:wild
)
1733 (make-pathname :directory
'(:relative
"contrib" :wild-inferiors
)
1734 :name
:wild
:type
:wild
)
1738 (make-pathname :directory
'(:relative
"output" :wild-inferiors
)
1739 :name
:wild
:type
:wild
)
1741 (setf (logical-pathname-translations "SYS")
1742 `(("SYS:SRC;**;*.*.*" ,src
)
1743 ("SYS:CONTRIB;**;*.*.*" ,contrib
)
1744 ("SYS:OUTPUT;**;*.*.*" ,output
)))))
1746 (defun set-sbcl-source-location (pathname)
1748 "Initialize the SYS logical host based on PATHNAME, which should be
1749 the top-level directory of the SBCL sources. This will replace any
1750 existing translations for \"SYS:SRC;\", \"SYS:CONTRIB;\", and
1751 \"SYS:OUTPUT;\". Other \"SYS:\" translations are preserved."
1752 (let ((truename (truename pathname
))
1753 (current-translations
1754 (remove-if (lambda (translation)
1755 (or (pathname-match-p "SYS:SRC;" translation
)
1756 (pathname-match-p "SYS:CONTRIB;" translation
)
1757 (pathname-match-p "SYS:OUTPUT;" translation
)))
1758 (logical-pathname-translations "SYS")
1760 (flet ((physical-target (component)
1762 (make-pathname :directory
(list :relative component
1767 (setf (logical-pathname-translations "SYS")
1768 `(("SYS:SRC;**;*.*.*" ,(physical-target "src"))
1769 ("SYS:CONTRIB;**;*.*.*" ,(physical-target "contrib"))
1770 ("SYS:OUTPUT;**;*.*.*" ,(physical-target "output"))
1771 ,@current-translations
)))))