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 (parse-native #'parse-native-unix-namestring)
23 (unparse #'unparse-unix-namestring)
24 (unparse-native #'unparse-native-unix-namestring)
25 (unparse-host #'unparse-unix-host)
26 (unparse-directory #'unparse-unix-directory)
27 (unparse-file #'unparse-unix-file)
28 (unparse-enough #'unparse-unix-enough)
29 (customary-case :lower))))
31 (defvar *unix-host* (make-unix-host))
33 (defun make-unix-host-load-form (host)
34 (declare (ignore host))
37 (defvar *physical-host* *unix-host*)
39 ;;; Return a value suitable, e.g., for preinitializing
40 ;;; *DEFAULT-PATHNAME-DEFAULTS* before *DEFAULT-PATHNAME-DEFAULTS* is
41 ;;; initialized (at which time we can't safely call e.g. #'PATHNAME).
42 (defun make-trivial-default-pathname ()
43 (%make-pathname *physical-host* nil nil nil nil :newest))
47 (def!method print-object ((pathname pathname) stream)
48 (let ((namestring (handler-case (namestring pathname)
52 (if (or *print-readably* *print-escape*)
55 (coerce namestring '(simple-array character (*))))
56 (print-unreadable-object (pathname stream :type t)
58 "~@<(with no namestring) ~_:HOST ~S ~_:DEVICE ~S ~_:DIRECTORY ~S ~
59 ~_:NAME ~S ~_:TYPE ~S ~_:VERSION ~S~:>"
60 (%pathname-host pathname)
61 (%pathname-device pathname)
62 (%pathname-directory pathname)
63 (%pathname-name pathname)
64 (%pathname-type pathname)
65 (%pathname-version pathname))))))
67 (def!method make-load-form ((pathname pathname) &optional environment)
68 (make-load-form-saving-slots pathname :environment environment))
70 ;;; A pathname is logical if the host component is a logical host.
71 ;;; This constructor is used to make an instance of the correct type
72 ;;; from parsed arguments.
73 (defun %make-maybe-logical-pathname (host device directory name type version)
74 ;; We canonicalize logical pathname components to uppercase. ANSI
75 ;; doesn't strictly require this, leaving it up to the implementor;
76 ;; but the arguments given in the X3J13 cleanup issue
77 ;; PATHNAME-LOGICAL:ADD seem compelling: we should canonicalize the
78 ;; case, and uppercase is the ordinary way to do that.
79 (flet ((upcase-maybe (x) (typecase x (string (logical-word-or-lose x)) (t x))))
80 (if (typep host 'logical-host)
81 (%make-logical-pathname host
83 (mapcar #'upcase-maybe directory)
88 (aver (eq host *physical-host*))
89 (%make-pathname host device directory name type version)))))
91 ;;; Hash table searching maps a logical pathname's host to its
92 ;;; physical pathname translation.
93 (defvar *logical-hosts* (make-hash-table :test 'equal))
97 (def!method make-load-form ((pattern pattern) &optional environment)
98 (make-load-form-saving-slots pattern :environment environment))
100 (def!method print-object ((pattern pattern) stream)
101 (print-unreadable-object (pattern stream :type t)
103 (let ((*print-escape* t))
104 (pprint-fill stream (pattern-pieces pattern) nil))
105 (prin1 (pattern-pieces pattern) stream))))
107 (defun pattern= (pattern1 pattern2)
108 (declare (type pattern pattern1 pattern2))
109 (let ((pieces1 (pattern-pieces pattern1))
110 (pieces2 (pattern-pieces pattern2)))
111 (and (= (length pieces1) (length pieces2))
112 (every (lambda (piece1 piece2)
115 (and (simple-string-p piece2)
116 (string= piece1 piece2)))
119 (eq (car piece1) (car piece2))
120 (string= (cdr piece1) (cdr piece2))))
122 (eq piece1 piece2))))
126 ;;; If the string matches the pattern returns the multiple values T
127 ;;; and a list of the matched strings.
128 (defun pattern-matches (pattern string)
129 (declare (type pattern pattern)
130 (type simple-string string))
131 (let ((len (length string)))
132 (labels ((maybe-prepend (subs cur-sub chars)
134 (let* ((len (length chars))
135 (new (make-string len))
138 (setf (schar new (decf index)) char))
141 (matches (pieces start subs cur-sub chars)
144 (values t (maybe-prepend subs cur-sub chars))
146 (let ((piece (car pieces)))
149 (let ((end (+ start (length piece))))
151 (string= piece string
152 :start2 start :end2 end)
153 (matches (cdr pieces) end
154 (maybe-prepend subs cur-sub chars)
160 (let ((char (schar string start)))
161 (if (find char (cdr piece) :test #'char=)
162 (matches (cdr pieces) (1+ start) subs t
163 (cons char chars))))))))
164 ((member :single-char-wild)
166 (matches (cdr pieces) (1+ start) subs t
167 (cons (schar string start) chars))))
168 ((member :multi-char-wild)
169 (multiple-value-bind (won new-subs)
170 (matches (cdr pieces) start subs t chars)
174 (matches pieces (1+ start) subs t
175 (cons (schar string start)
177 (multiple-value-bind (won subs)
178 (matches (pattern-pieces pattern) 0 nil nil nil)
179 (values won (reverse subs))))))
181 ;;; PATHNAME-MATCH-P for directory components
182 (defun directory-components-match (thing wild)
185 ;; If THING has a null directory, assume that it matches
186 ;; (:ABSOLUTE :WILD-INFERIORS) or (:RELATIVE :WILD-INFERIORS).
189 (member (first wild) '(:absolute :relative))
190 (eq (second wild) :wild-inferiors))
192 (let ((wild1 (first wild)))
193 (if (eq wild1 :wild-inferiors)
194 (let ((wild-subdirs (rest wild)))
195 (or (null wild-subdirs)
197 (when (directory-components-match thing wild-subdirs)
200 (unless thing (return nil)))))
202 (components-match (first thing) wild1)
203 (directory-components-match (rest thing)
206 ;;; Return true if pathname component THING is matched by WILD. (not
208 (defun components-match (thing wild)
209 (declare (type (or pattern symbol simple-string integer) thing wild))
214 ;; String is matched by itself, a matching pattern or :WILD.
217 (values (pattern-matches wild thing)))
219 (string= thing wild))))
221 ;; A pattern is only matched by an identical pattern.
222 (and (pattern-p wild) (pattern= thing wild)))
224 ;; An integer (version number) is matched by :WILD or the
225 ;; same integer. This branch will actually always be NIL as
226 ;; long as the version is a fixnum.
229 ;;; a predicate for comparing two pathname slot component sub-entries
230 (defun compare-component (this that)
234 (and (simple-string-p that)
235 (string= this that)))
237 (and (pattern-p that)
238 (pattern= this that)))
241 (compare-component (car this) (car that))
242 (compare-component (cdr this) (cdr that)))))))
244 ;;;; pathname functions
246 (defun pathname= (pathname1 pathname2)
247 (declare (type pathname pathname1)
248 (type pathname pathname2))
249 (and (eq (%pathname-host pathname1)
250 (%pathname-host pathname2))
251 (compare-component (%pathname-device pathname1)
252 (%pathname-device pathname2))
253 (compare-component (%pathname-directory pathname1)
254 (%pathname-directory pathname2))
255 (compare-component (%pathname-name pathname1)
256 (%pathname-name pathname2))
257 (compare-component (%pathname-type pathname1)
258 (%pathname-type pathname2))
259 (or (eq (%pathname-host pathname1) *unix-host*)
260 (compare-component (%pathname-version pathname1)
261 (%pathname-version pathname2)))))
263 ;;; Convert PATHNAME-DESIGNATOR (a pathname, or string, or
264 ;;; stream), into a pathname in pathname.
266 ;;; FIXME: was rewritten, should be tested (or rewritten again, this
267 ;;; time using ONCE-ONLY, *then* tested)
268 ;;; FIXME: become SB!XC:DEFMACRO inside EVAL-WHEN (COMPILE EVAL)?
269 (defmacro with-pathname ((pathname pathname-designator) &body body)
270 (let ((pd0 (gensym)))
271 `(let* ((,pd0 ,pathname-designator)
272 (,pathname (etypecase ,pd0
274 (string (parse-namestring ,pd0))
275 (file-stream (file-name ,pd0)))))
278 (defmacro with-native-pathname ((pathname pathname-designator) &body body)
279 (let ((pd0 (gensym)))
280 `(let* ((,pd0 ,pathname-designator)
281 (,pathname (etypecase ,pd0
283 (string (parse-native-namestring ,pd0))
286 (file-stream (file-name ,pd0)))))
289 (defmacro with-host ((host host-designator) &body body)
290 ;; Generally, redundant specification of information in software,
291 ;; whether in code or in comments, is bad. However, the ANSI spec
292 ;; for this is messy enough that it's hard to hold in short-term
293 ;; memory, so I've recorded these redundant notes on the
294 ;; implications of the ANSI spec.
296 ;; According to the ANSI spec, HOST can be a valid pathname host, or
297 ;; a logical host, or NIL.
299 ;; A valid pathname host can be a valid physical pathname host or a
300 ;; valid logical pathname host.
302 ;; A valid physical pathname host is "any of a string, a list of
303 ;; strings, or the symbol :UNSPECIFIC, that is recognized by the
304 ;; implementation as the name of a host". In SBCL as of 0.6.9.8,
305 ;; that means :UNSPECIFIC: though someday we might want to
306 ;; generalize it to allow strings like "RTFM.MIT.EDU" or lists like
307 ;; '("RTFM" "MIT" "EDU"), that's not supported now.
309 ;; A valid logical pathname host is a string which has been defined as
310 ;; the name of a logical host, as with LOAD-LOGICAL-PATHNAME-TRANSLATIONS.
312 ;; A logical host is an object of implementation-dependent nature. In
313 ;; SBCL, it's a member of the HOST class (a subclass of STRUCTURE-OBJECT).
314 (let ((hd0 (gensym)))
315 `(let* ((,hd0 ,host-designator)
316 (,host (etypecase ,hd0
318 ;; This is a special host. It's not valid as a
319 ;; logical host, so it is a sensible thing to
320 ;; designate the physical host object. So we do
324 ;; In general ANSI-compliant Common Lisps, a
325 ;; string might also be a physical pathname
326 ;; host, but ANSI leaves this up to the
327 ;; implementor, and in SBCL we don't do it, so
328 ;; it must be a logical host.
329 (find-logical-host ,hd0))
330 ((or null (member :unspecific))
331 ;; CLHS says that HOST=:UNSPECIFIC has
332 ;; implementation-defined behavior. We
333 ;; just turn it into NIL.
336 ;; ANSI also allows LISTs to designate hosts,
337 ;; but leaves its interpretation
338 ;; implementation-defined. Our interpretation
339 ;; is that it's unsupported.:-|
340 (error "A LIST representing a pathname host is not ~
341 supported in this implementation:~% ~S"
346 (defun find-host (host-designator &optional (errorp t))
347 (with-host (host host-designator)
348 (when (and errorp (not host))
349 (error "Couldn't find host: ~S" host-designator))
352 (defun pathname (pathspec)
354 "Convert PATHSPEC (a pathname designator) into a pathname."
355 (declare (type pathname-designator pathspec))
356 (with-pathname (pathname pathspec)
359 (defun native-pathname (pathspec)
361 "Convert PATHSPEC (a pathname designator) into a pathname, assuming
362 the operating system native pathname conventions."
363 (with-native-pathname (pathname pathspec)
366 ;;; Change the case of thing if DIDDLE-P.
367 (defun maybe-diddle-case (thing diddle-p)
368 (if (and diddle-p (not (or (symbolp thing) (integerp thing))))
369 (labels ((check-for (pred in)
372 (dolist (piece (pattern-pieces in))
373 (when (typecase piece
375 (check-for pred piece))
379 (check-for pred (cdr piece))))))
383 (when (check-for pred x)
386 (dotimes (i (length in))
387 (when (funcall pred (schar in i))
390 (diddle-with (fun thing)
394 (mapcar (lambda (piece)
402 (funcall fun (cdr piece))))
407 (pattern-pieces thing))))
414 (let ((any-uppers (check-for #'upper-case-p thing))
415 (any-lowers (check-for #'lower-case-p thing)))
416 (cond ((and any-uppers any-lowers)
417 ;; mixed case, stays the same
420 ;; all uppercase, becomes all lower case
421 (diddle-with (lambda (x) (if (stringp x)
425 ;; all lowercase, becomes all upper case
426 (diddle-with (lambda (x) (if (stringp x)
430 ;; no letters? I guess just leave it.
434 (defun merge-directories (dir1 dir2 diddle-case)
435 (if (or (eq (car dir1) :absolute)
440 (if (and (eq dir :back)
442 (not (member (car results)
443 '(:back :wild-inferiors))))
445 (push dir results))))
446 (dolist (dir (maybe-diddle-case dir2 diddle-case))
448 (dolist (dir (cdr dir1))
452 (defun merge-pathnames (pathname
454 (defaults *default-pathname-defaults*)
455 (default-version :newest))
457 "Construct a filled in pathname by completing the unspecified components
459 (declare (type pathname-designator pathname)
460 (type pathname-designator defaults)
462 (with-pathname (defaults defaults)
463 (let ((pathname (let ((*default-pathname-defaults* defaults))
464 (pathname pathname))))
465 (let* ((default-host (%pathname-host defaults))
466 (pathname-host (%pathname-host pathname))
468 (and default-host pathname-host
469 (not (eq (host-customary-case default-host)
470 (host-customary-case pathname-host))))))
471 (%make-maybe-logical-pathname
472 (or pathname-host default-host)
473 (or (%pathname-device pathname)
474 (maybe-diddle-case (%pathname-device defaults)
476 (merge-directories (%pathname-directory pathname)
477 (%pathname-directory defaults)
479 (or (%pathname-name pathname)
480 (maybe-diddle-case (%pathname-name defaults)
482 (or (%pathname-type pathname)
483 (maybe-diddle-case (%pathname-type defaults)
485 (or (%pathname-version pathname)
486 (and (not (%pathname-name pathname)) (%pathname-version defaults))
487 default-version))))))
489 (defun import-directory (directory diddle-case)
492 ((member :wild) '(:absolute :wild-inferiors))
493 ((member :unspecific) '(:relative))
496 (results (pop directory))
497 (dolist (piece directory)
498 (cond ((member piece '(:wild :wild-inferiors :up :back))
500 ((or (simple-string-p piece) (pattern-p piece))
501 (results (maybe-diddle-case piece diddle-case)))
503 (results (maybe-diddle-case (coerce piece 'simple-string)
506 (error "~S is not allowed as a directory component." piece))))
510 ,(maybe-diddle-case directory diddle-case)))
513 ,(maybe-diddle-case (coerce directory 'simple-string)
516 (defun make-pathname (&key host
521 (version nil versionp)
525 "Makes a new pathname from the component arguments. Note that host is
526 a host-structure or string."
527 (declare (type (or string host pathname-component-tokens) host)
528 (type (or string pathname-component-tokens) device)
529 (type (or list string pattern pathname-component-tokens) directory)
530 (type (or string pattern pathname-component-tokens) name type)
531 (type (or integer pathname-component-tokens (member :newest))
533 (type (or pathname-designator null) defaults)
534 (type (member :common :local) case))
535 (let* ((defaults (when defaults
536 (with-pathname (defaults defaults) defaults)))
537 (default-host (if defaults
538 (%pathname-host defaults)
539 (pathname-host *default-pathname-defaults*)))
540 ;; Raymond Toy writes: CLHS says make-pathname can take a
541 ;; string (as a logical-host) for the host part. We map that
542 ;; string into the corresponding logical host structure.
544 ;; Paul Werkowski writes:
545 ;; HyperSpec says for the arg to MAKE-PATHNAME;
546 ;; "host---a valid physical pathname host. ..."
547 ;; where it probably means -- a valid pathname host.
548 ;; "valid pathname host n. a valid physical pathname host or
549 ;; a valid logical pathname host."
551 ;; "valid physical pathname host n. any of a string,
552 ;; a list of strings, or the symbol :unspecific,
553 ;; that is recognized by the implementation as the name of a host."
554 ;; "valid logical pathname host n. a string that has been defined
555 ;; as the name of a logical host. ..."
556 ;; HS is silent on what happens if the :HOST arg is NOT one of these.
557 ;; It seems an error message is appropriate.
558 (host (or (find-host host nil) default-host))
559 (diddle-args (and (eq (host-customary-case host) :lower)
562 (not (eq (host-customary-case host)
563 (host-customary-case default-host))))
564 (dev (if devp device (if defaults (%pathname-device defaults))))
565 (dir (import-directory directory diddle-args))
568 (defaults (%pathname-version defaults))
570 (when (and defaults (not dirp))
572 (merge-directories dir
573 (%pathname-directory defaults)
576 (macrolet ((pick (var varp field)
577 `(cond ((or (simple-string-p ,var)
579 (maybe-diddle-case ,var diddle-args))
581 (maybe-diddle-case (coerce ,var 'simple-string)
584 (maybe-diddle-case ,var diddle-args))
586 (maybe-diddle-case (,field defaults)
590 (%make-maybe-logical-pathname host
591 dev ; forced to :UNSPECIFIC when logical
593 (pick name namep %pathname-name)
594 (pick type typep %pathname-type)
597 (defun pathname-host (pathname &key (case :local))
599 "Return PATHNAME's host."
600 (declare (type pathname-designator pathname)
601 (type (member :local :common) case)
604 (with-pathname (pathname pathname)
605 (%pathname-host pathname)))
607 (defun pathname-device (pathname &key (case :local))
609 "Return PATHNAME's device."
610 (declare (type pathname-designator pathname)
611 (type (member :local :common) case))
612 (with-pathname (pathname pathname)
613 (maybe-diddle-case (%pathname-device pathname)
614 (and (eq case :common)
615 (eq (host-customary-case
616 (%pathname-host pathname))
619 (defun pathname-directory (pathname &key (case :local))
621 "Return PATHNAME's directory."
622 (declare (type pathname-designator pathname)
623 (type (member :local :common) case))
624 (with-pathname (pathname pathname)
625 (maybe-diddle-case (%pathname-directory pathname)
626 (and (eq case :common)
627 (eq (host-customary-case
628 (%pathname-host pathname))
630 (defun pathname-name (pathname &key (case :local))
632 "Return PATHNAME's name."
633 (declare (type pathname-designator pathname)
634 (type (member :local :common) case))
635 (with-pathname (pathname pathname)
636 (maybe-diddle-case (%pathname-name pathname)
637 (and (eq case :common)
638 (eq (host-customary-case
639 (%pathname-host pathname))
642 (defun pathname-type (pathname &key (case :local))
644 "Return PATHNAME's type."
645 (declare (type pathname-designator pathname)
646 (type (member :local :common) case))
647 (with-pathname (pathname pathname)
648 (maybe-diddle-case (%pathname-type pathname)
649 (and (eq case :common)
650 (eq (host-customary-case
651 (%pathname-host pathname))
654 (defun pathname-version (pathname)
656 "Return PATHNAME's version."
657 (declare (type pathname-designator pathname))
658 (with-pathname (pathname pathname)
659 (%pathname-version pathname)))
663 ;;; Handle the case for PARSE-NAMESTRING parsing a potentially
664 ;;; syntactically valid logical namestring with an explicit host.
666 ;;; This then isn't fully general -- we are relying on the fact that
667 ;;; we will only pass to parse-namestring namestring with an explicit
668 ;;; logical host, so that we can pass the host return from
669 ;;; parse-logical-namestring through to %PARSE-NAMESTRING as a truth
670 ;;; value. Yeah, this is probably a KLUDGE - CSR, 2002-04-18
671 (defun parseable-logical-namestring-p (namestr start end)
674 ((namestring-parse-error (lambda (c)
677 (let ((colon (position #\: namestr :start start :end end)))
679 (let ((potential-host
680 (logical-word-or-lose (subseq namestr start colon))))
681 ;; depending on the outcome of CSR comp.lang.lisp post
682 ;; "can PARSE-NAMESTRING create logical hosts", we may need
683 ;; to do things with potential-host (create it
684 ;; temporarily, parse the namestring and unintern the
685 ;; logical host potential-host on failure.
686 (declare (ignore potential-host))
689 ((simple-type-error (lambda (c)
692 (parse-logical-namestring namestr start end))))
693 ;; if we got this far, we should have an explicit host
694 ;; (first return value of parse-logical-namestring)
698 ;;; Handle the case where PARSE-NAMESTRING is actually parsing a
699 ;;; namestring. We pick off the :JUNK-ALLOWED case then find a host to
700 ;;; use for parsing, call the parser, then check whether the host matches.
701 (defun %parse-namestring (namestr host defaults start end junk-allowed)
702 (declare (type (or host null) host)
703 (type string namestr)
705 (type (or index null) end))
709 (%parse-namestring namestr host defaults start end nil)
710 (namestring-parse-error (condition)
711 (values nil (namestring-parse-error-offset condition)))))
713 (let* ((end (%check-vector-sequence-bounds namestr start end)))
714 (multiple-value-bind (new-host device directory file type version)
715 ;; Comments below are quotes from the HyperSpec
716 ;; PARSE-NAMESTRING entry, reproduced here to demonstrate
717 ;; that we actually have to do things this way rather than
718 ;; some possibly more logical way. - CSR, 2002-04-18
720 ;; "If host is a logical host then thing is parsed as a
721 ;; logical pathname namestring on the host."
722 (host (funcall (host-parse host) namestr start end))
723 ;; "If host is nil and thing is a syntactically valid
724 ;; logical pathname namestring containing an explicit
725 ;; host, then it is parsed as a logical pathname
727 ((parseable-logical-namestring-p namestr start end)
728 (parse-logical-namestring namestr start end))
729 ;; "If host is nil, default-pathname is a logical
730 ;; pathname, and thing is a syntactically valid logical
731 ;; pathname namestring without an explicit host, then it
732 ;; is parsed as a logical pathname namestring on the
733 ;; host that is the host component of default-pathname."
735 ;; "Otherwise, the parsing of thing is
736 ;; implementation-defined."
738 ;; Both clauses are handled here, as the default
739 ;; *DEFAULT-PATHNAME-DEFAULTS* has a SB-IMPL::UNIX-HOST
741 ((pathname-host defaults)
742 (funcall (host-parse (pathname-host defaults))
746 ;; I don't think we should ever get here, as the default
747 ;; host will always have a non-null HOST, given that we
748 ;; can't create a new pathname without going through
749 ;; *DEFAULT-PATHNAME-DEFAULTS*, which has a non-null
751 (t (bug "Fallen through COND in %PARSE-NAMESTRING")))
752 (when (and host new-host (not (eq new-host host)))
753 (error 'simple-type-error
755 ;; Note: ANSI requires that this be a TYPE-ERROR,
756 ;; but there seems to be no completely correct
757 ;; value to use for TYPE-ERROR-EXPECTED-TYPE.
758 ;; Instead, we return a sort of "type error allowed
759 ;; type", trying to say "it would be OK if you
760 ;; passed NIL as the host value" but not mentioning
761 ;; that a matching string would be OK too.
764 "The host in the namestring, ~S,~@
765 does not match the explicit HOST argument, ~S."
766 :format-arguments (list new-host host)))
767 (let ((pn-host (or new-host host (pathname-host defaults))))
768 (values (%make-maybe-logical-pathname
769 pn-host device directory file type version)
772 ;;; If NAMESTR begins with a colon-terminated, defined, logical host,
773 ;;; then return that host, otherwise return NIL.
774 (defun extract-logical-host-prefix (namestr start end)
775 (declare (type simple-string namestr)
776 (type index start end)
777 (values (or logical-host null)))
778 (let ((colon-pos (position #\: namestr :start start :end end)))
780 (values (gethash (nstring-upcase (subseq namestr start colon-pos))
784 (defun parse-namestring (thing
787 (defaults *default-pathname-defaults*)
788 &key (start 0) end junk-allowed)
789 (declare (type pathname-designator thing defaults)
790 (type (or list host string (member :unspecific)) host)
792 (type (or index null) end)
793 (type (or t null) junk-allowed)
794 (values (or null pathname) (or null index)))
795 (with-host (found-host host)
796 (let (;; According to ANSI defaults may be any valid pathname designator
797 (defaults (etypecase defaults
801 (aver (pathnamep *default-pathname-defaults*))
802 (parse-namestring defaults))
804 (truename defaults)))))
805 (declare (type pathname defaults))
808 (%parse-namestring thing found-host defaults start end junk-allowed))
810 (%parse-namestring (coerce thing 'simple-string)
811 found-host defaults start end junk-allowed))
813 (let ((defaulted-host (or found-host (%pathname-host defaults))))
814 (declare (type host defaulted-host))
815 (unless (eq defaulted-host (%pathname-host thing))
816 (error "The HOST argument doesn't match the pathname host:~% ~
818 defaulted-host (%pathname-host thing))))
819 (values thing start))
821 (let ((name (file-name thing)))
823 (error "can't figure out the file associated with stream:~% ~S"
825 (values name nil)))))))
827 (defun %parse-native-namestring (namestr host defaults start end junk-allowed)
828 (declare (type (or host null) host)
829 (type string namestr)
831 (type (or index null) end))
835 (%parse-namestring namestr host defaults start end nil)
836 (namestring-parse-error (condition)
837 (values nil (namestring-parse-error-offset condition)))))
839 (let* ((end (%check-vector-sequence-bounds namestr start end)))
840 (multiple-value-bind (new-host device directory file type version)
842 (host (funcall (host-parse-native host) namestr start end))
843 ((pathname-host defaults)
844 (funcall (host-parse-native (pathname-host defaults))
848 ;; I don't think we should ever get here, as the default
849 ;; host will always have a non-null HOST, given that we
850 ;; can't create a new pathname without going through
851 ;; *DEFAULT-PATHNAME-DEFAULTS*, which has a non-null
853 (t (bug "Fallen through COND in %PARSE-NAMESTRING")))
854 (when (and host new-host (not (eq new-host host)))
855 (error 'simple-type-error
857 :expected-type `(or null (eql ,host))
859 "The host in the namestring, ~S,~@
860 does not match the explicit HOST argument, ~S."
861 :format-arguments (list new-host host)))
862 (let ((pn-host (or new-host host (pathname-host defaults))))
863 (values (%make-pathname
864 pn-host device directory file type version)
867 (defun parse-native-namestring (thing
870 (defaults *default-pathname-defaults*)
871 &key (start 0) end junk-allowed)
873 "Convert THING into a pathname, using the native conventions
874 appropriate for the pathname host HOST, or if not specified the host
875 of DEFAULTS. If THING is a string, the parse is bounded by START and
876 END, and error behaviour is controlled by JUNK-ALLOWED, as with
878 (declare (type pathname-designator thing defaults)
879 (type (or list host string (member :unspecific)) host)
881 (type (or index null) end)
882 (type (or t null) junk-allowed)
883 (values (or null pathname) (or null index)))
884 (with-host (found-host host)
885 (let ((defaults (etypecase defaults
889 (aver (pathnamep *default-pathname-defaults*))
890 (parse-native-namestring defaults))
892 (truename defaults)))))
893 (declare (type pathname defaults))
896 (%parse-native-namestring
897 thing found-host defaults start end junk-allowed))
899 (%parse-native-namestring (coerce thing 'simple-string)
900 found-host defaults start end junk-allowed))
902 (let ((defaulted-host (or found-host (%pathname-host defaults))))
903 (declare (type host defaulted-host))
904 (unless (eq defaulted-host (%pathname-host thing))
905 (error "The HOST argument doesn't match the pathname host:~% ~
907 defaulted-host (%pathname-host thing))))
908 (values thing start))
911 (let ((name (file-name thing)))
913 (error "can't figure out the file associated with stream:~% ~S"
915 (values name nil)))))))
917 (defun namestring (pathname)
919 "Construct the full (name)string form of the pathname."
920 (declare (type pathname-designator pathname))
921 (with-pathname (pathname pathname)
923 (let ((host (%pathname-host pathname)))
925 (error "can't determine the namestring for pathnames with no ~
926 host:~% ~S" pathname))
927 (funcall (host-unparse host) pathname)))))
929 (defun native-namestring (pathname)
931 "Construct the full native (name)string form of PATHNAME."
932 (declare (type pathname-designator pathname))
933 (with-native-pathname (pathname pathname)
935 (let ((host (%pathname-host pathname)))
937 (error "can't determine the native namestring for pathnames with no ~
938 host:~% ~S" pathname))
939 (funcall (host-unparse-native host) pathname)))))
941 (defun host-namestring (pathname)
943 "Return a string representation of the name of the host in the pathname."
944 (declare (type pathname-designator pathname))
945 (with-pathname (pathname pathname)
946 (let ((host (%pathname-host pathname)))
948 (funcall (host-unparse-host host) pathname)
950 "can't determine the namestring for pathnames with no host:~% ~S"
953 (defun directory-namestring (pathname)
955 "Return a string representation of the directories used in the pathname."
956 (declare (type pathname-designator pathname))
957 (with-pathname (pathname pathname)
958 (let ((host (%pathname-host pathname)))
960 (funcall (host-unparse-directory host) pathname)
962 "can't determine the namestring for pathnames with no host:~% ~S"
965 (defun file-namestring (pathname)
967 "Return a string representation of the name used in the pathname."
968 (declare (type pathname-designator pathname))
969 (with-pathname (pathname pathname)
970 (let ((host (%pathname-host pathname)))
972 (funcall (host-unparse-file host) pathname)
974 "can't determine the namestring for pathnames with no host:~% ~S"
977 (defun enough-namestring (pathname
979 (defaults *default-pathname-defaults*))
981 "Return an abbreviated pathname sufficent to identify the pathname relative
983 (declare (type pathname-designator pathname))
984 (with-pathname (pathname pathname)
985 (let ((host (%pathname-host pathname)))
987 (with-pathname (defaults defaults)
988 (funcall (host-unparse-enough host) pathname defaults))
990 "can't determine the namestring for pathnames with no host:~% ~S"
995 (defun wild-pathname-p (pathname &optional field-key)
997 "Predicate for determining whether pathname contains any wildcards."
998 (declare (type pathname-designator pathname)
999 (type (member nil :host :device :directory :name :type :version)
1001 (with-pathname (pathname pathname)
1003 (or (pattern-p x) (member x '(:wild :wild-inferiors)))))
1006 (or (wild-pathname-p pathname :host)
1007 (wild-pathname-p pathname :device)
1008 (wild-pathname-p pathname :directory)
1009 (wild-pathname-p pathname :name)
1010 (wild-pathname-p pathname :type)
1011 (wild-pathname-p pathname :version)))
1012 (:host (frob (%pathname-host pathname)))
1013 (:device (frob (%pathname-host pathname)))
1014 (:directory (some #'frob (%pathname-directory pathname)))
1015 (:name (frob (%pathname-name pathname)))
1016 (:type (frob (%pathname-type pathname)))
1017 (:version (frob (%pathname-version pathname)))))))
1019 (defun pathname-match-p (in-pathname in-wildname)
1021 "Pathname matches the wildname template?"
1022 (declare (type pathname-designator in-pathname))
1023 (with-pathname (pathname in-pathname)
1024 (with-pathname (wildname in-wildname)
1025 (macrolet ((frob (field &optional (op 'components-match))
1026 `(or (null (,field wildname))
1027 (,op (,field pathname) (,field wildname)))))
1028 (and (or (null (%pathname-host wildname))
1029 (eq (%pathname-host wildname) (%pathname-host pathname)))
1030 (frob %pathname-device)
1031 (frob %pathname-directory directory-components-match)
1032 (frob %pathname-name)
1033 (frob %pathname-type)
1034 (or (eq (%pathname-host wildname) *unix-host*)
1035 (frob %pathname-version)))))))
1037 ;;; Place the substitutions into the pattern and return the string or pattern
1038 ;;; that results. If DIDDLE-CASE is true, we diddle the result case as well,
1039 ;;; in case we are translating between hosts with difference conventional case.
1040 ;;; The second value is the tail of subs with all of the values that we used up
1041 ;;; stripped off. Note that PATTERN-MATCHES matches all consecutive wildcards
1042 ;;; as a single string, so we ignore subsequent contiguous wildcards.
1043 (defun substitute-into (pattern subs diddle-case)
1044 (declare (type pattern pattern)
1046 (values (or simple-string pattern) list))
1047 (let ((in-wildcard nil)
1050 (dolist (piece (pattern-pieces pattern))
1051 (cond ((simple-string-p piece)
1052 (push piece strings)
1053 (setf in-wildcard nil))
1056 (setf in-wildcard t)
1058 (error "not enough wildcards in FROM pattern to match ~
1061 (let ((sub (pop subs)))
1065 (push (apply #'concatenate 'simple-string
1068 (dolist (piece (pattern-pieces sub))
1069 (push piece pieces)))
1073 (error "can't substitute this into the middle of a word:~
1078 (push (apply #'concatenate 'simple-string (nreverse strings))
1082 (if (and pieces (simple-string-p (car pieces)) (null (cdr pieces)))
1084 (make-pattern (nreverse pieces)))
1088 ;;; Called when we can't see how source and from matched.
1089 (defun didnt-match-error (source from)
1090 (error "Pathname components from SOURCE and FROM args to TRANSLATE-PATHNAME~@
1091 did not match:~% ~S ~S"
1094 ;;; Do TRANSLATE-COMPONENT for all components except host, directory
1096 (defun translate-component (source from to diddle-case)
1103 (if (pattern= from source)
1105 (didnt-match-error source from)))
1107 (multiple-value-bind (won subs) (pattern-matches from source)
1109 (values (substitute-into to subs diddle-case))
1110 (didnt-match-error source from))))
1112 (maybe-diddle-case source diddle-case))))
1114 (values (substitute-into to (list source) diddle-case)))
1116 (if (components-match source from)
1117 (maybe-diddle-case source diddle-case)
1118 (didnt-match-error source from)))))
1120 (maybe-diddle-case source diddle-case))
1122 (if (components-match source from)
1124 (didnt-match-error source from)))))
1126 ;;; Return a list of all the things that we want to substitute into the TO
1127 ;;; pattern (the things matched by from on source.) When From contains
1128 ;;; :WILD-INFERIORS, the result contains a sublist of the matched source
1130 (defun compute-directory-substitutions (orig-source orig-from)
1131 (let ((source orig-source)
1136 (unless (every (lambda (x) (eq x :wild-inferiors)) from)
1137 (didnt-match-error orig-source orig-from))
1140 (unless from (didnt-match-error orig-source orig-from))
1141 (let ((from-part (pop from))
1142 (source-part (pop source)))
1145 (typecase source-part
1147 (if (pattern= from-part source-part)
1149 (didnt-match-error orig-source orig-from)))
1151 (multiple-value-bind (won new-subs)
1152 (pattern-matches from-part source-part)
1154 (dolist (sub new-subs)
1156 (didnt-match-error orig-source orig-from))))
1158 (didnt-match-error orig-source orig-from))))
1161 ((member :wild-inferiors)
1162 (let ((remaining-source (cons source-part source)))
1165 (when (directory-components-match remaining-source from)
1167 (unless remaining-source
1168 (didnt-match-error orig-source orig-from))
1169 (res (pop remaining-source)))
1171 (setq source remaining-source))))
1173 (unless (and (simple-string-p source-part)
1174 (string= from-part source-part))
1175 (didnt-match-error orig-source orig-from)))
1177 (didnt-match-error orig-source orig-from)))))
1180 ;;; This is called by TRANSLATE-PATHNAME on the directory components
1181 ;;; of its argument pathnames to produce the result directory
1182 ;;; component. If this leaves the directory NIL, we return the source
1183 ;;; directory. The :RELATIVE or :ABSOLUTE is taken from the source
1184 ;;; directory, except if TO is :ABSOLUTE, in which case the result
1185 ;;; will be :ABSOLUTE.
1186 (defun translate-directories (source from to diddle-case)
1187 (if (not (and source to from))
1188 (or (and to (null source) (remove :wild-inferiors to))
1189 (mapcar (lambda (x) (maybe-diddle-case x diddle-case)) source))
1191 ;; If TO is :ABSOLUTE, the result should still be :ABSOLUTE.
1192 (res (if (eq (first to) :absolute)
1195 (let ((subs-left (compute-directory-substitutions (rest source)
1197 (dolist (to-part (rest to))
1201 (let ((match (pop subs-left)))
1203 (error ":WILD-INFERIORS is not paired in from and to ~
1204 patterns:~% ~S ~S" from to))
1205 (res (maybe-diddle-case match diddle-case))))
1206 ((member :wild-inferiors)
1208 (let ((match (pop subs-left)))
1209 (unless (listp match)
1210 (error ":WILD-INFERIORS not paired in from and to ~
1211 patterns:~% ~S ~S" from to))
1213 (res (maybe-diddle-case x diddle-case)))))
1215 (multiple-value-bind
1217 (substitute-into to-part subs-left diddle-case)
1218 (setf subs-left new-subs-left)
1220 (t (res to-part)))))
1223 (defun translate-pathname (source from-wildname to-wildname &key)
1225 "Use the source pathname to translate the from-wildname's wild and
1226 unspecified elements into a completed to-pathname based on the to-wildname."
1227 (declare (type pathname-designator source from-wildname to-wildname))
1228 (with-pathname (source source)
1229 (with-pathname (from from-wildname)
1230 (with-pathname (to to-wildname)
1231 (let* ((source-host (%pathname-host source))
1232 (from-host (%pathname-host from))
1233 (to-host (%pathname-host to))
1235 (and source-host to-host
1236 (not (eq (host-customary-case source-host)
1237 (host-customary-case to-host))))))
1238 (macrolet ((frob (field &optional (op 'translate-component))
1239 `(let ((result (,op (,field source)
1243 (if (eq result :error)
1244 (error "~S doesn't match ~S." source from)
1246 (%make-maybe-logical-pathname
1247 (or to-host source-host)
1248 (frob %pathname-device)
1249 (frob %pathname-directory translate-directories)
1250 (frob %pathname-name)
1251 (frob %pathname-type)
1252 (if (eq from-host *unix-host*)
1253 (if (eq (%pathname-version to) :wild)
1254 (%pathname-version from)
1255 (%pathname-version to))
1256 (frob %pathname-version)))))))))
1258 ;;;; logical pathname support. ANSI 92-102 specification.
1260 ;;;; As logical-pathname translations are loaded they are
1261 ;;;; canonicalized as patterns to enable rapid efficient translation
1262 ;;;; into physical pathnames.
1266 ;;; Canonicalize a logical pathname word by uppercasing it checking that it
1267 ;;; contains only legal characters.
1268 (defun logical-word-or-lose (word)
1269 (declare (string word))
1270 (when (string= word "")
1271 (error 'namestring-parse-error
1272 :complaint "Attempted to treat invalid logical hostname ~
1273 as a logical host:~% ~S"
1275 :namestring word :offset 0))
1276 (let ((word (string-upcase word)))
1277 (dotimes (i (length word))
1278 (let ((ch (schar word i)))
1279 (unless (and (typep ch 'standard-char)
1280 (or (alpha-char-p ch) (digit-char-p ch) (char= ch #\-)))
1281 (error 'namestring-parse-error
1282 :complaint "logical namestring character which ~
1283 is not alphanumeric or hyphen:~% ~S"
1285 :namestring word :offset i))))
1286 (coerce word 'base-string)))
1288 ;;; Given a logical host or string, return a logical host. If ERROR-P
1289 ;;; is NIL, then return NIL when no such host exists.
1290 (defun find-logical-host (thing &optional (errorp t))
1293 (let ((found (gethash (logical-word-or-lose thing)
1295 (if (or found (not errorp))
1297 ;; This is the error signalled from e.g.
1298 ;; LOGICAL-PATHNAME-TRANSLATIONS when host is not a defined
1299 ;; host, and ANSI specifies that that's a TYPE-ERROR.
1300 (error 'simple-type-error
1302 ;; God only knows what ANSI expects us to use for
1303 ;; the EXPECTED-TYPE here. Maybe this will be OK..
1305 '(and string (satisfies logical-pathname-translations))
1306 :format-control "logical host not yet defined: ~S"
1307 :format-arguments (list thing)))))
1308 (logical-host thing)))
1310 ;;; Given a logical host name or host, return a logical host, creating
1311 ;;; a new one if necessary.
1312 (defun intern-logical-host (thing)
1313 (declare (values logical-host))
1314 (or (find-logical-host thing nil)
1315 (let* ((name (logical-word-or-lose thing))
1316 (new (make-logical-host :name name)))
1317 (setf (gethash name *logical-hosts*) new)
1320 ;;;; logical pathname parsing
1322 ;;; Deal with multi-char wildcards in a logical pathname token.
1323 (defun maybe-make-logical-pattern (namestring chunks)
1324 (let ((chunk (caar chunks)))
1325 (collect ((pattern))
1327 (len (length chunk)))
1328 (declare (fixnum last-pos))
1330 (when (= last-pos len) (return))
1331 (let ((pos (or (position #\* chunk :start last-pos) len)))
1332 (if (= pos last-pos)
1334 (error 'namestring-parse-error
1335 :complaint "double asterisk inside of logical ~
1338 :namestring namestring
1339 :offset (+ (cdar chunks) pos)))
1340 (pattern (subseq chunk last-pos pos)))
1343 (pattern :multi-char-wild))
1344 (setq last-pos (1+ pos)))))
1347 (make-pattern (pattern))
1348 (let ((x (car (pattern))))
1349 (if (eq x :multi-char-wild)
1353 ;;; Return a list of conses where the CDR is the start position and
1354 ;;; the CAR is a string (token) or character (punctuation.)
1355 (defun logical-chunkify (namestr start end)
1357 (do ((i start (1+ i))
1361 (chunks (cons (nstring-upcase (subseq namestr prev end)) prev))))
1362 (let ((ch (schar namestr i)))
1363 (unless (or (alpha-char-p ch) (digit-char-p ch)
1364 (member ch '(#\- #\*)))
1366 (chunks (cons (nstring-upcase (subseq namestr prev i)) prev)))
1368 (unless (member ch '(#\; #\: #\.))
1369 (error 'namestring-parse-error
1370 :complaint "illegal character for logical pathname:~% ~S"
1374 (chunks (cons ch i)))))
1377 ;;; Break up a logical-namestring, always a string, into its
1378 ;;; constituent parts.
1379 (defun parse-logical-namestring (namestr start end)
1380 (declare (type simple-string namestr)
1381 (type index start end))
1382 (collect ((directory))
1387 (labels ((expecting (what chunks)
1388 (unless (and chunks (simple-string-p (caar chunks)))
1389 (error 'namestring-parse-error
1390 :complaint "expecting ~A, got ~:[nothing~;~S~]."
1391 :args (list what (caar chunks) (caar chunks))
1393 :offset (if chunks (cdar chunks) end)))
1395 (parse-host (chunks)
1396 (case (caadr chunks)
1399 (find-logical-host (expecting "a host name" chunks)))
1400 (parse-relative (cddr chunks)))
1402 (parse-relative chunks))))
1403 (parse-relative (chunks)
1406 (directory :relative)
1407 (parse-directory (cdr chunks)))
1409 (directory :absolute) ; Assumption! Maybe revoked later.
1410 (parse-directory chunks))))
1411 (parse-directory (chunks)
1412 (case (caadr chunks)
1415 (let ((res (expecting "a directory name" chunks)))
1416 (cond ((string= res "..") :up)
1417 ((string= res "**") :wild-inferiors)
1419 (maybe-make-logical-pattern namestr chunks)))))
1420 (parse-directory (cddr chunks)))
1422 (parse-name chunks))))
1423 (parse-name (chunks)
1425 (expecting "a file name" chunks)
1426 (setq name (maybe-make-logical-pattern namestr chunks))
1427 (expecting-dot (cdr chunks))))
1428 (expecting-dot (chunks)
1430 (unless (eql (caar chunks) #\.)
1431 (error 'namestring-parse-error
1432 :complaint "expecting a dot, got ~S."
1433 :args (list (caar chunks))
1435 :offset (cdar chunks)))
1437 (parse-version (cdr chunks))
1438 (parse-type (cdr chunks)))))
1439 (parse-type (chunks)
1440 (expecting "a file type" chunks)
1441 (setq type (maybe-make-logical-pattern namestr chunks))
1442 (expecting-dot (cdr chunks)))
1443 (parse-version (chunks)
1444 (let ((str (expecting "a positive integer, * or NEWEST"
1447 ((string= str "*") (setq version :wild))
1448 ((string= str "NEWEST") (setq version :newest))
1450 (multiple-value-bind (res pos)
1451 (parse-integer str :junk-allowed t)
1452 (unless (and res (plusp res))
1453 (error 'namestring-parse-error
1454 :complaint "expected a positive integer, ~
1458 :offset (+ pos (cdar chunks))))
1459 (setq version res)))))
1461 (error 'namestring-parse-error
1462 :complaint "extra stuff after end of file name"
1464 :offset (cdadr chunks)))))
1465 (parse-host (logical-chunkify namestr start end)))
1466 (values host :unspecific (directory) name type version))))
1468 ;;; We can't initialize this yet because not all host methods are
1470 (defvar *logical-pathname-defaults*)
1472 (defun logical-pathname (pathspec)
1474 "Converts the pathspec argument to a logical-pathname and returns it."
1475 (declare (type (or logical-pathname string stream) pathspec)
1476 (values logical-pathname))
1477 (if (typep pathspec 'logical-pathname)
1479 (let ((res (parse-namestring pathspec nil *logical-pathname-defaults*)))
1480 (when (eq (%pathname-host res)
1481 (%pathname-host *logical-pathname-defaults*))
1482 (error "This logical namestring does not specify a host:~% ~S"
1486 ;;;; logical pathname unparsing
1488 (defun unparse-logical-directory (pathname)
1489 (declare (type pathname pathname))
1491 (let ((directory (%pathname-directory pathname)))
1493 (ecase (pop directory)
1494 (:absolute) ; nothing special
1495 (:relative (pieces ";")))
1496 (dolist (dir directory)
1497 (cond ((or (stringp dir) (pattern-p dir))
1498 (pieces (unparse-logical-piece dir))
1502 ((eq dir :wild-inferiors)
1505 (error "invalid directory component: ~S" dir))))))
1506 (apply #'concatenate 'simple-string (pieces))))
1508 (defun unparse-logical-piece (thing)
1510 ((member :wild) "*")
1511 (simple-string thing)
1513 (collect ((strings))
1514 (dolist (piece (pattern-pieces thing))
1516 (simple-string (strings piece))
1518 (cond ((eq piece :wild-inferiors)
1520 ((eq piece :multi-char-wild)
1522 (t (error "invalid keyword: ~S" piece))))))
1523 (apply #'concatenate 'simple-string (strings))))))
1525 (defun unparse-logical-file (pathname)
1526 (declare (type pathname pathname))
1527 (collect ((strings))
1528 (let* ((name (%pathname-name pathname))
1529 (type (%pathname-type pathname))
1530 (version (%pathname-version pathname))
1531 (type-supplied (not (or (null type) (eq type :unspecific))))
1532 (version-supplied (not (or (null version)
1533 (eq version :unspecific)))))
1535 (when (and (null type) (position #\. name :start 1))
1536 (error "too many dots in the name: ~S" pathname))
1537 (strings (unparse-logical-piece name)))
1540 (error "cannot specify the type without a file: ~S" pathname))
1541 (when (typep type 'simple-string)
1542 (when (position #\. type)
1543 (error "type component can't have a #\. inside: ~S" pathname)))
1545 (strings (unparse-logical-piece type)))
1546 (when version-supplied
1547 (unless type-supplied
1548 (error "cannot specify the version without a type: ~S" pathname))
1550 ((member :newest) (strings ".NEWEST"))
1551 ((member :wild) (strings ".*"))
1552 (fixnum (strings ".") (strings (format nil "~D" version))))))
1553 (apply #'concatenate 'simple-string (strings))))
1555 ;;; Unparse a logical pathname string.
1556 (defun unparse-enough-namestring (pathname defaults)
1557 (let* ((path-directory (pathname-directory pathname))
1558 (def-directory (pathname-directory defaults))
1560 ;; Go down the directory lists to see what matches. What's
1561 ;; left is what we want, more or less.
1562 (cond ((and (eq (first path-directory) (first def-directory))
1563 (eq (first path-directory) :absolute))
1564 ;; Both paths are :ABSOLUTE, so find where the
1565 ;; common parts end and return what's left
1566 (do* ((p (rest path-directory) (rest p))
1567 (d (rest def-directory) (rest d)))
1568 ((or (endp p) (endp d)
1569 (not (equal (first p) (first d))))
1572 ;; At least one path is :RELATIVE, so just return the
1573 ;; original path. If the original path is :RELATIVE,
1574 ;; then that's the right one. If PATH-DIRECTORY is
1575 ;; :ABSOLUTE, we want to return that except when
1576 ;; DEF-DIRECTORY is :ABSOLUTE, as handled above. so return
1577 ;; the original directory.
1579 (unparse-logical-namestring
1580 (make-pathname :host (pathname-host pathname)
1581 :directory enough-directory
1582 :name (pathname-name pathname)
1583 :type (pathname-type pathname)
1584 :version (pathname-version pathname)))))
1586 (defun unparse-logical-namestring (pathname)
1587 (declare (type logical-pathname pathname))
1588 (concatenate 'simple-string
1589 (logical-host-name (%pathname-host pathname)) ":"
1590 (unparse-logical-directory pathname)
1591 (unparse-logical-file pathname)))
1593 ;;;; logical pathname translations
1595 ;;; Verify that the list of translations consists of lists and prepare
1596 ;;; canonical translations. (Parse pathnames and expand out wildcards
1598 (defun canonicalize-logical-pathname-translations (translation-list host)
1599 (declare (type list translation-list) (type host host)
1601 (mapcar (lambda (translation)
1602 (destructuring-bind (from to) translation
1603 (list (if (typep from 'logical-pathname)
1605 (parse-namestring from host))
1609 (defun logical-pathname-translations (host)
1611 "Return the (logical) host object argument's list of translations."
1612 (declare (type (or string logical-host) host)
1614 (logical-host-translations (find-logical-host host)))
1616 (defun (setf logical-pathname-translations) (translations host)
1618 "Set the translations list for the logical host argument."
1619 (declare (type (or string logical-host) host)
1620 (type list translations)
1622 (let ((host (intern-logical-host host)))
1623 (setf (logical-host-canon-transls host)
1624 (canonicalize-logical-pathname-translations translations host))
1625 (setf (logical-host-translations host) translations)))
1627 (defun translate-logical-pathname (pathname &key)
1629 "Translate PATHNAME to a physical pathname, which is returned."
1630 (declare (type pathname-designator pathname)
1631 (values (or null pathname)))
1634 (dolist (x (logical-host-canon-transls (%pathname-host pathname))
1635 (error 'simple-file-error
1637 :format-control "no translation for ~S"
1638 :format-arguments (list pathname)))
1639 (destructuring-bind (from to) x
1640 (when (pathname-match-p pathname from)
1641 (return (translate-logical-pathname
1642 (translate-pathname pathname from to)))))))
1644 (t (translate-logical-pathname (pathname pathname)))))
1646 (defvar *logical-pathname-defaults*
1647 (%make-logical-pathname
1648 (make-logical-host :name (logical-word-or-lose "BOGUS"))
1649 :unspecific nil nil nil nil))
1651 (defun load-logical-pathname-translations (host)
1653 (declare (type string host)
1654 (values (member t nil)))
1655 (if (find-logical-host host nil)
1656 ;; This host is already defined, all is well and good.
1658 ;; ANSI: "The specific nature of the search is
1659 ;; implementation-defined." SBCL: doesn't search at all
1661 ;; FIXME: now that we have a SYS host that the system uses, it
1662 ;; might be cute to search in "SYS:TRANSLATIONS;<name>.LISP"
1663 (error "logical host ~S not found" host)))