1 ;;;; machine/filesystem-independent pathname functions
3 ;;;; This software is part of the SBCL system. See the README file for
6 ;;;; This software is derived from the CMU CL system, which was
7 ;;;; written at Carnegie Mellon University and released into the
8 ;;;; public domain. The software is in the public domain and is
9 ;;;; provided with absolutely no warranty. See the COPYING and CREDITS
10 ;;;; files for more information.
12 (in-package "SB!IMPL")
14 #!-sb-fluid (declaim (freeze-type logical-pathname logical-host))
16 ;;;; PHYSICAL-HOST stuff
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-physical-directory)
27 (unparse-file #'unparse-unix-file)
28 (unparse-enough #'unparse-unix-enough)
29 (unparse-directory-separator "/")
30 (simplify-namestring #'simplify-unix-namestring)
31 (customary-case :lower))))
32 (defvar *unix-host* (make-unix-host))
33 (defun make-unix-host-load-form (host)
34 (declare (ignore host))
37 (def!struct (win32-host
38 (:make-load-form-fun make-win32-host-load-form)
40 (parse #'parse-win32-namestring)
41 (parse-native #'parse-native-win32-namestring)
42 (unparse #'unparse-win32-namestring)
43 (unparse-native #'unparse-native-win32-namestring)
44 (unparse-host #'unparse-win32-host)
45 (unparse-directory #'unparse-physical-directory)
46 (unparse-file #'unparse-win32-file)
47 (unparse-enough #'unparse-win32-enough)
48 (unparse-directory-separator "\\")
49 (simplify-namestring #'simplify-win32-namestring)
50 (customary-case :lower))))
51 (defparameter *win32-host* (make-win32-host))
52 (defun make-win32-host-load-form (host)
53 (declare (ignore host))
56 (defvar *physical-host*
58 #!+win32 *win32-host*)
60 ;;; Return a value suitable, e.g., for preinitializing
61 ;;; *DEFAULT-PATHNAME-DEFAULTS* before *DEFAULT-PATHNAME-DEFAULTS* is
62 ;;; initialized (at which time we can't safely call e.g. #'PATHNAME).
63 (defun make-trivial-default-pathname ()
64 (%make-pathname *physical-host* nil nil nil nil :newest))
68 (def!method print-object ((pathname pathname) stream)
69 (let ((namestring (handler-case (namestring pathname)
73 (if (or *print-readably* *print-escape*)
76 (coerce namestring '(simple-array character (*))))
77 (print-unreadable-object (pathname stream :type t)
79 "~@<(with no namestring) ~_:HOST ~S ~_:DEVICE ~S ~_:DIRECTORY ~S ~
80 ~_:NAME ~S ~_:TYPE ~S ~_:VERSION ~S~:>"
81 (%pathname-host pathname)
82 (%pathname-device pathname)
83 (%pathname-directory pathname)
84 (%pathname-name pathname)
85 (%pathname-type pathname)
86 (%pathname-version pathname))))))
88 (def!method make-load-form ((pathname pathname) &optional environment)
89 (make-load-form-saving-slots pathname :environment environment))
91 ;;; A pathname is logical if the host component is a logical host.
92 ;;; This constructor is used to make an instance of the correct type
93 ;;; from parsed arguments.
94 (defun %make-maybe-logical-pathname (host device directory name type version)
95 ;; We canonicalize logical pathname components to uppercase. ANSI
96 ;; doesn't strictly require this, leaving it up to the implementor;
97 ;; but the arguments given in the X3J13 cleanup issue
98 ;; PATHNAME-LOGICAL:ADD seem compelling: we should canonicalize the
99 ;; case, and uppercase is the ordinary way to do that.
100 (flet ((upcase-maybe (x) (typecase x (string (logical-word-or-lose x)) (t x))))
101 (if (typep host 'logical-host)
102 (%make-logical-pathname host
104 (mapcar #'upcase-maybe directory)
109 (aver (eq host *physical-host*))
110 (%make-pathname host device directory name type version)))))
112 ;;; Hash table searching maps a logical pathname's host to its
113 ;;; physical pathname translation.
114 (defvar *logical-hosts* (make-hash-table :test 'equal :synchronized t))
118 (def!method make-load-form ((pattern pattern) &optional environment)
119 (make-load-form-saving-slots pattern :environment environment))
121 (def!method print-object ((pattern pattern) stream)
122 (print-unreadable-object (pattern stream :type t)
124 (let ((*print-escape* t))
125 (pprint-fill stream (pattern-pieces pattern) nil))
126 (prin1 (pattern-pieces pattern) stream))))
128 (defun pattern= (pattern1 pattern2)
129 (declare (type pattern pattern1 pattern2))
130 (let ((pieces1 (pattern-pieces pattern1))
131 (pieces2 (pattern-pieces pattern2)))
132 (and (= (length pieces1) (length pieces2))
133 (every (lambda (piece1 piece2)
136 (and (simple-string-p piece2)
137 (string= piece1 piece2)))
140 (eq (car piece1) (car piece2))
141 (string= (cdr piece1) (cdr piece2))))
143 (eq piece1 piece2))))
147 ;;; If the string matches the pattern returns the multiple values T
148 ;;; and a list of the matched strings.
149 (defun pattern-matches (pattern string)
150 (declare (type pattern pattern)
151 (type simple-string string))
152 (let ((len (length string)))
153 (labels ((maybe-prepend (subs cur-sub chars)
155 (let* ((len (length chars))
156 (new (make-string len))
159 (setf (schar new (decf index)) char))
162 (matches (pieces start subs cur-sub chars)
165 (values t (maybe-prepend subs cur-sub chars))
167 (let ((piece (car pieces)))
170 (let ((end (+ start (length piece))))
172 (string= piece string
173 :start2 start :end2 end)
174 (matches (cdr pieces) end
175 (maybe-prepend subs cur-sub chars)
181 (let ((char (schar string start)))
182 (if (find char (cdr piece) :test #'char=)
183 (matches (cdr pieces) (1+ start) subs t
184 (cons char chars))))))))
185 ((member :single-char-wild)
187 (matches (cdr pieces) (1+ start) subs t
188 (cons (schar string start) chars))))
189 ((member :multi-char-wild)
190 (multiple-value-bind (won new-subs)
191 (matches (cdr pieces) start subs t chars)
195 (matches pieces (1+ start) subs t
196 (cons (schar string start)
198 (multiple-value-bind (won subs)
199 (matches (pattern-pieces pattern) 0 nil nil nil)
200 (values won (reverse subs))))))
202 ;;; PATHNAME-MATCH-P for directory components
203 (defun directory-components-match (thing wild)
206 ;; If THING has a null directory, assume that it matches
207 ;; (:ABSOLUTE :WILD-INFERIORS) or (:RELATIVE :WILD-INFERIORS).
210 (member (first wild) '(:absolute :relative))
211 (eq (second wild) :wild-inferiors))
213 (let ((wild1 (first wild)))
214 (if (eq wild1 :wild-inferiors)
215 (let ((wild-subdirs (rest wild)))
216 (or (null wild-subdirs)
218 (when (directory-components-match thing wild-subdirs)
221 (unless thing (return nil)))))
223 (components-match (first thing) wild1)
224 (directory-components-match (rest thing)
227 ;;; Return true if pathname component THING is matched by WILD. (not
229 (defun components-match (thing wild)
230 (declare (type (or pattern symbol simple-string integer) thing wild))
235 ;; String is matched by itself, a matching pattern or :WILD.
238 (values (pattern-matches wild thing)))
240 (string= thing wild))))
242 ;; A pattern is only matched by an identical pattern.
243 (and (pattern-p wild) (pattern= thing wild)))
245 ;; An integer (version number) is matched by :WILD or the
246 ;; same integer. This branch will actually always be NIL as
247 ;; long as the version is a fixnum.
250 ;;; a predicate for comparing two pathname slot component sub-entries
251 (defun compare-component (this that)
255 (and (simple-string-p that)
256 (string= this that)))
258 (and (pattern-p that)
259 (pattern= this that)))
262 (compare-component (car this) (car that))
263 (compare-component (cdr this) (cdr that)))))))
265 ;;;; pathname functions
267 (defun pathname= (pathname1 pathname2)
268 (declare (type pathname pathname1)
269 (type pathname pathname2))
270 (or (eq pathname1 pathname2)
271 (and (eq (%pathname-host pathname1)
272 (%pathname-host pathname2))
273 (compare-component (%pathname-device pathname1)
274 (%pathname-device pathname2))
275 (compare-component (%pathname-directory pathname1)
276 (%pathname-directory pathname2))
277 (compare-component (%pathname-name pathname1)
278 (%pathname-name pathname2))
279 (compare-component (%pathname-type pathname1)
280 (%pathname-type pathname2))
281 (or (eq (%pathname-host pathname1) *unix-host*)
282 (compare-component (%pathname-version pathname1)
283 (%pathname-version pathname2))))))
285 ;;; Convert PATHNAME-DESIGNATOR (a pathname, or string, or
286 ;;; stream), into a pathname in pathname.
288 ;;; FIXME: was rewritten, should be tested (or rewritten again, this
289 ;;; time using ONCE-ONLY, *then* tested)
290 (eval-when (:compile-toplevel :execute)
291 (sb!xc:defmacro with-pathname ((pathname pathname-designator) &body body)
292 (let ((pd0 (gensym)))
293 `(let* ((,pd0 ,pathname-designator)
294 (,pathname (etypecase ,pd0
296 (string (parse-namestring ,pd0))
297 (file-stream (file-name ,pd0)))))
300 (sb!xc:defmacro with-native-pathname ((pathname pathname-designator) &body body)
301 (let ((pd0 (gensym)))
302 `(let* ((,pd0 ,pathname-designator)
303 (,pathname (etypecase ,pd0
305 (string (parse-native-namestring ,pd0))
308 (file-stream (file-name ,pd0)))))
311 (sb!xc:defmacro with-host ((host host-designator) &body body)
312 ;; Generally, redundant specification of information in software,
313 ;; whether in code or in comments, is bad. However, the ANSI spec
314 ;; for this is messy enough that it's hard to hold in short-term
315 ;; memory, so I've recorded these redundant notes on the
316 ;; implications of the ANSI spec.
318 ;; According to the ANSI spec, HOST can be a valid pathname host, or
319 ;; a logical host, or NIL.
321 ;; A valid pathname host can be a valid physical pathname host or a
322 ;; valid logical pathname host.
324 ;; A valid physical pathname host is "any of a string, a list of
325 ;; strings, or the symbol :UNSPECIFIC, that is recognized by the
326 ;; implementation as the name of a host". In SBCL as of 0.6.9.8,
327 ;; that means :UNSPECIFIC: though someday we might want to
328 ;; generalize it to allow strings like "RTFM.MIT.EDU" or lists like
329 ;; '("RTFM" "MIT" "EDU"), that's not supported now.
331 ;; A valid logical pathname host is a string which has been defined as
332 ;; the name of a logical host, as with LOAD-LOGICAL-PATHNAME-TRANSLATIONS.
334 ;; A logical host is an object of implementation-dependent nature. In
335 ;; SBCL, it's a member of the HOST class (a subclass of STRUCTURE-OBJECT).
336 (let ((hd0 (gensym)))
337 `(let* ((,hd0 ,host-designator)
338 (,host (etypecase ,hd0
340 ;; This is a special host. It's not valid as a
341 ;; logical host, so it is a sensible thing to
342 ;; designate the physical host object. So we do
346 ;; In general ANSI-compliant Common Lisps, a
347 ;; string might also be a physical pathname
348 ;; host, but ANSI leaves this up to the
349 ;; implementor, and in SBCL we don't do it, so
350 ;; it must be a logical host.
351 (find-logical-host ,hd0))
352 ((or null (member :unspecific))
353 ;; CLHS says that HOST=:UNSPECIFIC has
354 ;; implementation-defined behavior. We
355 ;; just turn it into NIL.
358 ;; ANSI also allows LISTs to designate hosts,
359 ;; but leaves its interpretation
360 ;; implementation-defined. Our interpretation
361 ;; is that it's unsupported.:-|
362 (error "A LIST representing a pathname host is not ~
363 supported in this implementation:~% ~S"
369 (defun find-host (host-designator &optional (errorp t))
370 (with-host (host host-designator)
371 (when (and errorp (not host))
372 (error "Couldn't find host: ~S" host-designator))
375 (defun pathname (pathspec)
377 "Convert PATHSPEC (a pathname designator) into a pathname."
378 (declare (type pathname-designator pathspec))
379 (with-pathname (pathname pathspec)
382 (defun native-pathname (pathspec)
384 "Convert PATHSPEC (a pathname designator) into a pathname, assuming
385 the operating system native pathname conventions."
386 (with-native-pathname (pathname pathspec)
389 ;;; Change the case of thing if DIDDLE-P.
390 (defun maybe-diddle-case (thing diddle-p)
391 (if (and diddle-p (not (or (symbolp thing) (integerp thing))))
392 (labels ((check-for (pred in)
395 (dolist (piece (pattern-pieces in))
396 (when (typecase piece
398 (check-for pred piece))
402 (check-for pred (cdr piece))))))
406 (when (check-for pred x)
409 (dotimes (i (length in))
410 (when (funcall pred (schar in i))
413 (diddle-with (fun thing)
417 (mapcar (lambda (piece)
425 (funcall fun (cdr piece))))
430 (pattern-pieces thing))))
437 (let ((any-uppers (check-for #'upper-case-p thing))
438 (any-lowers (check-for #'lower-case-p thing)))
439 (cond ((and any-uppers any-lowers)
440 ;; mixed case, stays the same
443 ;; all uppercase, becomes all lower case
444 (diddle-with (lambda (x) (if (stringp x)
448 ;; all lowercase, becomes all upper case
449 (diddle-with (lambda (x) (if (stringp x)
453 ;; no letters? I guess just leave it.
457 (defun merge-directories (dir1 dir2 diddle-case)
458 (if (or (eq (car dir1) :absolute)
463 (if (and (eq dir :back)
465 (not (member (car results)
466 '(:back :wild-inferiors :relative :absolute))))
468 (push dir results))))
469 (dolist (dir (maybe-diddle-case dir2 diddle-case))
471 (dolist (dir (cdr dir1))
475 (defun merge-pathnames (pathname
477 (defaults *default-pathname-defaults*)
478 (default-version :newest))
480 "Construct a filled in pathname by completing the unspecified components
482 (declare (type pathname-designator pathname)
483 (type pathname-designator defaults)
485 (with-pathname (defaults defaults)
486 (let ((pathname (let ((*default-pathname-defaults* defaults))
487 (pathname pathname))))
488 (let* ((default-host (%pathname-host defaults))
489 (pathname-host (%pathname-host pathname))
491 (and default-host pathname-host
492 (not (eq (host-customary-case default-host)
493 (host-customary-case pathname-host))))))
494 (%make-maybe-logical-pathname
495 (or pathname-host default-host)
496 (or (%pathname-device pathname)
497 (maybe-diddle-case (%pathname-device defaults)
499 (merge-directories (%pathname-directory pathname)
500 (%pathname-directory defaults)
502 (or (%pathname-name pathname)
503 (maybe-diddle-case (%pathname-name defaults)
505 (or (%pathname-type pathname)
506 (maybe-diddle-case (%pathname-type defaults)
508 (or (%pathname-version pathname)
509 (and (not (%pathname-name pathname)) (%pathname-version defaults))
510 default-version))))))
512 (defun import-directory (directory diddle-case)
515 ((member :wild) '(:absolute :wild-inferiors))
516 ((member :unspecific) '(:relative))
519 (let ((root (pop directory)))
520 (if (member root '(:relative :absolute))
522 (error "List of directory components must start with ~S or ~S."
523 :absolute :relative)))
525 (let ((next (pop directory)))
526 (if (or (eq :home next)
527 (typep next '(cons (eql :home) (cons string null))))
529 (push next directory)))
530 (dolist (piece directory)
531 (cond ((member piece '(:wild :wild-inferiors :up :back))
533 ((or (simple-string-p piece) (pattern-p piece))
534 (results (maybe-diddle-case piece diddle-case)))
536 (results (maybe-diddle-case (coerce piece 'simple-string)
539 (error "~S is not allowed as a directory component." piece)))))
542 `(:absolute ,(maybe-diddle-case directory diddle-case)))
545 ,(maybe-diddle-case (coerce directory 'simple-string) diddle-case)))))
547 (defun make-pathname (&key host
552 (version nil versionp)
556 "Makes a new pathname from the component arguments. Note that host is
557 a host-structure or string."
558 (declare (type (or string host pathname-component-tokens) host)
559 (type (or string pathname-component-tokens) device)
560 (type (or list string pattern pathname-component-tokens) directory)
561 (type (or string pattern pathname-component-tokens) name type)
562 (type (or integer pathname-component-tokens (member :newest))
564 (type (or pathname-designator null) defaults)
565 (type (member :common :local) case))
566 (let* ((defaults (when defaults
567 (with-pathname (defaults defaults) defaults)))
568 (default-host (if defaults
569 (%pathname-host defaults)
570 (pathname-host *default-pathname-defaults*)))
571 ;; Raymond Toy writes: CLHS says make-pathname can take a
572 ;; string (as a logical-host) for the host part. We map that
573 ;; string into the corresponding logical host structure.
575 ;; Paul Werkowski writes:
576 ;; HyperSpec says for the arg to MAKE-PATHNAME;
577 ;; "host---a valid physical pathname host. ..."
578 ;; where it probably means -- a valid pathname host.
579 ;; "valid pathname host n. a valid physical pathname host or
580 ;; a valid logical pathname host."
582 ;; "valid physical pathname host n. any of a string,
583 ;; a list of strings, or the symbol :unspecific,
584 ;; that is recognized by the implementation as the name of a host."
585 ;; "valid logical pathname host n. a string that has been defined
586 ;; as the name of a logical host. ..."
587 ;; HS is silent on what happens if the :HOST arg is NOT one of these.
588 ;; It seems an error message is appropriate.
589 (host (or (find-host host nil) default-host))
590 (diddle-args (and (eq (host-customary-case host) :lower)
593 (not (eq (host-customary-case host)
594 (host-customary-case default-host))))
595 (dev (if devp device (if defaults (%pathname-device defaults))))
596 (dir (import-directory directory diddle-args))
599 (defaults (%pathname-version defaults))
601 (when (and defaults (not dirp))
603 (merge-directories dir
604 (%pathname-directory defaults)
607 (macrolet ((pick (var varp field)
608 `(cond ((or (simple-string-p ,var)
610 (maybe-diddle-case ,var diddle-args))
612 (maybe-diddle-case (coerce ,var 'simple-string)
615 (maybe-diddle-case ,var diddle-args))
617 (maybe-diddle-case (,field defaults)
621 (%make-maybe-logical-pathname host
622 dev ; forced to :UNSPECIFIC when logical
624 (pick name namep %pathname-name)
625 (pick type typep %pathname-type)
628 (defun pathname-host (pathname &key (case :local))
630 "Return PATHNAME's host."
631 (declare (type pathname-designator pathname)
632 (type (member :local :common) case)
635 (with-pathname (pathname pathname)
636 (%pathname-host pathname)))
638 (defun pathname-device (pathname &key (case :local))
640 "Return PATHNAME's device."
641 (declare (type pathname-designator pathname)
642 (type (member :local :common) case))
643 (with-pathname (pathname pathname)
644 (maybe-diddle-case (%pathname-device pathname)
645 (and (eq case :common)
646 (eq (host-customary-case
647 (%pathname-host pathname))
650 (defun pathname-directory (pathname &key (case :local))
652 "Return PATHNAME's directory."
653 (declare (type pathname-designator pathname)
654 (type (member :local :common) case))
655 (with-pathname (pathname pathname)
656 (maybe-diddle-case (%pathname-directory pathname)
657 (and (eq case :common)
658 (eq (host-customary-case
659 (%pathname-host pathname))
661 (defun pathname-name (pathname &key (case :local))
663 "Return PATHNAME's name."
664 (declare (type pathname-designator pathname)
665 (type (member :local :common) case))
666 (with-pathname (pathname pathname)
667 (maybe-diddle-case (%pathname-name pathname)
668 (and (eq case :common)
669 (eq (host-customary-case
670 (%pathname-host pathname))
673 (defun pathname-type (pathname &key (case :local))
675 "Return PATHNAME's type."
676 (declare (type pathname-designator pathname)
677 (type (member :local :common) case))
678 (with-pathname (pathname pathname)
679 (maybe-diddle-case (%pathname-type pathname)
680 (and (eq case :common)
681 (eq (host-customary-case
682 (%pathname-host pathname))
685 (defun pathname-version (pathname)
687 "Return PATHNAME's version."
688 (declare (type pathname-designator pathname))
689 (with-pathname (pathname pathname)
690 (%pathname-version pathname)))
694 ;;; Handle the case for PARSE-NAMESTRING parsing a potentially
695 ;;; syntactically valid logical namestring with an explicit host.
697 ;;; This then isn't fully general -- we are relying on the fact that
698 ;;; we will only pass to parse-namestring namestring with an explicit
699 ;;; logical host, so that we can pass the host return from
700 ;;; parse-logical-namestring through to %PARSE-NAMESTRING as a truth
701 ;;; value. Yeah, this is probably a KLUDGE - CSR, 2002-04-18
702 (defun parseable-logical-namestring-p (namestr start end)
705 ((namestring-parse-error (lambda (c)
708 (let ((colon (position #\: namestr :start start :end end)))
710 (let ((potential-host
711 (logical-word-or-lose (subseq namestr start colon))))
712 ;; depending on the outcome of CSR comp.lang.lisp post
713 ;; "can PARSE-NAMESTRING create logical hosts", we may need
714 ;; to do things with potential-host (create it
715 ;; temporarily, parse the namestring and unintern the
716 ;; logical host potential-host on failure.
717 (declare (ignore potential-host))
720 ((simple-type-error (lambda (c)
723 (parse-logical-namestring namestr start end))))
724 ;; if we got this far, we should have an explicit host
725 ;; (first return value of parse-logical-namestring)
729 ;;; Handle the case where PARSE-NAMESTRING is actually parsing a
730 ;;; namestring. We pick off the :JUNK-ALLOWED case then find a host to
731 ;;; use for parsing, call the parser, then check whether the host matches.
732 (defun %parse-namestring (namestr host defaults start end junk-allowed)
733 (declare (type (or host null) host)
734 (type string namestr)
736 (type (or index null) end))
740 (%parse-namestring namestr host defaults start end nil)
741 (namestring-parse-error (condition)
742 (values nil (namestring-parse-error-offset condition)))))
744 (let* ((end (%check-vector-sequence-bounds namestr start end)))
745 (multiple-value-bind (new-host device directory file type version)
746 ;; Comments below are quotes from the HyperSpec
747 ;; PARSE-NAMESTRING entry, reproduced here to demonstrate
748 ;; that we actually have to do things this way rather than
749 ;; some possibly more logical way. - CSR, 2002-04-18
751 ;; "If host is a logical host then thing is parsed as a
752 ;; logical pathname namestring on the host."
753 (host (funcall (host-parse host) namestr start end))
754 ;; "If host is nil and thing is a syntactically valid
755 ;; logical pathname namestring containing an explicit
756 ;; host, then it is parsed as a logical pathname
758 ((parseable-logical-namestring-p namestr start end)
759 (parse-logical-namestring namestr start end))
760 ;; "If host is nil, default-pathname is a logical
761 ;; pathname, and thing is a syntactically valid logical
762 ;; pathname namestring without an explicit host, then it
763 ;; is parsed as a logical pathname namestring on the
764 ;; host that is the host component of default-pathname."
766 ;; "Otherwise, the parsing of thing is
767 ;; implementation-defined."
769 ;; Both clauses are handled here, as the default
770 ;; *DEFAULT-PATHNAME-DEFAULTS* has a SB-IMPL::UNIX-HOST
772 ((pathname-host defaults)
773 (funcall (host-parse (pathname-host defaults))
777 ;; I don't think we should ever get here, as the default
778 ;; host will always have a non-null HOST, given that we
779 ;; can't create a new pathname without going through
780 ;; *DEFAULT-PATHNAME-DEFAULTS*, which has a non-null
782 (t (bug "Fallen through COND in %PARSE-NAMESTRING")))
783 (when (and host new-host (not (eq new-host host)))
784 (error 'simple-type-error
786 ;; Note: ANSI requires that this be a TYPE-ERROR,
787 ;; but there seems to be no completely correct
788 ;; value to use for TYPE-ERROR-EXPECTED-TYPE.
789 ;; Instead, we return a sort of "type error allowed
790 ;; type", trying to say "it would be OK if you
791 ;; passed NIL as the host value" but not mentioning
792 ;; that a matching string would be OK too.
795 "The host in the namestring, ~S,~@
796 does not match the explicit HOST argument, ~S."
797 :format-arguments (list new-host host)))
798 (let ((pn-host (or new-host host (pathname-host defaults))))
799 (values (%make-maybe-logical-pathname
800 pn-host device directory file type version)
803 ;;; If NAMESTR begins with a colon-terminated, defined, logical host,
804 ;;; then return that host, otherwise return NIL.
805 (defun extract-logical-host-prefix (namestr start end)
806 (declare (type simple-string namestr)
807 (type index start end)
808 (values (or logical-host null)))
809 (let ((colon-pos (position #\: namestr :start start :end end)))
811 (values (gethash (nstring-upcase (subseq namestr start colon-pos))
815 (defun parse-namestring (thing
818 (defaults *default-pathname-defaults*)
819 &key (start 0) end junk-allowed)
820 (declare (type pathname-designator thing defaults)
821 (type (or list host string (member :unspecific)) host)
823 (type (or index null) end)
824 (type (or t null) junk-allowed)
825 (values (or null pathname) (or null index)))
826 (with-host (found-host host)
827 (let (;; According to ANSI defaults may be any valid pathname designator
828 (defaults (etypecase defaults
832 (aver (pathnamep *default-pathname-defaults*))
833 (parse-namestring defaults))
835 (truename defaults)))))
836 (declare (type pathname defaults))
839 (%parse-namestring thing found-host defaults start end junk-allowed))
841 (%parse-namestring (coerce thing 'simple-string)
842 found-host defaults start end junk-allowed))
844 (let ((defaulted-host (or found-host (%pathname-host defaults))))
845 (declare (type host defaulted-host))
846 (unless (eq defaulted-host (%pathname-host thing))
847 (error "The HOST argument doesn't match the pathname host:~% ~
849 defaulted-host (%pathname-host thing))))
850 (values thing start))
852 (let ((name (file-name thing)))
854 (error "can't figure out the file associated with stream:~% ~S"
856 (values name nil)))))))
858 (defun %parse-native-namestring (namestr host defaults start end junk-allowed
860 (declare (type (or host null) host)
861 (type string namestr)
863 (type (or index null) end))
867 (%parse-native-namestring namestr host defaults start end nil as-directory)
868 (namestring-parse-error (condition)
869 (values nil (namestring-parse-error-offset condition)))))
871 (let* ((end (%check-vector-sequence-bounds namestr start end)))
872 (multiple-value-bind (new-host device directory file type version)
875 (funcall (host-parse-native host) namestr start end as-directory))
876 ((pathname-host defaults)
877 (funcall (host-parse-native (pathname-host defaults))
882 ;; I don't think we should ever get here, as the default
883 ;; host will always have a non-null HOST, given that we
884 ;; can't create a new pathname without going through
885 ;; *DEFAULT-PATHNAME-DEFAULTS*, which has a non-null
887 (t (bug "Fallen through COND in %PARSE-NAMESTRING")))
888 (when (and host new-host (not (eq new-host host)))
889 (error 'simple-type-error
891 :expected-type `(or null (eql ,host))
893 "The host in the namestring, ~S,~@
894 does not match the explicit HOST argument, ~S."
895 :format-arguments (list new-host host)))
896 (let ((pn-host (or new-host host (pathname-host defaults))))
897 (values (%make-pathname
898 pn-host device directory file type version)
901 (defun parse-native-namestring (thing
904 (defaults *default-pathname-defaults*)
905 &key (start 0) end junk-allowed
908 "Convert THING into a pathname, using the native conventions
909 appropriate for the pathname host HOST, or if not specified the
910 host of DEFAULTS. If THING is a string, the parse is bounded by
911 START and END, and error behaviour is controlled by JUNK-ALLOWED,
912 as with PARSE-NAMESTRING. For file systems whose native
913 conventions allow directories to be indicated as files, if
914 AS-DIRECTORY is true, return a pathname denoting THING as a
916 (declare (type pathname-designator thing defaults)
917 (type (or list host string (member :unspecific)) host)
919 (type (or index null) end)
920 (type (or t null) junk-allowed)
921 (values (or null pathname) (or null index)))
922 (with-host (found-host host)
923 (let ((defaults (etypecase defaults
927 (aver (pathnamep *default-pathname-defaults*))
928 (parse-native-namestring defaults))
930 (truename defaults)))))
931 (declare (type pathname defaults))
934 (%parse-native-namestring
935 thing found-host defaults start end junk-allowed as-directory))
937 (%parse-native-namestring (coerce thing 'simple-string)
938 found-host defaults start end junk-allowed
941 (let ((defaulted-host (or found-host (%pathname-host defaults))))
942 (declare (type host defaulted-host))
943 (unless (eq defaulted-host (%pathname-host thing))
944 (error "The HOST argument doesn't match the pathname host:~% ~
946 defaulted-host (%pathname-host thing))))
947 (values thing start))
950 (let ((name (file-name thing)))
952 (error "can't figure out the file associated with stream:~% ~S"
954 (values name nil)))))))
956 (defun namestring (pathname)
958 "Construct the full (name)string form of the pathname."
959 (declare (type pathname-designator pathname))
960 (with-pathname (pathname pathname)
962 (let ((host (%pathname-host pathname)))
964 (error "can't determine the namestring for pathnames with no ~
965 host:~% ~S" pathname))
966 (funcall (host-unparse host) pathname)))))
968 (defun native-namestring (pathname &key as-file)
970 "Construct the full native (name)string form of PATHNAME. For
971 file systems whose native conventions allow directories to be
972 indicated as files, if AS-FILE is true and the name, type, and
973 version components of PATHNAME are all NIL or :UNSPECIFIC,
974 construct a string that names the directory according to the file
975 system's syntax for files."
976 (declare (type pathname-designator pathname))
977 (with-native-pathname (pathname pathname)
979 (let ((host (%pathname-host pathname)))
981 (error "can't determine the native namestring for pathnames with no ~
982 host:~% ~S" pathname))
983 (funcall (host-unparse-native host) pathname as-file)))))
985 (defun host-namestring (pathname)
987 "Return a string representation of the name of the host in the pathname."
988 (declare (type pathname-designator pathname))
989 (with-pathname (pathname pathname)
990 (let ((host (%pathname-host pathname)))
992 (funcall (host-unparse-host host) pathname)
994 "can't determine the namestring for pathnames with no host:~% ~S"
997 (defun directory-namestring (pathname)
999 "Return a string representation of the directories used in the pathname."
1000 (declare (type pathname-designator pathname))
1001 (with-pathname (pathname pathname)
1002 (let ((host (%pathname-host pathname)))
1004 (funcall (host-unparse-directory host) pathname)
1006 "can't determine the namestring for pathnames with no host:~% ~S"
1009 (defun file-namestring (pathname)
1011 "Return a string representation of the name used in the pathname."
1012 (declare (type pathname-designator pathname))
1013 (with-pathname (pathname pathname)
1014 (let ((host (%pathname-host pathname)))
1016 (funcall (host-unparse-file host) pathname)
1018 "can't determine the namestring for pathnames with no host:~% ~S"
1021 (defun enough-namestring (pathname
1023 (defaults *default-pathname-defaults*))
1025 "Return an abbreviated pathname sufficent to identify the pathname relative
1027 (declare (type pathname-designator pathname))
1028 (with-pathname (pathname pathname)
1029 (let ((host (%pathname-host pathname)))
1031 (with-pathname (defaults defaults)
1032 (funcall (host-unparse-enough host) pathname defaults))
1034 "can't determine the namestring for pathnames with no host:~% ~S"
1039 (defun wild-pathname-p (pathname &optional field-key)
1041 "Predicate for determining whether pathname contains any wildcards."
1042 (declare (type pathname-designator pathname)
1043 (type (member nil :host :device :directory :name :type :version)
1045 (with-pathname (pathname pathname)
1047 (or (pattern-p x) (member x '(:wild :wild-inferiors)))))
1050 (or (wild-pathname-p pathname :host)
1051 (wild-pathname-p pathname :device)
1052 (wild-pathname-p pathname :directory)
1053 (wild-pathname-p pathname :name)
1054 (wild-pathname-p pathname :type)
1055 (wild-pathname-p pathname :version)))
1056 (:host (frob (%pathname-host pathname)))
1057 (:device (frob (%pathname-host pathname)))
1058 (:directory (some #'frob (%pathname-directory pathname)))
1059 (:name (frob (%pathname-name pathname)))
1060 (:type (frob (%pathname-type pathname)))
1061 (:version (frob (%pathname-version pathname)))))))
1063 (defun pathname-match-p (in-pathname in-wildname)
1065 "Pathname matches the wildname template?"
1066 (declare (type pathname-designator in-pathname))
1067 (with-pathname (pathname in-pathname)
1068 (with-pathname (wildname in-wildname)
1069 (macrolet ((frob (field &optional (op 'components-match))
1070 `(or (null (,field wildname))
1071 (,op (,field pathname) (,field wildname)))))
1072 (and (or (null (%pathname-host wildname))
1073 (eq (%pathname-host wildname) (%pathname-host pathname)))
1074 (frob %pathname-device)
1075 (frob %pathname-directory directory-components-match)
1076 (frob %pathname-name)
1077 (frob %pathname-type)
1078 (or (eq (%pathname-host wildname) *physical-host*)
1079 (frob %pathname-version)))))))
1081 ;;; Place the substitutions into the pattern and return the string or pattern
1082 ;;; that results. If DIDDLE-CASE is true, we diddle the result case as well,
1083 ;;; in case we are translating between hosts with difference conventional case.
1084 ;;; The second value is the tail of subs with all of the values that we used up
1085 ;;; stripped off. Note that PATTERN-MATCHES matches all consecutive wildcards
1086 ;;; as a single string, so we ignore subsequent contiguous wildcards.
1087 (defun substitute-into (pattern subs diddle-case)
1088 (declare (type pattern pattern)
1090 (values (or simple-string pattern) list))
1091 (let ((in-wildcard nil)
1094 (dolist (piece (pattern-pieces pattern))
1095 (cond ((simple-string-p piece)
1096 (push piece strings)
1097 (setf in-wildcard nil))
1100 (setf in-wildcard t)
1102 (error "not enough wildcards in FROM pattern to match ~
1105 (let ((sub (pop subs)))
1109 (push (apply #'concatenate 'simple-string
1112 (dolist (piece (pattern-pieces sub))
1113 (push piece pieces)))
1117 (error "can't substitute this into the middle of a word:~
1122 (push (apply #'concatenate 'simple-string (nreverse strings))
1126 (if (and pieces (simple-string-p (car pieces)) (null (cdr pieces)))
1128 (make-pattern (nreverse pieces)))
1132 ;;; Called when we can't see how source and from matched.
1133 (defun didnt-match-error (source from)
1134 (error "Pathname components from SOURCE and FROM args to TRANSLATE-PATHNAME~@
1135 did not match:~% ~S ~S"
1138 ;;; Do TRANSLATE-COMPONENT for all components except host, directory
1140 (defun translate-component (source from to diddle-case)
1147 (if (pattern= from source)
1149 (didnt-match-error source from)))
1151 (multiple-value-bind (won subs) (pattern-matches from source)
1153 (values (substitute-into to subs diddle-case))
1154 (didnt-match-error source from))))
1156 (maybe-diddle-case source diddle-case))))
1158 (values (substitute-into to (list source) diddle-case)))
1160 (if (components-match source from)
1161 (maybe-diddle-case source diddle-case)
1162 (didnt-match-error source from)))))
1164 (maybe-diddle-case source diddle-case))
1166 (if (components-match source from)
1168 (didnt-match-error source from)))))
1170 ;;; Return a list of all the things that we want to substitute into the TO
1171 ;;; pattern (the things matched by from on source.) When From contains
1172 ;;; :WILD-INFERIORS, the result contains a sublist of the matched source
1174 (defun compute-directory-substitutions (orig-source orig-from)
1175 (let ((source orig-source)
1180 (unless (every (lambda (x) (eq x :wild-inferiors)) from)
1181 (didnt-match-error orig-source orig-from))
1184 (unless from (didnt-match-error orig-source orig-from))
1185 (let ((from-part (pop from))
1186 (source-part (pop source)))
1189 (typecase source-part
1191 (if (pattern= from-part source-part)
1193 (didnt-match-error orig-source orig-from)))
1195 (multiple-value-bind (won new-subs)
1196 (pattern-matches from-part source-part)
1198 (dolist (sub new-subs)
1200 (didnt-match-error orig-source orig-from))))
1202 (didnt-match-error orig-source orig-from))))
1205 ((member :wild-inferiors)
1206 (let ((remaining-source (cons source-part source)))
1209 (when (directory-components-match remaining-source from)
1211 (unless remaining-source
1212 (didnt-match-error orig-source orig-from))
1213 (res (pop remaining-source)))
1215 (setq source remaining-source))))
1217 (unless (and (simple-string-p source-part)
1218 (string= from-part source-part))
1219 (didnt-match-error orig-source orig-from)))
1221 (didnt-match-error orig-source orig-from)))))
1224 ;;; This is called by TRANSLATE-PATHNAME on the directory components
1225 ;;; of its argument pathnames to produce the result directory
1226 ;;; component. If this leaves the directory NIL, we return the source
1227 ;;; directory. The :RELATIVE or :ABSOLUTE is taken from the source
1228 ;;; directory, except if TO is :ABSOLUTE, in which case the result
1229 ;;; will be :ABSOLUTE.
1230 (defun translate-directories (source from to diddle-case)
1231 (if (not (and source to from))
1232 (or (and to (null source) (remove :wild-inferiors to))
1233 (mapcar (lambda (x) (maybe-diddle-case x diddle-case)) source))
1235 ;; If TO is :ABSOLUTE, the result should still be :ABSOLUTE.
1236 (res (if (eq (first to) :absolute)
1239 (let ((subs-left (compute-directory-substitutions (rest source)
1241 (dolist (to-part (rest to))
1245 (let ((match (pop subs-left)))
1247 (error ":WILD-INFERIORS is not paired in from and to ~
1248 patterns:~% ~S ~S" from to))
1249 (res (maybe-diddle-case match diddle-case))))
1250 ((member :wild-inferiors)
1252 (let ((match (pop subs-left)))
1253 (unless (listp match)
1254 (error ":WILD-INFERIORS not paired in from and to ~
1255 patterns:~% ~S ~S" from to))
1257 (res (maybe-diddle-case x diddle-case)))))
1259 (multiple-value-bind
1261 (substitute-into to-part subs-left diddle-case)
1262 (setf subs-left new-subs-left)
1264 (t (res to-part)))))
1267 (defun translate-pathname (source from-wildname to-wildname &key)
1269 "Use the source pathname to translate the from-wildname's wild and
1270 unspecified elements into a completed to-pathname based on the to-wildname."
1271 (declare (type pathname-designator source from-wildname to-wildname))
1272 (with-pathname (source source)
1273 (with-pathname (from from-wildname)
1274 (with-pathname (to to-wildname)
1275 (let* ((source-host (%pathname-host source))
1276 (from-host (%pathname-host from))
1277 (to-host (%pathname-host to))
1279 (and source-host to-host
1280 (not (eq (host-customary-case source-host)
1281 (host-customary-case to-host))))))
1282 (macrolet ((frob (field &optional (op 'translate-component))
1283 `(let ((result (,op (,field source)
1287 (if (eq result :error)
1288 (error "~S doesn't match ~S." source from)
1290 (%make-maybe-logical-pathname
1291 (or to-host source-host)
1292 (frob %pathname-device)
1293 (frob %pathname-directory translate-directories)
1294 (frob %pathname-name)
1295 (frob %pathname-type)
1296 (if (eq from-host *unix-host*)
1297 (if (or (eq (%pathname-version to) :wild)
1298 (eq (%pathname-version to) nil))
1299 (%pathname-version source)
1300 (%pathname-version to))
1301 (frob %pathname-version)))))))))
1303 ;;;; logical pathname support. ANSI 92-102 specification.
1305 ;;;; As logical-pathname translations are loaded they are
1306 ;;;; canonicalized as patterns to enable rapid efficient translation
1307 ;;;; into physical pathnames.
1311 (defun simplify-namestring (namestring &optional host)
1312 (funcall (host-simplify-namestring
1314 (pathname-host (sane-default-pathname-defaults))))
1317 ;;; Canonicalize a logical pathname word by uppercasing it checking that it
1318 ;;; contains only legal characters.
1319 (defun logical-word-or-lose (word)
1320 (declare (string word))
1321 (when (string= word "")
1322 (error 'namestring-parse-error
1323 :complaint "Attempted to treat invalid logical hostname ~
1324 as a logical host:~% ~S"
1326 :namestring word :offset 0))
1327 (let ((word (string-upcase word)))
1328 (dotimes (i (length word))
1329 (let ((ch (schar word i)))
1330 (unless (and (typep ch 'standard-char)
1331 (or (alpha-char-p ch) (digit-char-p ch) (char= ch #\-)))
1332 (error 'namestring-parse-error
1333 :complaint "logical namestring character which ~
1334 is not alphanumeric or hyphen:~% ~S"
1336 :namestring word :offset i))))
1337 (coerce word 'string))) ; why not simple-string?
1339 ;;; Given a logical host or string, return a logical host. If ERROR-P
1340 ;;; is NIL, then return NIL when no such host exists.
1341 (defun find-logical-host (thing &optional (errorp t))
1344 (let ((found (gethash (logical-word-or-lose thing)
1346 (if (or found (not errorp))
1348 ;; This is the error signalled from e.g.
1349 ;; LOGICAL-PATHNAME-TRANSLATIONS when host is not a defined
1350 ;; host, and ANSI specifies that that's a TYPE-ERROR.
1351 (error 'simple-type-error
1353 ;; God only knows what ANSI expects us to use for
1354 ;; the EXPECTED-TYPE here. Maybe this will be OK..
1356 '(and string (satisfies logical-pathname-translations))
1357 :format-control "logical host not yet defined: ~S"
1358 :format-arguments (list thing)))))
1359 (logical-host thing)))
1361 ;;; Given a logical host name or host, return a logical host, creating
1362 ;;; a new one if necessary.
1363 (defun intern-logical-host (thing)
1364 (declare (values logical-host))
1365 (with-locked-system-table (*logical-hosts*)
1366 (or (find-logical-host thing nil)
1367 (let* ((name (logical-word-or-lose thing))
1368 (new (make-logical-host :name name)))
1369 (setf (gethash name *logical-hosts*) new)
1372 ;;;; logical pathname parsing
1374 ;;; Deal with multi-char wildcards in a logical pathname token.
1375 (defun maybe-make-logical-pattern (namestring chunks)
1376 (let ((chunk (caar chunks)))
1377 (collect ((pattern))
1379 (len (length chunk)))
1380 (declare (fixnum last-pos))
1382 (when (= last-pos len) (return))
1383 (let ((pos (or (position #\* chunk :start last-pos) len)))
1384 (if (= pos last-pos)
1386 (error 'namestring-parse-error
1387 :complaint "double asterisk inside of logical ~
1390 :namestring namestring
1391 :offset (+ (cdar chunks) pos)))
1392 (pattern (subseq chunk last-pos pos)))
1395 (pattern :multi-char-wild))
1396 (setq last-pos (1+ pos)))))
1399 (make-pattern (pattern))
1400 (let ((x (car (pattern))))
1401 (if (eq x :multi-char-wild)
1405 ;;; Return a list of conses where the CDR is the start position and
1406 ;;; the CAR is a string (token) or character (punctuation.)
1407 (defun logical-chunkify (namestr start end)
1409 (do ((i start (1+ i))
1413 (chunks (cons (nstring-upcase (subseq namestr prev end)) prev))))
1414 (let ((ch (schar namestr i)))
1415 (unless (or (alpha-char-p ch) (digit-char-p ch)
1416 (member ch '(#\- #\*)))
1418 (chunks (cons (nstring-upcase (subseq namestr prev i)) prev)))
1420 (unless (member ch '(#\; #\: #\.))
1421 (error 'namestring-parse-error
1422 :complaint "illegal character for logical pathname:~% ~S"
1426 (chunks (cons ch i)))))
1429 ;;; Break up a logical-namestring, always a string, into its
1430 ;;; constituent parts.
1431 (defun parse-logical-namestring (namestr start end)
1432 (declare (type simple-string namestr)
1433 (type index start end))
1434 (collect ((directory))
1439 (labels ((expecting (what chunks)
1440 (unless (and chunks (simple-string-p (caar chunks)))
1441 (error 'namestring-parse-error
1442 :complaint "expecting ~A, got ~:[nothing~;~S~]."
1443 :args (list what (caar chunks) (caar chunks))
1445 :offset (if chunks (cdar chunks) end)))
1447 (parse-host (chunks)
1448 (case (caadr chunks)
1451 (find-logical-host (expecting "a host name" chunks)))
1452 (parse-relative (cddr chunks)))
1454 (parse-relative chunks))))
1455 (parse-relative (chunks)
1458 (directory :relative)
1459 (parse-directory (cdr chunks)))
1461 (directory :absolute) ; Assumption! Maybe revoked later.
1462 (parse-directory chunks))))
1463 (parse-directory (chunks)
1464 (case (caadr chunks)
1467 (let ((res (expecting "a directory name" chunks)))
1468 (cond ((string= res "..") :up)
1469 ((string= res "**") :wild-inferiors)
1471 (maybe-make-logical-pattern namestr chunks)))))
1472 (parse-directory (cddr chunks)))
1474 (parse-name chunks))))
1475 (parse-name (chunks)
1477 (expecting "a file name" chunks)
1478 (setq name (maybe-make-logical-pattern namestr chunks))
1479 (expecting-dot (cdr chunks))))
1480 (expecting-dot (chunks)
1482 (unless (eql (caar chunks) #\.)
1483 (error 'namestring-parse-error
1484 :complaint "expecting a dot, got ~S."
1485 :args (list (caar chunks))
1487 :offset (cdar chunks)))
1489 (parse-version (cdr chunks))
1490 (parse-type (cdr chunks)))))
1491 (parse-type (chunks)
1492 (expecting "a file type" chunks)
1493 (setq type (maybe-make-logical-pattern namestr chunks))
1494 (expecting-dot (cdr chunks)))
1495 (parse-version (chunks)
1496 (let ((str (expecting "a positive integer, * or NEWEST"
1499 ((string= str "*") (setq version :wild))
1500 ((string= str "NEWEST") (setq version :newest))
1502 (multiple-value-bind (res pos)
1503 (parse-integer str :junk-allowed t)
1504 (unless (and res (plusp res))
1505 (error 'namestring-parse-error
1506 :complaint "expected a positive integer, ~
1510 :offset (+ pos (cdar chunks))))
1511 (setq version res)))))
1513 (error 'namestring-parse-error
1514 :complaint "extra stuff after end of file name"
1516 :offset (cdadr chunks)))))
1517 (parse-host (logical-chunkify namestr start end)))
1518 (values host :unspecific (directory) name type version))))
1520 ;;; We can't initialize this yet because not all host methods are
1522 (defvar *logical-pathname-defaults*)
1524 (defun logical-namestring-p (x)
1527 (typep (pathname x) 'logical-pathname))))
1529 (deftype logical-namestring ()
1530 `(satisfies logical-namestring-p))
1532 (defun logical-pathname (pathspec)
1534 "Converts the pathspec argument to a logical-pathname and returns it."
1535 (declare (type (or logical-pathname string stream) pathspec)
1536 (values logical-pathname))
1537 (if (typep pathspec 'logical-pathname)
1539 (flet ((oops (problem)
1540 (error 'simple-type-error
1542 :expected-type 'logical-namestring
1543 :format-control "~S is not a valid logical namestring:~% ~A"
1544 :format-arguments (list pathspec problem))))
1545 (let ((res (handler-case
1546 (parse-namestring pathspec nil *logical-pathname-defaults*)
1547 (error (e) (oops e)))))
1548 (when (eq (%pathname-host res)
1549 (%pathname-host *logical-pathname-defaults*))
1550 (oops "no host specified"))
1553 ;;;; logical pathname unparsing
1555 (defun unparse-logical-directory (pathname)
1556 (declare (type pathname pathname))
1558 (let ((directory (%pathname-directory pathname)))
1560 (ecase (pop directory)
1561 (:absolute) ; nothing special
1562 (:relative (pieces ";")))
1563 (dolist (dir directory)
1564 (cond ((or (stringp dir) (pattern-p dir))
1565 (pieces (unparse-logical-piece dir))
1569 ((eq dir :wild-inferiors)
1572 (error "invalid directory component: ~S" dir))))))
1573 (apply #'concatenate 'simple-string (pieces))))
1575 (defun unparse-logical-piece (thing)
1577 ((member :wild) "*")
1578 (simple-string thing)
1580 (collect ((strings))
1581 (dolist (piece (pattern-pieces thing))
1583 (simple-string (strings piece))
1585 (cond ((eq piece :wild-inferiors)
1587 ((eq piece :multi-char-wild)
1589 (t (error "invalid keyword: ~S" piece))))))
1590 (apply #'concatenate 'simple-string (strings))))))
1592 (defun unparse-logical-file (pathname)
1593 (declare (type pathname pathname))
1594 (collect ((strings))
1595 (let* ((name (%pathname-name pathname))
1596 (type (%pathname-type pathname))
1597 (version (%pathname-version pathname))
1598 (type-supplied (not (or (null type) (eq type :unspecific))))
1599 (version-supplied (not (or (null version)
1600 (eq version :unspecific)))))
1602 (when (and (null type)
1603 (typep name 'string)
1604 (position #\. name :start 1))
1605 (error "too many dots in the name: ~S" pathname))
1606 (strings (unparse-logical-piece name)))
1609 (error "cannot specify the type without a file: ~S" pathname))
1610 (when (typep type 'string)
1611 (when (position #\. type)
1612 (error "type component can't have a #\. inside: ~S" pathname)))
1614 (strings (unparse-logical-piece type)))
1615 (when version-supplied
1616 (unless type-supplied
1617 (error "cannot specify the version without a type: ~S" pathname))
1619 ((member :newest) (strings ".NEWEST"))
1620 ((member :wild) (strings ".*"))
1621 (fixnum (strings ".") (strings (format nil "~D" version))))))
1622 (apply #'concatenate 'simple-string (strings))))
1624 ;;; Unparse a logical pathname string.
1625 (defun unparse-enough-namestring (pathname defaults)
1626 (let* ((path-directory (pathname-directory pathname))
1627 (def-directory (pathname-directory defaults))
1629 ;; Go down the directory lists to see what matches. What's
1630 ;; left is what we want, more or less.
1631 (cond ((and (eq (first path-directory) (first def-directory))
1632 (eq (first path-directory) :absolute))
1633 ;; Both paths are :ABSOLUTE, so find where the
1634 ;; common parts end and return what's left
1635 (do* ((p (rest path-directory) (rest p))
1636 (d (rest def-directory) (rest d)))
1637 ((or (endp p) (endp d)
1638 (not (equal (first p) (first d))))
1641 ;; At least one path is :RELATIVE, so just return the
1642 ;; original path. If the original path is :RELATIVE,
1643 ;; then that's the right one. If PATH-DIRECTORY is
1644 ;; :ABSOLUTE, we want to return that except when
1645 ;; DEF-DIRECTORY is :ABSOLUTE, as handled above. so return
1646 ;; the original directory.
1648 (unparse-logical-namestring
1649 (make-pathname :host (pathname-host pathname)
1650 :directory enough-directory
1651 :name (pathname-name pathname)
1652 :type (pathname-type pathname)
1653 :version (pathname-version pathname)))))
1655 (defun unparse-logical-namestring (pathname)
1656 (declare (type logical-pathname pathname))
1657 (concatenate 'simple-string
1658 (logical-host-name (%pathname-host pathname)) ":"
1659 (unparse-logical-directory pathname)
1660 (unparse-logical-file pathname)))
1662 ;;;; logical pathname translations
1664 ;;; Verify that the list of translations consists of lists and prepare
1665 ;;; canonical translations. (Parse pathnames and expand out wildcards
1667 (defun canonicalize-logical-pathname-translations (translation-list host)
1668 (declare (type list translation-list) (type host host)
1670 (mapcar (lambda (translation)
1671 (destructuring-bind (from to) translation
1672 (list (if (typep from 'logical-pathname)
1674 (parse-namestring from host))
1678 (defun logical-pathname-translations (host)
1680 "Return the (logical) host object argument's list of translations."
1681 (declare (type (or string logical-host) host)
1683 (logical-host-translations (find-logical-host host)))
1685 (defun (setf logical-pathname-translations) (translations host)
1687 "Set the translations list for the logical host argument."
1688 (declare (type (or string logical-host) host)
1689 (type list translations)
1691 (let ((host (intern-logical-host host)))
1692 (setf (logical-host-canon-transls host)
1693 (canonicalize-logical-pathname-translations translations host))
1694 (setf (logical-host-translations host) translations)))
1696 (defun translate-logical-pathname (pathname &key)
1698 "Translate PATHNAME to a physical pathname, which is returned."
1699 (declare (type pathname-designator pathname)
1700 (values (or null pathname)))
1703 (dolist (x (logical-host-canon-transls (%pathname-host pathname))
1704 (error 'simple-file-error
1706 :format-control "no translation for ~S"
1707 :format-arguments (list pathname)))
1708 (destructuring-bind (from to) x
1709 (when (pathname-match-p pathname from)
1710 (return (translate-logical-pathname
1711 (translate-pathname pathname from to)))))))
1713 (t (translate-logical-pathname (pathname pathname)))))
1715 (defvar *logical-pathname-defaults*
1716 (%make-logical-pathname
1717 (make-logical-host :name (logical-word-or-lose "BOGUS"))
1718 :unspecific nil nil nil nil))
1720 (defun load-logical-pathname-translations (host)
1722 "Reads logical pathname translations from SYS:SITE;HOST.TRANSLATIONS.NEWEST,
1723 with HOST replaced by the supplied parameter. Returns T on success.
1725 If HOST is already defined as logical pathname host, no file is loaded and NIL
1728 The file should contain a single form, suitable for use with
1729 \(SETF LOGICAL-PATHNAME-TRANSLATIONS).
1731 Note: behaviour of this function is higly implementation dependent, and
1732 historically it used to be a no-op in SBcL -- the current approach is somewhat
1733 experimental and subject to change."
1734 (declare (type string host)
1735 (values (member t nil)))
1736 (if (find-logical-host host nil)
1737 ;; This host is already defined, all is well and good.
1739 ;; ANSI: "The specific nature of the search is
1740 ;; implementation-defined."
1742 (setf (logical-pathname-translations host)
1743 (with-open-file (lpt (make-pathname :host "SYS"
1744 :directory '(:absolute "SITE")
1746 :type "TRANSLATIONS"
1750 (defun !pathname-cold-init ()
1751 (let* ((sys *default-pathname-defaults*)
1754 (make-pathname :directory '(:relative "src" :wild-inferiors)
1755 :name :wild :type :wild)
1759 (make-pathname :directory '(:relative "contrib" :wild-inferiors)
1760 :name :wild :type :wild)
1764 (make-pathname :directory '(:relative "output" :wild-inferiors)
1765 :name :wild :type :wild)
1767 (setf (logical-pathname-translations "SYS")
1768 `(("SYS:SRC;**;*.*.*" ,src)
1769 ("SYS:CONTRIB;**;*.*.*" ,contrib)
1770 ("SYS:OUTPUT;**;*.*.*" ,output)))))
1772 (defun set-sbcl-source-location (pathname)
1773 "Initialize the SYS logical host based on PATHNAME, which should be
1774 the top-level directory of the SBCL sources. This will replace any
1775 existing translations for \"SYS:SRC;\", \"SYS:CONTRIB;\", and
1776 \"SYS:OUTPUT;\". Other \"SYS:\" translations are preserved."
1777 (let ((truename (truename pathname))
1778 (current-translations
1779 (remove-if (lambda (translation)
1780 (or (pathname-match-p "SYS:SRC;" translation)
1781 (pathname-match-p "SYS:CONTRIB;" translation)
1782 (pathname-match-p "SYS:OUTPUT;" translation)))
1783 (logical-pathname-translations "SYS")
1785 (flet ((physical-target (component)
1787 (make-pathname :directory (list :relative component
1792 (setf (logical-pathname-translations "SYS")
1793 `(("SYS:SRC;**;*.*.*" ,(physical-target "src"))
1794 ("SYS:CONTRIB;**;*.*.*" ,(physical-target "contrib"))
1795 ("SYS:OUTPUT;**;*.*.*" ,(physical-target "output"))
1796 ,@current-translations)))))