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
))
18 (def!struct
(unix-host
19 (:make-load-form-fun make-unix-host-load-form
)
21 (parse #'parse-unix-namestring
)
22 (unparse #'unparse-unix-namestring
)
23 (unparse-host #'unparse-unix-host
)
24 (unparse-directory #'unparse-unix-directory
)
25 (unparse-file #'unparse-unix-file
)
26 (unparse-enough #'unparse-unix-enough
)
27 (customary-case :lower
))))
29 (defvar *unix-host
* (make-unix-host))
31 (defun make-unix-host-load-form (host)
32 (declare (ignore host
))
35 ;;; Return a value suitable, e.g., for preinitializing
36 ;;; *DEFAULT-PATHNAME-DEFAULTS* before *DEFAULT-PATHNAME-DEFAULTS* is
37 ;;; initialized (at which time we can't safely call e.g. #'PATHNAME).
38 (defun make-trivial-default-pathname ()
39 (%make-pathname
*unix-host
* nil nil nil nil
:newest
))
43 (def!method print-object
((pathname pathname
) stream
)
44 (let ((namestring (handler-case (namestring pathname
)
48 (if (or *print-readably
* *print-escape
*)
51 (coerce namestring
'(simple-array character
(*))))
52 (print-unreadable-object (pathname stream
:type t
)
54 "~@<(with no namestring) ~_:HOST ~S ~_:DEVICE ~S ~_:DIRECTORY ~S ~
55 ~_:NAME ~S ~_:TYPE ~S ~_:VERSION ~S~:>"
56 (%pathname-host pathname
)
57 (%pathname-device pathname
)
58 (%pathname-directory pathname
)
59 (%pathname-name pathname
)
60 (%pathname-type pathname
)
61 (%pathname-version pathname
))))))
63 (def!method make-load-form
((pathname pathname
) &optional environment
)
64 (make-load-form-saving-slots pathname
:environment environment
))
66 ;;; A pathname is logical if the host component is a logical host.
67 ;;; This constructor is used to make an instance of the correct type
68 ;;; from parsed arguments.
69 (defun %make-maybe-logical-pathname
(host device directory name type version
)
70 ;; We canonicalize logical pathname components to uppercase. ANSI
71 ;; doesn't strictly require this, leaving it up to the implementor;
72 ;; but the arguments given in the X3J13 cleanup issue
73 ;; PATHNAME-LOGICAL:ADD seem compelling: we should canonicalize the
74 ;; case, and uppercase is the ordinary way to do that.
75 (flet ((upcase-maybe (x) (typecase x
(string (logical-word-or-lose x
)) (t x
))))
76 (if (typep host
'logical-host
)
77 (%make-logical-pathname host
79 (mapcar #'upcase-maybe directory
)
84 (aver (eq host
*unix-host
*))
85 (%make-pathname host device directory name type version
)))))
87 ;;; Hash table searching maps a logical pathname's host to its
88 ;;; physical pathname translation.
89 (defvar *logical-hosts
* (make-hash-table :test
'equal
))
93 (def!method make-load-form
((pattern pattern
) &optional environment
)
94 (make-load-form-saving-slots pattern
:environment environment
))
96 (def!method print-object
((pattern pattern
) stream
)
97 (print-unreadable-object (pattern stream
:type t
)
99 (let ((*print-escape
* t
))
100 (pprint-fill stream
(pattern-pieces pattern
) nil
))
101 (prin1 (pattern-pieces pattern
) stream
))))
103 (defun pattern= (pattern1 pattern2
)
104 (declare (type pattern pattern1 pattern2
))
105 (let ((pieces1 (pattern-pieces pattern1
))
106 (pieces2 (pattern-pieces pattern2
)))
107 (and (= (length pieces1
) (length pieces2
))
108 (every (lambda (piece1 piece2
)
111 (and (simple-string-p piece2
)
112 (string= piece1 piece2
)))
115 (eq (car piece1
) (car piece2
))
116 (string= (cdr piece1
) (cdr piece2
))))
118 (eq piece1 piece2
))))
122 ;;; If the string matches the pattern returns the multiple values T
123 ;;; and a list of the matched strings.
124 (defun pattern-matches (pattern string
)
125 (declare (type pattern pattern
)
126 (type simple-string string
))
127 (let ((len (length string
)))
128 (labels ((maybe-prepend (subs cur-sub chars
)
130 (let* ((len (length chars
))
131 (new (make-string len
))
134 (setf (schar new
(decf index
)) char
))
137 (matches (pieces start subs cur-sub chars
)
140 (values t
(maybe-prepend subs cur-sub chars
))
142 (let ((piece (car pieces
)))
145 (let ((end (+ start
(length piece
))))
147 (string= piece string
148 :start2 start
:end2 end
)
149 (matches (cdr pieces
) end
150 (maybe-prepend subs cur-sub chars
)
156 (let ((char (schar string start
)))
157 (if (find char
(cdr piece
) :test
#'char
=)
158 (matches (cdr pieces
) (1+ start
) subs t
159 (cons char chars
))))))))
160 ((member :single-char-wild
)
162 (matches (cdr pieces
) (1+ start
) subs t
163 (cons (schar string start
) chars
))))
164 ((member :multi-char-wild
)
165 (multiple-value-bind (won new-subs
)
166 (matches (cdr pieces
) start subs t chars
)
170 (matches pieces
(1+ start
) subs t
171 (cons (schar string start
)
173 (multiple-value-bind (won subs
)
174 (matches (pattern-pieces pattern
) 0 nil nil nil
)
175 (values won
(reverse subs
))))))
177 ;;; PATHNAME-MATCH-P for directory components
178 (defun directory-components-match (thing wild
)
181 ;; If THING has a null directory, assume that it matches
182 ;; (:ABSOLUTE :WILD-INFERIORS) or (:RELATIVE :WILD-INFERIORS).
185 (member (first wild
) '(:absolute
:relative
))
186 (eq (second wild
) :wild-inferiors
))
188 (let ((wild1 (first wild
)))
189 (if (eq wild1
:wild-inferiors
)
190 (let ((wild-subdirs (rest wild
)))
191 (or (null wild-subdirs
)
193 (when (directory-components-match thing wild-subdirs
)
196 (unless thing
(return nil
)))))
198 (components-match (first thing
) wild1
)
199 (directory-components-match (rest thing
)
202 ;;; Return true if pathname component THING is matched by WILD. (not
204 (defun components-match (thing wild
)
205 (declare (type (or pattern symbol simple-string integer
) thing wild
))
210 ;; String is matched by itself, a matching pattern or :WILD.
213 (values (pattern-matches wild thing
)))
215 (string= thing wild
))))
217 ;; A pattern is only matched by an identical pattern.
218 (and (pattern-p wild
) (pattern= thing wild
)))
220 ;; An integer (version number) is matched by :WILD or the
221 ;; same integer. This branch will actually always be NIL as
222 ;; long as the version is a fixnum.
225 ;;; a predicate for comparing two pathname slot component sub-entries
226 (defun compare-component (this that
)
230 (and (simple-string-p that
)
231 (string= this that
)))
233 (and (pattern-p that
)
234 (pattern= this that
)))
237 (compare-component (car this
) (car that
))
238 (compare-component (cdr this
) (cdr that
)))))))
240 ;;;; pathname functions
242 (defun pathname= (pathname1 pathname2
)
243 (declare (type pathname pathname1
)
244 (type pathname pathname2
))
245 (and (eq (%pathname-host pathname1
)
246 (%pathname-host pathname2
))
247 (compare-component (%pathname-device pathname1
)
248 (%pathname-device pathname2
))
249 (compare-component (%pathname-directory pathname1
)
250 (%pathname-directory pathname2
))
251 (compare-component (%pathname-name pathname1
)
252 (%pathname-name pathname2
))
253 (compare-component (%pathname-type pathname1
)
254 (%pathname-type pathname2
))
255 (or (eq (%pathname-host pathname1
) *unix-host
*)
256 (compare-component (%pathname-version pathname1
)
257 (%pathname-version pathname2
)))))
259 ;;; Convert PATHNAME-DESIGNATOR (a pathname, or string, or
260 ;;; stream), into a pathname in pathname.
262 ;;; FIXME: was rewritten, should be tested (or rewritten again, this
263 ;;; time using ONCE-ONLY, *then* tested)
264 ;;; FIXME: become SB!XC:DEFMACRO inside EVAL-WHEN (COMPILE EVAL)?
265 (defmacro with-pathname
((pathname pathname-designator
) &body body
)
266 (let ((pd0 (gensym)))
267 `(let* ((,pd0
,pathname-designator
)
268 (,pathname
(etypecase ,pd0
270 (string (parse-namestring ,pd0
))
271 (file-stream (file-name ,pd0
)))))
274 ;;; Convert the var, a host or string name for a host, into a
275 ;;; LOGICAL-HOST structure or nil if not defined.
277 ;;; pw notes 1/12/97 this potentially useful macro is not used anywhere
278 ;;; and 'find-host' is not defined. 'find-logical-host' seems to be needed.
280 (defmacro with-host
((var expr
) &body body
)
281 `(let ((,var
(let ((,var
,expr
))
284 (string (find-logical-host ,var nil
))
289 (defun pathname (thing)
291 "Convert thing (a pathname, string or stream) into a pathname."
292 (declare (type pathname-designator thing
))
293 (with-pathname (pathname thing
)
296 ;;; Change the case of thing if DIDDLE-P.
297 (defun maybe-diddle-case (thing diddle-p
)
298 (if (and diddle-p
(not (or (symbolp thing
) (integerp thing
))))
299 (labels ((check-for (pred in
)
302 (dolist (piece (pattern-pieces in
))
303 (when (typecase piece
305 (check-for pred piece
))
309 (check-for pred
(cdr piece
))))))
313 (when (check-for pred x
)
316 (dotimes (i (length in
))
317 (when (funcall pred
(schar in i
))
320 (diddle-with (fun thing
)
324 (mapcar (lambda (piece)
332 (funcall fun
(cdr piece
))))
337 (pattern-pieces thing
))))
344 (let ((any-uppers (check-for #'upper-case-p thing
))
345 (any-lowers (check-for #'lower-case-p thing
)))
346 (cond ((and any-uppers any-lowers
)
347 ;; mixed case, stays the same
350 ;; all uppercase, becomes all lower case
351 (diddle-with (lambda (x) (if (stringp x
)
355 ;; all lowercase, becomes all upper case
356 (diddle-with (lambda (x) (if (stringp x
)
360 ;; no letters? I guess just leave it.
364 (defun merge-directories (dir1 dir2 diddle-case
)
365 (if (or (eq (car dir1
) :absolute
)
370 (if (and (eq dir
:back
)
372 (not (member (car results
)
373 '(:back
:wild-inferiors
))))
375 (push dir results
))))
376 (dolist (dir (maybe-diddle-case dir2 diddle-case
))
378 (dolist (dir (cdr dir1
))
382 (defun merge-pathnames (pathname
384 (defaults *default-pathname-defaults
*)
385 (default-version :newest
))
387 "Construct a filled in pathname by completing the unspecified components
389 (declare (type pathname-designator pathname
)
390 (type pathname-designator defaults
)
392 (with-pathname (defaults defaults
)
393 (let ((pathname (let ((*default-pathname-defaults
* defaults
))
394 (pathname pathname
))))
395 (let* ((default-host (%pathname-host defaults
))
396 (pathname-host (%pathname-host pathname
))
398 (and default-host pathname-host
399 (not (eq (host-customary-case default-host
)
400 (host-customary-case pathname-host
))))))
401 (%make-maybe-logical-pathname
402 (or pathname-host default-host
)
403 (or (%pathname-device pathname
)
404 (maybe-diddle-case (%pathname-device defaults
)
406 (merge-directories (%pathname-directory pathname
)
407 (%pathname-directory defaults
)
409 (or (%pathname-name pathname
)
410 (maybe-diddle-case (%pathname-name defaults
)
412 (or (%pathname-type pathname
)
413 (maybe-diddle-case (%pathname-type defaults
)
415 (or (%pathname-version pathname
)
416 (and (not (%pathname-name pathname
)) (%pathname-version defaults
))
417 default-version
))))))
419 (defun import-directory (directory diddle-case
)
422 ((member :wild
) '(:absolute
:wild-inferiors
))
423 ((member :unspecific
) '(:relative
))
426 (results (pop directory
))
427 (dolist (piece directory
)
428 (cond ((member piece
'(:wild
:wild-inferiors
:up
:back
))
430 ((or (simple-string-p piece
) (pattern-p piece
))
431 (results (maybe-diddle-case piece diddle-case
)))
433 (results (maybe-diddle-case (coerce piece
'simple-string
)
436 (error "~S is not allowed as a directory component." piece
))))
440 ,(maybe-diddle-case directory diddle-case
)))
443 ,(maybe-diddle-case (coerce directory
'simple-string
)
446 (defun make-pathname (&key host
451 (version nil versionp
)
455 "Makes a new pathname from the component arguments. Note that host is
456 a host-structure or string."
457 (declare (type (or string host pathname-component-tokens
) host
)
458 (type (or string pathname-component-tokens
) device
)
459 (type (or list string pattern pathname-component-tokens
) directory
)
460 (type (or string pattern pathname-component-tokens
) name type
)
461 (type (or integer pathname-component-tokens
(member :newest
))
463 (type (or pathname-designator null
) defaults
)
464 (type (member :common
:local
) case
))
465 (let* ((defaults (when defaults
466 (with-pathname (defaults defaults
) defaults
)))
467 (default-host (if defaults
468 (%pathname-host defaults
)
469 (pathname-host *default-pathname-defaults
*)))
470 ;; Raymond Toy writes: CLHS says make-pathname can take a
471 ;; string (as a logical-host) for the host part. We map that
472 ;; string into the corresponding logical host structure.
474 ;; Paul Werkowski writes:
475 ;; HyperSpec says for the arg to MAKE-PATHNAME;
476 ;; "host---a valid physical pathname host. ..."
477 ;; where it probably means -- a valid pathname host.
478 ;; "valid pathname host n. a valid physical pathname host or
479 ;; a valid logical pathname host."
481 ;; "valid physical pathname host n. any of a string,
482 ;; a list of strings, or the symbol :unspecific,
483 ;; that is recognized by the implementation as the name of a host."
484 ;; "valid logical pathname host n. a string that has been defined
485 ;; as the name of a logical host. ..."
486 ;; HS is silent on what happens if the :HOST arg is NOT one of these.
487 ;; It seems an error message is appropriate.
489 (host host
) ; A valid host, use it.
490 ((string 0) *unix-host
*) ; "" cannot be a logical host
491 (string (find-logical-host host t
)) ; logical-host or lose.
492 (t default-host
))) ; unix-host
493 (diddle-args (and (eq (host-customary-case host
) :lower
)
496 (not (eq (host-customary-case host
)
497 (host-customary-case default-host
))))
498 (dev (if devp device
(if defaults
(%pathname-device defaults
))))
499 (dir (import-directory directory diddle-args
))
502 (defaults (%pathname-version defaults
))
504 (when (and defaults
(not dirp
))
506 (merge-directories dir
507 (%pathname-directory defaults
)
510 (macrolet ((pick (var varp field
)
511 `(cond ((or (simple-string-p ,var
)
513 (maybe-diddle-case ,var diddle-args
))
515 (maybe-diddle-case (coerce ,var
'simple-string
)
518 (maybe-diddle-case ,var diddle-args
))
520 (maybe-diddle-case (,field defaults
)
524 (%make-maybe-logical-pathname host
525 dev
; forced to :UNSPECIFIC when logical
527 (pick name namep %pathname-name
)
528 (pick type typep %pathname-type
)
531 (defun pathname-host (pathname &key
(case :local
))
533 "Return PATHNAME's host."
534 (declare (type pathname-designator pathname
)
535 (type (member :local
:common
) case
)
538 (with-pathname (pathname pathname
)
539 (%pathname-host pathname
)))
541 (defun pathname-device (pathname &key
(case :local
))
543 "Return PATHNAME's device."
544 (declare (type pathname-designator pathname
)
545 (type (member :local
:common
) case
))
546 (with-pathname (pathname pathname
)
547 (maybe-diddle-case (%pathname-device pathname
)
548 (and (eq case
:common
)
549 (eq (host-customary-case
550 (%pathname-host pathname
))
553 (defun pathname-directory (pathname &key
(case :local
))
555 "Return PATHNAME's directory."
556 (declare (type pathname-designator pathname
)
557 (type (member :local
:common
) case
))
558 (with-pathname (pathname pathname
)
559 (maybe-diddle-case (%pathname-directory pathname
)
560 (and (eq case
:common
)
561 (eq (host-customary-case
562 (%pathname-host pathname
))
564 (defun pathname-name (pathname &key
(case :local
))
566 "Return PATHNAME's name."
567 (declare (type pathname-designator pathname
)
568 (type (member :local
:common
) case
))
569 (with-pathname (pathname pathname
)
570 (maybe-diddle-case (%pathname-name pathname
)
571 (and (eq case
:common
)
572 (eq (host-customary-case
573 (%pathname-host pathname
))
576 (defun pathname-type (pathname &key
(case :local
))
578 "Return PATHNAME's type."
579 (declare (type pathname-designator pathname
)
580 (type (member :local
:common
) case
))
581 (with-pathname (pathname pathname
)
582 (maybe-diddle-case (%pathname-type pathname
)
583 (and (eq case
:common
)
584 (eq (host-customary-case
585 (%pathname-host pathname
))
588 (defun pathname-version (pathname)
590 "Return PATHNAME's version."
591 (declare (type pathname-designator pathname
))
592 (with-pathname (pathname pathname
)
593 (%pathname-version pathname
)))
597 ;;; Handle the case for PARSE-NAMESTRING parsing a potentially
598 ;;; syntactically valid logical namestring with an explicit host.
600 ;;; This then isn't fully general -- we are relying on the fact that
601 ;;; we will only pass to parse-namestring namestring with an explicit
602 ;;; logical host, so that we can pass the host return from
603 ;;; parse-logical-namestring through to %PARSE-NAMESTRING as a truth
604 ;;; value. Yeah, this is probably a KLUDGE - CSR, 2002-04-18
605 (defun parseable-logical-namestring-p (namestr start end
)
608 ((namestring-parse-error (lambda (c)
611 (let ((colon (position #\
: namestr
:start start
:end end
)))
613 (let ((potential-host
614 (logical-word-or-lose (subseq namestr start colon
))))
615 ;; depending on the outcome of CSR comp.lang.lisp post
616 ;; "can PARSE-NAMESTRING create logical hosts", we may need
617 ;; to do things with potential-host (create it
618 ;; temporarily, parse the namestring and unintern the
619 ;; logical host potential-host on failure.
620 (declare (ignore potential-host
))
623 ((simple-type-error (lambda (c)
626 (parse-logical-namestring namestr start end
))))
627 ;; if we got this far, we should have an explicit host
628 ;; (first return value of parse-logical-namestring)
632 ;;; Handle the case where PARSE-NAMESTRING is actually parsing a
633 ;;; namestring. We pick off the :JUNK-ALLOWED case then find a host to
634 ;;; use for parsing, call the parser, then check whether the host matches.
635 (defun %parse-namestring
(namestr host defaults start end junk-allowed
)
636 (declare (type (or host null
) host
)
637 (type string namestr
)
639 (type (or index null
) end
))
643 (%parse-namestring namestr host defaults start end nil
)
644 (namestring-parse-error (condition)
645 (values nil
(namestring-parse-error-offset condition
)))))
647 (let* ((end (%check-vector-sequence-bounds namestr start end
)))
648 (multiple-value-bind (new-host device directory file type version
)
649 ;; Comments below are quotes from the HyperSpec
650 ;; PARSE-NAMESTRING entry, reproduced here to demonstrate
651 ;; that we actually have to do things this way rather than
652 ;; some possibly more logical way. - CSR, 2002-04-18
654 ;; "If host is a logical host then thing is parsed as a
655 ;; logical pathname namestring on the host."
656 (host (funcall (host-parse host
) namestr start end
))
657 ;; "If host is nil and thing is a syntactically valid
658 ;; logical pathname namestring containing an explicit
659 ;; host, then it is parsed as a logical pathname
661 ((parseable-logical-namestring-p namestr start end
)
662 (parse-logical-namestring namestr start end
))
663 ;; "If host is nil, default-pathname is a logical
664 ;; pathname, and thing is a syntactically valid logical
665 ;; pathname namestring without an explicit host, then it
666 ;; is parsed as a logical pathname namestring on the
667 ;; host that is the host component of default-pathname."
669 ;; "Otherwise, the parsing of thing is
670 ;; implementation-defined."
672 ;; Both clauses are handled here, as the default
673 ;; *DEFAULT-PATHNAME-DEFAULTS has a SB-IMPL::UNIX-HOST
675 ((pathname-host defaults
)
676 (funcall (host-parse (pathname-host defaults
))
680 ;; I don't think we should ever get here, as the default
681 ;; host will always have a non-null HOST, given that we
682 ;; can't create a new pathname without going through
683 ;; *DEFAULT-PATHNAME-DEFAULTS*, which has a non-null
685 (t (bug "Fallen through COND in %PARSE-NAMESTRING")))
686 (when (and host new-host
(not (eq new-host host
)))
687 (error 'simple-type-error
689 ;; Note: ANSI requires that this be a TYPE-ERROR,
690 ;; but there seems to be no completely correct
691 ;; value to use for TYPE-ERROR-EXPECTED-TYPE.
692 ;; Instead, we return a sort of "type error allowed
693 ;; type", trying to say "it would be OK if you
694 ;; passed NIL as the host value" but not mentioning
695 ;; that a matching string would be OK too.
698 "The host in the namestring, ~S,~@
699 does not match the explicit HOST argument, ~S."
700 :format-arguments
(list new-host host
)))
701 (let ((pn-host (or new-host host
(pathname-host defaults
))))
702 (values (%make-maybe-logical-pathname
703 pn-host device directory file type version
)
706 ;;; If NAMESTR begins with a colon-terminated, defined, logical host,
707 ;;; then return that host, otherwise return NIL.
708 (defun extract-logical-host-prefix (namestr start end
)
709 (declare (type simple-string namestr
)
710 (type index start end
)
711 (values (or logical-host null
)))
712 (let ((colon-pos (position #\
: namestr
:start start
:end end
)))
714 (values (gethash (nstring-upcase (subseq namestr start colon-pos
))
718 (defun parse-namestring (thing
721 (defaults *default-pathname-defaults
*)
722 &key
(start 0) end junk-allowed
)
723 (declare (type pathname-designator thing defaults
)
724 (type (or list host string
(member :unspecific
)) host
)
726 (type (or index null
) end
)
727 (type (or t null
) junk-allowed
)
728 (values (or null pathname
) (or null index
)))
729 ;; Generally, redundant specification of information in software,
730 ;; whether in code or in comments, is bad. However, the ANSI spec
731 ;; for this is messy enough that it's hard to hold in short-term
732 ;; memory, so I've recorded these redundant notes on the
733 ;; implications of the ANSI spec.
735 ;; According to the ANSI spec, HOST can be a valid pathname host, or
736 ;; a logical host, or NIL.
738 ;; A valid pathname host can be a valid physical pathname host or a
739 ;; valid logical pathname host.
741 ;; A valid physical pathname host is "any of a string, a list of
742 ;; strings, or the symbol :UNSPECIFIC, that is recognized by the
743 ;; implementation as the name of a host". In SBCL as of 0.6.9.8,
744 ;; that means :UNSPECIFIC: though someday we might want to
745 ;; generalize it to allow strings like "RTFM.MIT.EDU" or lists like
746 ;; '("RTFM" "MIT" "EDU"), that's not supported now.
748 ;; A valid logical pathname host is a string which has been defined as
749 ;; the name of a logical host, as with LOAD-LOGICAL-PATHNAME-TRANSLATIONS.
751 ;; A logical host is an object of implementation-dependent nature. In
752 ;; SBCL, it's a member of the HOST class (a subclass of STRUCTURE-OBJECT).
753 (let ((found-host (etypecase host
755 ;; This is a special host. It's not valid as a
756 ;; logical host, so it is a sensible thing to
757 ;; designate the physical Unix host object. So
761 ;; In general ANSI-compliant Common Lisps, a
762 ;; string might also be a physical pathname host,
763 ;; but ANSI leaves this up to the implementor,
764 ;; and in SBCL we don't do it, so it must be a
766 (find-logical-host host
))
767 ((or null
(member :unspecific
))
768 ;; CLHS says that HOST=:UNSPECIFIC has
769 ;; implementation-defined behavior. We
770 ;; just turn it into NIL.
773 ;; ANSI also allows LISTs to designate hosts,
774 ;; but leaves its interpretation
775 ;; implementation-defined. Our interpretation
776 ;; is that it's unsupported.:-|
777 (error "A LIST representing a pathname host is not ~
778 supported in this implementation:~% ~S"
782 ;; According to ANSI defaults may be any valid pathname designator
783 (defaults (etypecase defaults
787 (aver (pathnamep *default-pathname-defaults
*))
788 (parse-namestring defaults
))
790 (truename defaults
)))))
791 (declare (type (or null host
) found-host
)
792 (type pathname defaults
))
795 (%parse-namestring thing found-host defaults start end junk-allowed
))
797 (%parse-namestring
(coerce thing
'simple-string
)
798 found-host defaults start end junk-allowed
))
800 (let ((defaulted-host (or found-host
(%pathname-host defaults
))))
801 (declare (type host defaulted-host
))
802 (unless (eq defaulted-host
(%pathname-host thing
))
803 (error "The HOST argument doesn't match the pathname host:~% ~
805 defaulted-host
(%pathname-host thing
))))
806 (values thing start
))
808 (let ((name (file-name thing
)))
810 (error "can't figure out the file associated with stream:~% ~S"
812 (values name nil
))))))
814 (defun namestring (pathname)
816 "Construct the full (name)string form of the pathname."
817 (declare (type pathname-designator pathname
))
818 (with-pathname (pathname pathname
)
820 (let ((host (%pathname-host pathname
)))
822 (error "can't determine the namestring for pathnames with no ~
823 host:~% ~S" pathname
))
824 (funcall (host-unparse host
) pathname
)))))
826 (defun host-namestring (pathname)
828 "Return a string representation of the name of the host in the pathname."
829 (declare (type pathname-designator pathname
))
830 (with-pathname (pathname pathname
)
831 (let ((host (%pathname-host pathname
)))
833 (funcall (host-unparse-host host
) pathname
)
835 "can't determine the namestring for pathnames with no host:~% ~S"
838 (defun directory-namestring (pathname)
840 "Return a string representation of the directories used in the pathname."
841 (declare (type pathname-designator pathname
))
842 (with-pathname (pathname pathname
)
843 (let ((host (%pathname-host pathname
)))
845 (funcall (host-unparse-directory host
) pathname
)
847 "can't determine the namestring for pathnames with no host:~% ~S"
850 (defun file-namestring (pathname)
852 "Return a string representation of the name used in the pathname."
853 (declare (type pathname-designator pathname
))
854 (with-pathname (pathname pathname
)
855 (let ((host (%pathname-host pathname
)))
857 (funcall (host-unparse-file host
) pathname
)
859 "can't determine the namestring for pathnames with no host:~% ~S"
862 (defun enough-namestring (pathname
864 (defaults *default-pathname-defaults
*))
866 "Return an abbreviated pathname sufficent to identify the pathname relative
868 (declare (type pathname-designator pathname
))
869 (with-pathname (pathname pathname
)
870 (let ((host (%pathname-host pathname
)))
872 (with-pathname (defaults defaults
)
873 (funcall (host-unparse-enough host
) pathname defaults
))
875 "can't determine the namestring for pathnames with no host:~% ~S"
880 (defun wild-pathname-p (pathname &optional field-key
)
882 "Predicate for determining whether pathname contains any wildcards."
883 (declare (type pathname-designator pathname
)
884 (type (member nil
:host
:device
:directory
:name
:type
:version
)
886 (with-pathname (pathname pathname
)
888 (or (pattern-p x
) (member x
'(:wild
:wild-inferiors
)))))
891 (or (wild-pathname-p pathname
:host
)
892 (wild-pathname-p pathname
:device
)
893 (wild-pathname-p pathname
:directory
)
894 (wild-pathname-p pathname
:name
)
895 (wild-pathname-p pathname
:type
)
896 (wild-pathname-p pathname
:version
)))
897 (:host
(frob (%pathname-host pathname
)))
898 (:device
(frob (%pathname-host pathname
)))
899 (:directory
(some #'frob
(%pathname-directory pathname
)))
900 (:name
(frob (%pathname-name pathname
)))
901 (:type
(frob (%pathname-type pathname
)))
902 (:version
(frob (%pathname-version pathname
)))))))
904 (defun pathname-match-p (in-pathname in-wildname
)
906 "Pathname matches the wildname template?"
907 (declare (type pathname-designator in-pathname
))
908 (with-pathname (pathname in-pathname
)
909 (with-pathname (wildname in-wildname
)
910 (macrolet ((frob (field &optional
(op 'components-match
))
911 `(or (null (,field wildname
))
912 (,op
(,field pathname
) (,field wildname
)))))
913 (and (or (null (%pathname-host wildname
))
914 (eq (%pathname-host wildname
) (%pathname-host pathname
)))
915 (frob %pathname-device
)
916 (frob %pathname-directory directory-components-match
)
917 (frob %pathname-name
)
918 (frob %pathname-type
)
919 (or (eq (%pathname-host wildname
) *unix-host
*)
920 (frob %pathname-version
)))))))
922 ;;; Place the substitutions into the pattern and return the string or pattern
923 ;;; that results. If DIDDLE-CASE is true, we diddle the result case as well,
924 ;;; in case we are translating between hosts with difference conventional case.
925 ;;; The second value is the tail of subs with all of the values that we used up
926 ;;; stripped off. Note that PATTERN-MATCHES matches all consecutive wildcards
927 ;;; as a single string, so we ignore subsequent contiguous wildcards.
928 (defun substitute-into (pattern subs diddle-case
)
929 (declare (type pattern pattern
)
931 (values (or simple-string pattern
) list
))
932 (let ((in-wildcard nil
)
935 (dolist (piece (pattern-pieces pattern
))
936 (cond ((simple-string-p piece
)
938 (setf in-wildcard nil
))
943 (error "not enough wildcards in FROM pattern to match ~
946 (let ((sub (pop subs
)))
950 (push (apply #'concatenate
'simple-string
953 (dolist (piece (pattern-pieces sub
))
954 (push piece pieces
)))
958 (error "can't substitute this into the middle of a word:~
963 (push (apply #'concatenate
'simple-string
(nreverse strings
))
967 (if (and pieces
(simple-string-p (car pieces
)) (null (cdr pieces
)))
969 (make-pattern (nreverse pieces
)))
973 ;;; Called when we can't see how source and from matched.
974 (defun didnt-match-error (source from
)
975 (error "Pathname components from SOURCE and FROM args to TRANSLATE-PATHNAME~@
976 did not match:~% ~S ~S"
979 ;;; Do TRANSLATE-COMPONENT for all components except host, directory
981 (defun translate-component (source from to diddle-case
)
988 (if (pattern= from source
)
990 (didnt-match-error source from
)))
992 (multiple-value-bind (won subs
) (pattern-matches from source
)
994 (values (substitute-into to subs diddle-case
))
995 (didnt-match-error source from
))))
997 (maybe-diddle-case source diddle-case
))))
999 (values (substitute-into to
(list source
) diddle-case
)))
1001 (if (components-match source from
)
1002 (maybe-diddle-case source diddle-case
)
1003 (didnt-match-error source from
)))))
1005 (maybe-diddle-case source diddle-case
))
1007 (if (components-match source from
)
1009 (didnt-match-error source from
)))))
1011 ;;; Return a list of all the things that we want to substitute into the TO
1012 ;;; pattern (the things matched by from on source.) When From contains
1013 ;;; :WILD-INFERIORS, the result contains a sublist of the matched source
1015 (defun compute-directory-substitutions (orig-source orig-from
)
1016 (let ((source orig-source
)
1021 (unless (every (lambda (x) (eq x
:wild-inferiors
)) from
)
1022 (didnt-match-error orig-source orig-from
))
1025 (unless from
(didnt-match-error orig-source orig-from
))
1026 (let ((from-part (pop from
))
1027 (source-part (pop source
)))
1030 (typecase source-part
1032 (if (pattern= from-part source-part
)
1034 (didnt-match-error orig-source orig-from
)))
1036 (multiple-value-bind (won new-subs
)
1037 (pattern-matches from-part source-part
)
1039 (dolist (sub new-subs
)
1041 (didnt-match-error orig-source orig-from
))))
1043 (didnt-match-error orig-source orig-from
))))
1046 ((member :wild-inferiors
)
1047 (let ((remaining-source (cons source-part source
)))
1050 (when (directory-components-match remaining-source from
)
1052 (unless remaining-source
1053 (didnt-match-error orig-source orig-from
))
1054 (res (pop remaining-source
)))
1056 (setq source remaining-source
))))
1058 (unless (and (simple-string-p source-part
)
1059 (string= from-part source-part
))
1060 (didnt-match-error orig-source orig-from
)))
1062 (didnt-match-error orig-source orig-from
)))))
1065 ;;; This is called by TRANSLATE-PATHNAME on the directory components
1066 ;;; of its argument pathnames to produce the result directory
1067 ;;; component. If this leaves the directory NIL, we return the source
1068 ;;; directory. The :RELATIVE or :ABSOLUTE is taken from the source
1069 ;;; directory, except if TO is :ABSOLUTE, in which case the result
1070 ;;; will be :ABSOLUTE.
1071 (defun translate-directories (source from to diddle-case
)
1072 (if (not (and source to from
))
1073 (or (and to
(null source
) (remove :wild-inferiors to
))
1074 (mapcar (lambda (x) (maybe-diddle-case x diddle-case
)) source
))
1076 ;; If TO is :ABSOLUTE, the result should still be :ABSOLUTE.
1077 (res (if (eq (first to
) :absolute
)
1080 (let ((subs-left (compute-directory-substitutions (rest source
)
1082 (dolist (to-part (rest to
))
1086 (let ((match (pop subs-left
)))
1088 (error ":WILD-INFERIORS is not paired in from and to ~
1089 patterns:~% ~S ~S" from to
))
1090 (res (maybe-diddle-case match diddle-case
))))
1091 ((member :wild-inferiors
)
1093 (let ((match (pop subs-left
)))
1094 (unless (listp match
)
1095 (error ":WILD-INFERIORS not paired in from and to ~
1096 patterns:~% ~S ~S" from to
))
1098 (res (maybe-diddle-case x diddle-case
)))))
1100 (multiple-value-bind
1102 (substitute-into to-part subs-left diddle-case
)
1103 (setf subs-left new-subs-left
)
1105 (t (res to-part
)))))
1108 (defun translate-pathname (source from-wildname to-wildname
&key
)
1110 "Use the source pathname to translate the from-wildname's wild and
1111 unspecified elements into a completed to-pathname based on the to-wildname."
1112 (declare (type pathname-designator source from-wildname to-wildname
))
1113 (with-pathname (source source
)
1114 (with-pathname (from from-wildname
)
1115 (with-pathname (to to-wildname
)
1116 (let* ((source-host (%pathname-host source
))
1117 (from-host (%pathname-host from
))
1118 (to-host (%pathname-host to
))
1120 (and source-host to-host
1121 (not (eq (host-customary-case source-host
)
1122 (host-customary-case to-host
))))))
1123 (macrolet ((frob (field &optional
(op 'translate-component
))
1124 `(let ((result (,op
(,field source
)
1128 (if (eq result
:error
)
1129 (error "~S doesn't match ~S." source from
)
1131 (%make-maybe-logical-pathname
1132 (or to-host source-host
)
1133 (frob %pathname-device
)
1134 (frob %pathname-directory translate-directories
)
1135 (frob %pathname-name
)
1136 (frob %pathname-type
)
1137 (if (eq from-host
*unix-host
*)
1138 (if (eq (%pathname-version to
) :wild
)
1139 (%pathname-version from
)
1140 (%pathname-version to
))
1141 (frob %pathname-version
)))))))))
1143 ;;;; logical pathname support. ANSI 92-102 specification.
1145 ;;;; As logical-pathname translations are loaded they are
1146 ;;;; canonicalized as patterns to enable rapid efficient translation
1147 ;;;; into physical pathnames.
1151 ;;; Canonicalize a logical pathname word by uppercasing it checking that it
1152 ;;; contains only legal characters.
1153 (defun logical-word-or-lose (word)
1154 (declare (string word
))
1155 (when (string= word
"")
1156 (error 'namestring-parse-error
1157 :complaint
"Attempted to treat invalid logical hostname ~
1158 as a logical host:~% ~S"
1160 :namestring word
:offset
0))
1161 (let ((word (string-upcase word
)))
1162 (dotimes (i (length word
))
1163 (let ((ch (schar word i
)))
1164 (unless (and (typep ch
'standard-char
)
1165 (or (alpha-char-p ch
) (digit-char-p ch
) (char= ch
#\-
)))
1166 (error 'namestring-parse-error
1167 :complaint
"logical namestring character which ~
1168 is not alphanumeric or hyphen:~% ~S"
1170 :namestring word
:offset i
))))
1171 (coerce word
'base-string
)))
1173 ;;; Given a logical host or string, return a logical host. If ERROR-P
1174 ;;; is NIL, then return NIL when no such host exists.
1175 (defun find-logical-host (thing &optional
(errorp t
))
1178 (let ((found (gethash (logical-word-or-lose thing
)
1180 (if (or found
(not errorp
))
1182 ;; This is the error signalled from e.g.
1183 ;; LOGICAL-PATHNAME-TRANSLATIONS when host is not a defined
1184 ;; host, and ANSI specifies that that's a TYPE-ERROR.
1185 (error 'simple-type-error
1187 ;; God only knows what ANSI expects us to use for
1188 ;; the EXPECTED-TYPE here. Maybe this will be OK..
1190 '(and string
(satisfies logical-pathname-translations
))
1191 :format-control
"logical host not yet defined: ~S"
1192 :format-arguments
(list thing
)))))
1193 (logical-host thing
)))
1195 ;;; Given a logical host name or host, return a logical host, creating
1196 ;;; a new one if necessary.
1197 (defun intern-logical-host (thing)
1198 (declare (values logical-host
))
1199 (or (find-logical-host thing nil
)
1200 (let* ((name (logical-word-or-lose thing
))
1201 (new (make-logical-host :name name
)))
1202 (setf (gethash name
*logical-hosts
*) new
)
1205 ;;;; logical pathname parsing
1207 ;;; Deal with multi-char wildcards in a logical pathname token.
1208 (defun maybe-make-logical-pattern (namestring chunks
)
1209 (let ((chunk (caar chunks
)))
1210 (collect ((pattern))
1212 (len (length chunk
)))
1213 (declare (fixnum last-pos
))
1215 (when (= last-pos len
) (return))
1216 (let ((pos (or (position #\
* chunk
:start last-pos
) len
)))
1217 (if (= pos last-pos
)
1219 (error 'namestring-parse-error
1220 :complaint
"double asterisk inside of logical ~
1223 :namestring namestring
1224 :offset
(+ (cdar chunks
) pos
)))
1225 (pattern (subseq chunk last-pos pos
)))
1228 (pattern :multi-char-wild
))
1229 (setq last-pos
(1+ pos
)))))
1232 (make-pattern (pattern))
1233 (let ((x (car (pattern))))
1234 (if (eq x
:multi-char-wild
)
1238 ;;; Return a list of conses where the CDR is the start position and
1239 ;;; the CAR is a string (token) or character (punctuation.)
1240 (defun logical-chunkify (namestr start end
)
1242 (do ((i start
(1+ i
))
1246 (chunks (cons (nstring-upcase (subseq namestr prev end
)) prev
))))
1247 (let ((ch (schar namestr i
)))
1248 (unless (or (alpha-char-p ch
) (digit-char-p ch
)
1249 (member ch
'(#\-
#\
*)))
1251 (chunks (cons (nstring-upcase (subseq namestr prev i
)) prev
)))
1253 (unless (member ch
'(#\
; #\: #\.))
1254 (error 'namestring-parse-error
1255 :complaint
"illegal character for logical pathname:~% ~S"
1259 (chunks (cons ch i
)))))
1262 ;;; Break up a logical-namestring, always a string, into its
1263 ;;; constituent parts.
1264 (defun parse-logical-namestring (namestr start end
)
1265 (declare (type simple-string namestr
)
1266 (type index start end
))
1267 (collect ((directory))
1272 (labels ((expecting (what chunks
)
1273 (unless (and chunks
(simple-string-p (caar chunks
)))
1274 (error 'namestring-parse-error
1275 :complaint
"expecting ~A, got ~:[nothing~;~S~]."
1276 :args
(list what
(caar chunks
) (caar chunks
))
1278 :offset
(if chunks
(cdar chunks
) end
)))
1280 (parse-host (chunks)
1281 (case (caadr chunks
)
1284 (find-logical-host (expecting "a host name" chunks
)))
1285 (parse-relative (cddr chunks
)))
1287 (parse-relative chunks
))))
1288 (parse-relative (chunks)
1291 (directory :relative
)
1292 (parse-directory (cdr chunks
)))
1294 (directory :absolute
) ; Assumption! Maybe revoked later.
1295 (parse-directory chunks
))))
1296 (parse-directory (chunks)
1297 (case (caadr chunks
)
1300 (let ((res (expecting "a directory name" chunks
)))
1301 (cond ((string= res
"..") :up
)
1302 ((string= res
"**") :wild-inferiors
)
1304 (maybe-make-logical-pattern namestr chunks
)))))
1305 (parse-directory (cddr chunks
)))
1307 (parse-name chunks
))))
1308 (parse-name (chunks)
1310 (expecting "a file name" chunks
)
1311 (setq name
(maybe-make-logical-pattern namestr chunks
))
1312 (expecting-dot (cdr chunks
))))
1313 (expecting-dot (chunks)
1315 (unless (eql (caar chunks
) #\.
)
1316 (error 'namestring-parse-error
1317 :complaint
"expecting a dot, got ~S."
1318 :args
(list (caar chunks
))
1320 :offset
(cdar chunks
)))
1322 (parse-version (cdr chunks
))
1323 (parse-type (cdr chunks
)))))
1324 (parse-type (chunks)
1325 (expecting "a file type" chunks
)
1326 (setq type
(maybe-make-logical-pattern namestr chunks
))
1327 (expecting-dot (cdr chunks
)))
1328 (parse-version (chunks)
1329 (let ((str (expecting "a positive integer, * or NEWEST"
1332 ((string= str
"*") (setq version
:wild
))
1333 ((string= str
"NEWEST") (setq version
:newest
))
1335 (multiple-value-bind (res pos
)
1336 (parse-integer str
:junk-allowed t
)
1337 (unless (and res
(plusp res
))
1338 (error 'namestring-parse-error
1339 :complaint
"expected a positive integer, ~
1343 :offset
(+ pos
(cdar chunks
))))
1344 (setq version res
)))))
1346 (error 'namestring-parse-error
1347 :complaint
"extra stuff after end of file name"
1349 :offset
(cdadr chunks
)))))
1350 (parse-host (logical-chunkify namestr start end
)))
1351 (values host
:unspecific
(directory) name type version
))))
1353 ;;; We can't initialize this yet because not all host methods are
1355 (defvar *logical-pathname-defaults
*)
1357 (defun logical-pathname (pathspec)
1359 "Converts the pathspec argument to a logical-pathname and returns it."
1360 (declare (type (or logical-pathname string stream
) pathspec
)
1361 (values logical-pathname
))
1362 (if (typep pathspec
'logical-pathname
)
1364 (let ((res (parse-namestring pathspec nil
*logical-pathname-defaults
*)))
1365 (when (eq (%pathname-host res
)
1366 (%pathname-host
*logical-pathname-defaults
*))
1367 (error "This logical namestring does not specify a host:~% ~S"
1371 ;;;; logical pathname unparsing
1373 (defun unparse-logical-directory (pathname)
1374 (declare (type pathname pathname
))
1376 (let ((directory (%pathname-directory pathname
)))
1378 (ecase (pop directory
)
1379 (:absolute
) ; nothing special
1380 (:relative
(pieces ";")))
1381 (dolist (dir directory
)
1382 (cond ((or (stringp dir
) (pattern-p dir
))
1383 (pieces (unparse-logical-piece dir
))
1387 ((eq dir
:wild-inferiors
)
1390 (error "invalid directory component: ~S" dir
))))))
1391 (apply #'concatenate
'simple-string
(pieces))))
1393 (defun unparse-logical-piece (thing)
1395 ((member :wild
) "*")
1396 (simple-string thing
)
1398 (collect ((strings))
1399 (dolist (piece (pattern-pieces thing
))
1401 (simple-string (strings piece
))
1403 (cond ((eq piece
:wild-inferiors
)
1405 ((eq piece
:multi-char-wild
)
1407 (t (error "invalid keyword: ~S" piece
))))))
1408 (apply #'concatenate
'simple-string
(strings))))))
1410 (defun unparse-logical-file (pathname)
1411 (declare (type pathname pathname
))
1412 (collect ((strings))
1413 (let* ((name (%pathname-name pathname
))
1414 (type (%pathname-type pathname
))
1415 (version (%pathname-version pathname
))
1416 (type-supplied (not (or (null type
) (eq type
:unspecific
))))
1417 (version-supplied (not (or (null version
)
1418 (eq version
:unspecific
)))))
1420 (when (and (null type
) (position #\. name
:start
1))
1421 (error "too many dots in the name: ~S" pathname
))
1422 (strings (unparse-logical-piece name
)))
1425 (error "cannot specify the type without a file: ~S" pathname
))
1426 (when (typep type
'simple-string
)
1427 (when (position #\. type
)
1428 (error "type component can't have a #\. inside: ~S" pathname
)))
1430 (strings (unparse-logical-piece type
)))
1431 (when version-supplied
1432 (unless type-supplied
1433 (error "cannot specify the version without a type: ~S" pathname
))
1435 ((member :newest
) (strings ".NEWEST"))
1436 ((member :wild
) (strings ".*"))
1437 (fixnum (strings ".") (strings (format nil
"~D" version
))))))
1438 (apply #'concatenate
'simple-string
(strings))))
1440 ;;; Unparse a logical pathname string.
1441 (defun unparse-enough-namestring (pathname defaults
)
1442 (let* ((path-directory (pathname-directory pathname
))
1443 (def-directory (pathname-directory defaults
))
1445 ;; Go down the directory lists to see what matches. What's
1446 ;; left is what we want, more or less.
1447 (cond ((and (eq (first path-directory
) (first def-directory
))
1448 (eq (first path-directory
) :absolute
))
1449 ;; Both paths are :ABSOLUTE, so find where the
1450 ;; common parts end and return what's left
1451 (do* ((p (rest path-directory
) (rest p
))
1452 (d (rest def-directory
) (rest d
)))
1453 ((or (endp p
) (endp d
)
1454 (not (equal (first p
) (first d
))))
1457 ;; At least one path is :RELATIVE, so just return the
1458 ;; original path. If the original path is :RELATIVE,
1459 ;; then that's the right one. If PATH-DIRECTORY is
1460 ;; :ABSOLUTE, we want to return that except when
1461 ;; DEF-DIRECTORY is :ABSOLUTE, as handled above. so return
1462 ;; the original directory.
1464 (unparse-logical-namestring
1465 (make-pathname :host
(pathname-host pathname
)
1466 :directory enough-directory
1467 :name
(pathname-name pathname
)
1468 :type
(pathname-type pathname
)
1469 :version
(pathname-version pathname
)))))
1471 (defun unparse-logical-namestring (pathname)
1472 (declare (type logical-pathname pathname
))
1473 (concatenate 'simple-string
1474 (logical-host-name (%pathname-host pathname
)) ":"
1475 (unparse-logical-directory pathname
)
1476 (unparse-logical-file pathname
)))
1478 ;;;; logical pathname translations
1480 ;;; Verify that the list of translations consists of lists and prepare
1481 ;;; canonical translations. (Parse pathnames and expand out wildcards
1483 (defun canonicalize-logical-pathname-translations (translation-list host
)
1484 (declare (type list translation-list
) (type host host
)
1486 (mapcar (lambda (translation)
1487 (destructuring-bind (from to
) translation
1488 (list (if (typep from
'logical-pathname
)
1490 (parse-namestring from host
))
1494 (defun logical-pathname-translations (host)
1496 "Return the (logical) host object argument's list of translations."
1497 (declare (type (or string logical-host
) host
)
1499 (logical-host-translations (find-logical-host host
)))
1501 (defun (setf logical-pathname-translations
) (translations host
)
1503 "Set the translations list for the logical host argument."
1504 (declare (type (or string logical-host
) host
)
1505 (type list translations
)
1507 (let ((host (intern-logical-host host
)))
1508 (setf (logical-host-canon-transls host
)
1509 (canonicalize-logical-pathname-translations translations host
))
1510 (setf (logical-host-translations host
) translations
)))
1512 (defun translate-logical-pathname (pathname &key
)
1514 "Translate PATHNAME to a physical pathname, which is returned."
1515 (declare (type pathname-designator pathname
)
1516 (values (or null pathname
)))
1519 (dolist (x (logical-host-canon-transls (%pathname-host pathname
))
1520 (error 'simple-file-error
1522 :format-control
"no translation for ~S"
1523 :format-arguments
(list pathname
)))
1524 (destructuring-bind (from to
) x
1525 (when (pathname-match-p pathname from
)
1526 (return (translate-logical-pathname
1527 (translate-pathname pathname from to
)))))))
1529 (t (translate-logical-pathname (pathname pathname
)))))
1531 (defvar *logical-pathname-defaults
*
1532 (%make-logical-pathname
1533 (make-logical-host :name
(logical-word-or-lose "BOGUS"))
1534 :unspecific nil nil nil nil
))
1536 (defun load-logical-pathname-translations (host)
1538 (declare (type string host
)
1539 (values (member t nil
)))
1540 (if (find-logical-host host nil
)
1541 ;; This host is already defined, all is well and good.
1543 ;; ANSI: "The specific nature of the search is
1544 ;; implementation-defined." SBCL: doesn't search at all
1546 ;; FIXME: now that we have a SYS host that the system uses, it
1547 ;; might be cute to search in "SYS:TRANSLATIONS;<name>.LISP"
1548 (error "logical host ~S not found" host
)))