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!method print-object ((host host) stream)
19 (print-unreadable-object (host stream :type t :identity t)))
23 (def!method print-object ((pathname pathname) stream)
24 (let ((namestring (handler-case (namestring pathname)
27 (format stream "#P~S" namestring)
28 (print-unreadable-object (pathname stream :type t)
30 "~@<(with no namestring) ~_:HOST ~S ~_:DEVICE ~S ~_:DIRECTORY ~S ~
31 ~_:NAME ~S ~_:TYPE ~S ~_:VERSION ~S~:>"
32 (%pathname-host pathname)
33 (%pathname-device pathname)
34 (%pathname-directory pathname)
35 (%pathname-name pathname)
36 (%pathname-type pathname)
37 (%pathname-version pathname))))))
39 (def!method make-load-form ((pathname pathname) &optional environment)
40 (make-load-form-saving-slots pathname :environment environment))
42 ;;; The potential conflict with search lists requires isolating the
43 ;;; printed representation to use the i/o macro #.(logical-pathname
44 ;;; <path-designator>).
46 ;;; FIXME: We don't use search lists any more, so that comment is
48 (def!method print-object ((pathname logical-pathname) stream)
49 (let ((namestring (handler-case (namestring pathname)
52 (format stream "#.(CL:LOGICAL-PATHNAME ~S)" namestring)
53 (print-unreadable-object (pathname stream :type t)
56 "~_:HOST ~S ~_:DIRECTORY ~S ~_:FILE ~S ~_:NAME ~S ~_:VERSION ~S"
57 (%pathname-host pathname)
58 (%pathname-directory pathname)
59 (%pathname-name pathname)
60 (%pathname-type pathname)
61 (%pathname-version pathname))))))
63 ;;; A pathname is logical if the host component is a logical host.
64 ;;; This constructor is used to make an instance of the correct type
65 ;;; from parsed arguments.
66 (defun %make-maybe-logical-pathname (host device directory name type version)
67 ;; We canonicalize logical pathname components to uppercase. ANSI
68 ;; doesn't strictly require this, leaving it up to the implementor;
69 ;; but the arguments given in the X3J13 cleanup issue
70 ;; PATHNAME-LOGICAL:ADD seem compelling: we should canonicalize the
71 ;; case, and uppercase is the ordinary way to do that.
72 (flet ((upcase-maybe (x) (typecase x (string (logical-word-or-lose x)) (t x))))
73 (if (typep host 'logical-host)
74 (%make-logical-pathname host
76 (mapcar #'upcase-maybe directory)
80 (%make-pathname host device directory name type version))))
82 ;;; Hash table searching maps a logical pathname's host to its
83 ;;; physical pathname translation.
84 (defvar *logical-hosts* (make-hash-table :test 'equal))
88 (def!method make-load-form ((pattern pattern) &optional environment)
89 (make-load-form-saving-slots pattern :environment environment))
91 (def!method print-object ((pattern pattern) stream)
92 (print-unreadable-object (pattern stream :type t)
94 (let ((*print-escape* t))
95 (pprint-fill stream (pattern-pieces pattern) nil))
96 (prin1 (pattern-pieces pattern) stream))))
98 (defun pattern= (pattern1 pattern2)
99 (declare (type pattern pattern1 pattern2))
100 (let ((pieces1 (pattern-pieces pattern1))
101 (pieces2 (pattern-pieces pattern2)))
102 (and (= (length pieces1) (length pieces2))
103 (every #'(lambda (piece1 piece2)
106 (and (simple-string-p piece2)
107 (string= piece1 piece2)))
110 (eq (car piece1) (car piece2))
111 (string= (cdr piece1) (cdr piece2))))
113 (eq piece1 piece2))))
117 ;;; If the string matches the pattern returns the multiple values T and a
118 ;;; list of the matched strings.
119 (defun pattern-matches (pattern string)
120 (declare (type pattern pattern)
121 (type simple-string string))
122 (let ((len (length string)))
123 (labels ((maybe-prepend (subs cur-sub chars)
125 (let* ((len (length chars))
126 (new (make-string len))
129 (setf (schar new (decf index)) char))
132 (matches (pieces start subs cur-sub chars)
135 (values t (maybe-prepend subs cur-sub chars))
137 (let ((piece (car pieces)))
140 (let ((end (+ start (length piece))))
142 (string= piece string
143 :start2 start :end2 end)
144 (matches (cdr pieces) end
145 (maybe-prepend subs cur-sub chars)
151 (let ((char (schar string start)))
152 (if (find char (cdr piece) :test #'char=)
153 (matches (cdr pieces) (1+ start) subs t
154 (cons char chars))))))))
155 ((member :single-char-wild)
157 (matches (cdr pieces) (1+ start) subs t
158 (cons (schar string start) chars))))
159 ((member :multi-char-wild)
160 (multiple-value-bind (won new-subs)
161 (matches (cdr pieces) start subs t chars)
165 (matches pieces (1+ start) subs t
166 (cons (schar string start)
168 (multiple-value-bind (won subs)
169 (matches (pattern-pieces pattern) 0 nil nil nil)
170 (values won (reverse subs))))))
172 ;;; PATHNAME-MATCH-P for directory components
173 (defun directory-components-match (thing wild)
176 ;; If THING has a null directory, assume that it matches
177 ;; (:ABSOLUTE :WILD-INFERIORS) or (:RELATIVE :WILD-INFERIORS).
180 (member (first wild) '(:absolute :relative))
181 (eq (second wild) :wild-inferiors))
183 (let ((wild1 (first wild)))
184 (if (eq wild1 :wild-inferiors)
185 (let ((wild-subdirs (rest wild)))
186 (or (null wild-subdirs)
188 (when (directory-components-match thing wild-subdirs)
191 (unless thing (return nil)))))
193 (components-match (first thing) wild1)
194 (directory-components-match (rest thing)
197 ;;; Return true if pathname component THING is matched by WILD. (not
199 (defun components-match (thing wild)
200 (declare (type (or pattern symbol simple-string integer) thing wild))
205 ;; String is matched by itself, a matching pattern or :WILD.
208 (values (pattern-matches wild thing)))
210 (string= thing wild))))
212 ;; A pattern is only matched by an identical pattern.
213 (and (pattern-p wild) (pattern= thing wild)))
215 ;; An integer (version number) is matched by :WILD or the
216 ;; same integer. This branch will actually always be NIL as
217 ;; long as the version is a fixnum.
220 ;;; a predicate for comparing two pathname slot component sub-entries
221 (defun compare-component (this that)
225 (and (simple-string-p that)
226 (string= this that)))
228 (and (pattern-p that)
229 (pattern= this that)))
232 (compare-component (car this) (car that))
233 (compare-component (cdr this) (cdr that)))))))
235 ;;;; pathname functions
237 (defun pathname= (pathname1 pathname2)
238 (declare (type pathname pathname1)
239 (type pathname pathname2))
240 (and (eq (%pathname-host pathname1)
241 (%pathname-host pathname2))
242 (compare-component (%pathname-device pathname1)
243 (%pathname-device pathname2))
244 (compare-component (%pathname-directory pathname1)
245 (%pathname-directory pathname2))
246 (compare-component (%pathname-name pathname1)
247 (%pathname-name pathname2))
248 (compare-component (%pathname-type pathname1)
249 (%pathname-type pathname2))
250 (compare-component (%pathname-version pathname1)
251 (%pathname-version pathname2))))
253 ;;; Convert PATHNAME-DESIGNATOR (a pathname, or string, or
254 ;;; stream), into a pathname in pathname.
256 ;;; FIXME: was rewritten, should be tested (or rewritten again, this
257 ;;; time using ONCE-ONLY, *then* tested)
258 ;;; FIXME: become SB!XC:DEFMACRO inside EVAL-WHEN (COMPILE EVAL)?
259 (defmacro with-pathname ((pathname pathname-designator) &body body)
260 (let ((pd0 (gensym)))
261 `(let* ((,pd0 ,pathname-designator)
262 (,pathname (etypecase ,pd0
264 (string (parse-namestring ,pd0))
265 (stream (file-name ,pd0)))))
268 ;;; Convert the var, a host or string name for a host, into a
269 ;;; LOGICAL-HOST structure or nil if not defined.
271 ;;; pw notes 1/12/97 this potentially useful macro is not used anywhere
272 ;;; and 'find-host' is not defined. 'find-logical-host' seems to be needed.
274 (defmacro with-host ((var expr) &body body)
275 `(let ((,var (let ((,var ,expr))
278 (string (find-logical-host ,var nil))
283 (defun pathname (thing)
285 "Convert thing (a pathname, string or stream) into a pathname."
286 (declare (type pathname-designator thing))
287 (with-pathname (pathname thing)
290 ;;; Change the case of thing if DIDDLE-P.
291 (defun maybe-diddle-case (thing diddle-p)
292 (if (and diddle-p (not (or (symbolp thing) (integerp thing))))
293 (labels ((check-for (pred in)
296 (dolist (piece (pattern-pieces in))
297 (when (typecase piece
299 (check-for pred piece))
303 (check-for pred (cdr in))))))
307 (when (check-for pred x)
310 (dotimes (i (length in))
311 (when (funcall pred (schar in i))
314 (diddle-with (fun thing)
318 (mapcar #'(lambda (piece)
326 (funcall fun (cdr piece))))
331 (pattern-pieces thing))))
338 (let ((any-uppers (check-for #'upper-case-p thing))
339 (any-lowers (check-for #'lower-case-p thing)))
340 (cond ((and any-uppers any-lowers)
341 ;; Mixed case, stays the same.
344 ;; All uppercase, becomes all lower case.
345 (diddle-with #'(lambda (x) (if (stringp x)
349 ;; All lowercase, becomes all upper case.
350 (diddle-with #'(lambda (x) (if (stringp x)
354 ;; No letters? I guess just leave it.
358 (defun merge-directories (dir1 dir2 diddle-case)
359 (if (or (eq (car dir1) :absolute)
364 (if (and (eq dir :back)
366 (not (eq (car results) :back)))
368 (push dir results))))
369 (dolist (dir (maybe-diddle-case dir2 diddle-case))
371 (dolist (dir (cdr dir1))
375 (defun merge-pathnames (pathname
377 (defaults *default-pathname-defaults*)
378 (default-version :newest))
380 "Construct a filled in pathname by completing the unspecified components
382 (declare (type pathname-designator pathname)
383 (type pathname-designator defaults)
385 (with-pathname (defaults defaults)
386 (let ((pathname (let ((*default-pathname-defaults* defaults))
387 (pathname pathname))))
388 (let* ((default-host (%pathname-host defaults))
389 (pathname-host (%pathname-host pathname))
391 (and default-host pathname-host
392 (not (eq (host-customary-case default-host)
393 (host-customary-case pathname-host))))))
394 (%make-maybe-logical-pathname
395 (or pathname-host default-host)
396 (or (%pathname-device pathname)
397 (maybe-diddle-case (%pathname-device defaults)
399 (merge-directories (%pathname-directory pathname)
400 (%pathname-directory defaults)
402 (or (%pathname-name pathname)
403 (maybe-diddle-case (%pathname-name defaults)
405 (or (%pathname-type pathname)
406 (maybe-diddle-case (%pathname-type defaults)
408 (or (%pathname-version pathname)
409 default-version))))))
411 (defun import-directory (directory diddle-case)
414 ((member :wild) '(:absolute :wild-inferiors))
415 ((member :unspecific) '(:relative))
418 (results (pop directory))
419 (dolist (piece directory)
420 (cond ((member piece '(:wild :wild-inferiors :up :back))
422 ((or (simple-string-p piece) (pattern-p piece))
423 (results (maybe-diddle-case piece diddle-case)))
425 (results (maybe-diddle-case (coerce piece 'simple-string)
428 (error "~S is not allowed as a directory component." piece))))
432 ,(maybe-diddle-case directory diddle-case)))
435 ,(maybe-diddle-case (coerce directory 'simple-string)
438 (defun make-pathname (&key host
443 (version nil versionp)
447 "Makes a new pathname from the component arguments. Note that host is
448 a host-structure or string."
449 (declare (type (or string host pathname-component-tokens) host)
450 (type (or string pathname-component-tokens) device)
451 (type (or list string pattern pathname-component-tokens) directory)
452 (type (or string pattern pathname-component-tokens) name type)
453 (type (or integer pathname-component-tokens (member :newest))
455 (type (or pathname-designator null) defaults)
456 (type (member :common :local) case))
457 (let* ((defaults (when defaults
458 (with-pathname (defaults defaults) defaults)))
459 (default-host (if defaults
460 (%pathname-host defaults)
461 (pathname-host *default-pathname-defaults*)))
462 ;; toy@rtp.ericsson.se: CLHS says make-pathname can take a
463 ;; string (as a logical-host) for the host part. We map that
464 ;; string into the corresponding logical host structure.
467 ;; HyperSpec says for the arg to MAKE-PATHNAME;
468 ;; "host---a valid physical pathname host. ..."
469 ;; where it probably means -- a valid pathname host.
470 ;; "valid pathname host n. a valid physical pathname host or
471 ;; a valid logical pathname host."
473 ;; "valid physical pathname host n. any of a string,
474 ;; a list of strings, or the symbol :unspecific,
475 ;; that is recognized by the implementation as the name of a host."
476 ;; "valid logical pathname host n. a string that has been defined
477 ;; as the name of a logical host. ..."
478 ;; HS is silent on what happens if the :HOST arg is NOT one of these.
479 ;; It seems an error message is appropriate.
481 (host host) ; A valid host, use it.
482 (string (find-logical-host host t)) ; logical-host or lose.
483 (t default-host))) ; unix-host
484 (diddle-args (and (eq (host-customary-case host) :lower)
487 (not (eq (host-customary-case host)
488 (host-customary-case default-host))))
489 (dev (if devp device (if defaults (%pathname-device defaults))))
490 (dir (import-directory directory diddle-args))
493 (defaults (%pathname-version defaults))
495 (when (and defaults (not dirp))
497 (merge-directories dir
498 (%pathname-directory defaults)
501 (macrolet ((pick (var varp field)
502 `(cond ((or (simple-string-p ,var)
504 (maybe-diddle-case ,var diddle-args))
506 (maybe-diddle-case (coerce ,var 'simple-string)
509 (maybe-diddle-case ,var diddle-args))
511 (maybe-diddle-case (,field defaults)
515 (%make-maybe-logical-pathname host
516 dev ; forced to :UNSPECIFIC when logical
518 (pick name namep %pathname-name)
519 (pick type typep %pathname-type)
522 (defun pathname-host (pathname &key (case :local))
524 "Return PATHNAME's host."
525 (declare (type pathname-designator pathname)
526 (type (member :local :common) case)
529 (with-pathname (pathname pathname)
530 (%pathname-host pathname)))
532 (defun pathname-device (pathname &key (case :local))
534 "Return PATHNAME's device."
535 (declare (type pathname-designator pathname)
536 (type (member :local :common) case))
537 (with-pathname (pathname pathname)
538 (maybe-diddle-case (%pathname-device pathname)
539 (and (eq case :common)
540 (eq (host-customary-case
541 (%pathname-host pathname))
544 (defun pathname-directory (pathname &key (case :local))
546 "Return PATHNAME's directory."
547 (declare (type pathname-designator pathname)
548 (type (member :local :common) case))
549 (with-pathname (pathname pathname)
550 (maybe-diddle-case (%pathname-directory pathname)
551 (and (eq case :common)
552 (eq (host-customary-case
553 (%pathname-host pathname))
555 (defun pathname-name (pathname &key (case :local))
557 "Return PATHNAME's name."
558 (declare (type pathname-designator pathname)
559 (type (member :local :common) case))
560 (with-pathname (pathname pathname)
561 (maybe-diddle-case (%pathname-name pathname)
562 (and (eq case :common)
563 (eq (host-customary-case
564 (%pathname-host pathname))
567 (defun pathname-type (pathname &key (case :local))
569 "Return PATHNAME's type."
570 (declare (type pathname-designator pathname)
571 (type (member :local :common) case))
572 (with-pathname (pathname pathname)
573 (maybe-diddle-case (%pathname-type pathname)
574 (and (eq case :common)
575 (eq (host-customary-case
576 (%pathname-host pathname))
579 (defun pathname-version (pathname)
581 "Return PATHNAME's version."
582 (declare (type pathname-designator pathname))
583 (with-pathname (pathname pathname)
584 (%pathname-version pathname)))
588 ;;; Handle the case where PARSE-NAMESTRING is actually parsing a
589 ;;; namestring. We pick off the :JUNK-ALLOWED case then find a host to
590 ;;; use for parsing, call the parser, then check whether the host matches.
591 (defun %parse-namestring (namestr host defaults start end junk-allowed)
592 (declare (type (or host null) host)
593 (type string namestr)
595 (type (or index null) end))
598 (%parse-namestring namestr host defaults start end nil)
599 (namestring-parse-error (condition)
600 (values nil (namestring-parse-error-offset condition))))
601 (let* ((end (or end (length namestr)))
603 (extract-logical-host-prefix namestr start end)
604 (pathname-host defaults))))
606 (error "When no HOST argument is supplied, the DEFAULTS argument ~
607 must have a non-null PATHNAME-HOST."))
609 (multiple-value-bind (new-host device directory file type version)
610 (funcall (host-parse parse-host) namestr start end)
611 (when (and host new-host (not (eq new-host host)))
612 (error 'simple-type-error
614 ;; Note: ANSI requires that this be a TYPE-ERROR,
615 ;; but there seems to be no completely correct
616 ;; value to use for TYPE-ERROR-EXPECTED-TYPE.
617 ;; Instead, we return a sort of "type error allowed
618 ;; type", trying to say "it would be OK if you
619 ;; passed NIL as the host value" but not mentioning
620 ;; that a matching string would be OK too.
623 "The host in the namestring, ~S,~@
624 does not match the explicit HOST argument, ~S."
625 :format-arguments (list new-host host)))
626 (let ((pn-host (or new-host parse-host)))
627 (values (%make-maybe-logical-pathname
628 pn-host device directory file type version)
631 ;;; If NAMESTR begins with a colon-terminated, defined, logical host,
632 ;;; then return that host, otherwise return NIL.
633 (defun extract-logical-host-prefix (namestr start end)
634 (declare (type simple-base-string namestr)
635 (type index start end)
636 (values (or logical-host null)))
637 (let ((colon-pos (position #\: namestr :start start :end end)))
639 (values (gethash (nstring-upcase (subseq namestr start colon-pos))
643 (defun parse-namestring (thing
646 (defaults *default-pathname-defaults*)
647 &key (start 0) end junk-allowed)
648 (declare (type pathname-designator thing)
649 (type (or list host string (member :unspecific)) host)
650 (type pathname defaults)
652 (type (or index null) end)
653 (type (or t null) junk-allowed)
654 (values (or null pathname) (or null index)))
655 ;; Generally, redundant specification of information in software,
656 ;; whether in code or in comments, is bad. However, the ANSI spec
657 ;; for this is messy enough that it's hard to hold in short-term
658 ;; memory, so I've recorded these redundant notes on the
659 ;; implications of the ANSI spec.
661 ;; According to the ANSI spec, HOST can be a valid pathname host, or
662 ;; a logical host, or NIL.
664 ;; A valid pathname host can be a valid physical pathname host or a
665 ;; valid logical pathname host.
667 ;; A valid physical pathname host is "any of a string, a list of
668 ;; strings, or the symbol :UNSPECIFIC, that is recognized by the
669 ;; implementation as the name of a host". In SBCL as of 0.6.9.8,
670 ;; that means :UNSPECIFIC: though someday we might want to
671 ;; generalize it to allow strings like "RTFM.MIT.EDU" or lists like
672 ;; '("RTFM" "MIT" "EDU"), that's not supported now.
674 ;; A valid logical pathname host is a string which has been defined as
675 ;; the name of a logical host, as with LOAD-LOGICAL-PATHNAME-TRANSLATIONS.
677 ;; A logical host is an object of implementation-dependent nature. In
678 ;; SBCL, it's a member of the HOST class (a subclass of STRUCTURE-OBJECT).
679 (let ((found-host (etypecase host
681 ;; In general ANSI-compliant Common Lisps, a
682 ;; string might also be a physical pathname host,
683 ;; but ANSI leaves this up to the implementor,
684 ;; and in SBCL we don't do it, so it must be a
686 (find-logical-host host))
687 ((or null (member :unspecific))
688 ;; CLHS says that HOST=:UNSPECIFIC has
689 ;; implementation-defined behavior. We
690 ;; just turn it into NIL.
693 ;; ANSI also allows LISTs to designate hosts,
694 ;; but leaves its interpretation
695 ;; implementation-defined. Our interpretation
696 ;; is that it's unsupported.:-|
697 (error "A LIST representing a pathname host is not ~
698 supported in this implementation:~% ~S"
702 (declare (type (or null host) found-host))
705 (%parse-namestring thing found-host defaults start end junk-allowed))
707 (%parse-namestring (coerce thing 'simple-string)
708 found-host defaults start end junk-allowed))
710 (let ((defaulted-host (or found-host (%pathname-host defaults))))
711 (declare (type host defaulted-host))
712 (unless (eq defaulted-host (%pathname-host thing))
713 (error "The HOST argument doesn't match the pathname host:~% ~
715 defaulted-host (%pathname-host thing))))
716 (values thing start))
718 (let ((name (file-name thing)))
720 (error "can't figure out the file associated with stream:~% ~S"
722 (values name nil))))))
724 (defun namestring (pathname)
726 "Construct the full (name)string form of the pathname."
727 (declare (type pathname-designator pathname)
728 (values (or null simple-base-string)))
729 (with-pathname (pathname pathname)
731 (let ((host (%pathname-host pathname)))
733 (error "can't determine the namestring for pathnames with no ~
734 host:~% ~S" pathname))
735 (funcall (host-unparse host) pathname)))))
737 (defun host-namestring (pathname)
739 "Returns a string representation of the name of the host in the pathname."
740 (declare (type pathname-designator pathname)
741 (values (or null simple-base-string)))
742 (with-pathname (pathname pathname)
743 (let ((host (%pathname-host pathname)))
745 (funcall (host-unparse-host host) pathname)
747 "can't determine the namestring for pathnames with no host:~% ~S"
750 (defun directory-namestring (pathname)
752 "Returns a string representation of the directories used in the pathname."
753 (declare (type pathname-designator pathname)
754 (values (or null simple-base-string)))
755 (with-pathname (pathname pathname)
756 (let ((host (%pathname-host pathname)))
758 (funcall (host-unparse-directory host) pathname)
760 "can't determine the namestring for pathnames with no host:~% ~S"
763 (defun file-namestring (pathname)
765 "Returns a string representation of the name used in the pathname."
766 (declare (type pathname-designator pathname)
767 (values (or null simple-base-string)))
768 (with-pathname (pathname pathname)
769 (let ((host (%pathname-host pathname)))
771 (funcall (host-unparse-file host) pathname)
773 "can't determine the namestring for pathnames with no host:~% ~S"
776 (defun enough-namestring (pathname
778 (defaults *default-pathname-defaults*))
780 "Returns an abbreviated pathname sufficent to identify the pathname relative
782 (declare (type pathname-designator pathname))
783 (with-pathname (pathname pathname)
784 (let ((host (%pathname-host pathname)))
786 (with-pathname (defaults defaults)
787 (funcall (host-unparse-enough host) pathname defaults))
789 "can't determine the namestring for pathnames with no host:~% ~S"
794 (defun wild-pathname-p (pathname &optional field-key)
796 "Predicate for determining whether pathname contains any wildcards."
797 (declare (type pathname-designator pathname)
798 (type (member nil :host :device :directory :name :type :version)
800 (with-pathname (pathname pathname)
802 (or (pattern-p x) (member x '(:wild :wild-inferiors)))))
805 (or (wild-pathname-p pathname :host)
806 (wild-pathname-p pathname :device)
807 (wild-pathname-p pathname :directory)
808 (wild-pathname-p pathname :name)
809 (wild-pathname-p pathname :type)
810 (wild-pathname-p pathname :version)))
811 (:host (frob (%pathname-host pathname)))
812 (:device (frob (%pathname-host pathname)))
813 (:directory (some #'frob (%pathname-directory pathname)))
814 (:name (frob (%pathname-name pathname)))
815 (:type (frob (%pathname-type pathname)))
816 (:version (frob (%pathname-version pathname)))))))
818 (defun pathname-match-p (in-pathname in-wildname)
820 "Pathname matches the wildname template?"
821 (declare (type pathname-designator in-pathname))
822 (with-pathname (pathname in-pathname)
823 (with-pathname (wildname in-wildname)
824 (macrolet ((frob (field &optional (op 'components-match ))
825 `(or (null (,field wildname))
826 (,op (,field pathname) (,field wildname)))))
827 (and (or (null (%pathname-host wildname))
828 (eq (%pathname-host wildname) (%pathname-host pathname)))
829 (frob %pathname-device)
830 (frob %pathname-directory directory-components-match)
831 (frob %pathname-name)
832 (frob %pathname-type)
833 (frob %pathname-version))))))
835 ;;; Place the substitutions into the pattern and return the string or pattern
836 ;;; that results. If DIDDLE-CASE is true, we diddle the result case as well,
837 ;;; in case we are translating between hosts with difference conventional case.
838 ;;; The second value is the tail of subs with all of the values that we used up
839 ;;; stripped off. Note that PATTERN-MATCHES matches all consecutive wildcards
840 ;;; as a single string, so we ignore subsequent contiguous wildcards.
841 (defun substitute-into (pattern subs diddle-case)
842 (declare (type pattern pattern)
844 (values (or simple-base-string pattern) list))
845 (let ((in-wildcard nil)
848 (dolist (piece (pattern-pieces pattern))
849 (cond ((simple-string-p piece)
851 (setf in-wildcard nil))
856 (error "not enough wildcards in FROM pattern to match ~
859 (let ((sub (pop subs)))
863 (push (apply #'concatenate 'simple-string
866 (dolist (piece (pattern-pieces sub))
867 (push piece pieces)))
871 (error "can't substitute this into the middle of a word:~
876 (push (apply #'concatenate 'simple-string (nreverse strings))
880 (if (and pieces (simple-string-p (car pieces)) (null (cdr pieces)))
882 (make-pattern (nreverse pieces)))
886 ;;; Called when we can't see how source and from matched.
887 (defun didnt-match-error (source from)
888 (error "Pathname components from SOURCE and FROM args to TRANSLATE-PATHNAME~@
889 did not match:~% ~S ~S"
892 ;;; Do TRANSLATE-COMPONENT for all components except host and directory.
893 (defun translate-component (source from to diddle-case)
900 (if (pattern= from source)
902 (didnt-match-error source from)))
904 (multiple-value-bind (won subs) (pattern-matches from source)
906 (values (substitute-into to subs diddle-case))
907 (didnt-match-error source from))))
909 (maybe-diddle-case source diddle-case))))
911 (values (substitute-into to (list source) diddle-case)))
913 (if (components-match source from)
914 (maybe-diddle-case source diddle-case)
915 (didnt-match-error source from)))))
917 (maybe-diddle-case source diddle-case))
919 (if (components-match source from)
921 (didnt-match-error source from)))))
923 ;;; Return a list of all the things that we want to substitute into the TO
924 ;;; pattern (the things matched by from on source.) When From contains
925 ;;; :WILD-INFERIORS, the result contains a sublist of the matched source
927 (defun compute-directory-substitutions (orig-source orig-from)
928 (let ((source orig-source)
933 (unless (every #'(lambda (x) (eq x :wild-inferiors)) from)
934 (didnt-match-error orig-source orig-from))
937 (unless from (didnt-match-error orig-source orig-from))
938 (let ((from-part (pop from))
939 (source-part (pop source)))
942 (typecase source-part
944 (if (pattern= from-part source-part)
946 (didnt-match-error orig-source orig-from)))
948 (multiple-value-bind (won new-subs)
949 (pattern-matches from-part source-part)
951 (dolist (sub new-subs)
953 (didnt-match-error orig-source orig-from))))
955 (didnt-match-error orig-source orig-from))))
958 ((member :wild-inferiors)
959 (let ((remaining-source (cons source-part source)))
962 (when (directory-components-match remaining-source from)
964 (unless remaining-source
965 (didnt-match-error orig-source orig-from))
966 (res (pop remaining-source)))
968 (setq source remaining-source))))
970 (unless (and (simple-string-p source-part)
971 (string= from-part source-part))
972 (didnt-match-error orig-source orig-from)))
974 (didnt-match-error orig-source orig-from)))))
977 ;;; This is called by TRANSLATE-PATHNAME on the directory components
978 ;;; of its argument pathnames to produce the result directory
979 ;;; component. If this leaves the directory NIL, we return the source
980 ;;; directory. The :RELATIVE or :ABSOLUTE is taken from the source
981 ;;; directory, except if TO is :ABSOLUTE, in which case the result
982 ;;; will be :ABSOLUTE.
983 (defun translate-directories (source from to diddle-case)
984 (if (not (and source to from))
985 (or (and to (null source) (remove :wild-inferiors to))
986 (mapcar (lambda (x) (maybe-diddle-case x diddle-case)) source))
988 ;; If TO is :ABSOLUTE, the result should still be :ABSOLUTE.
989 (res (if (eq (first to) :absolute)
992 (let ((subs-left (compute-directory-substitutions (rest source)
994 (dolist (to-part (rest to))
998 (let ((match (pop subs-left)))
1000 (error ":WILD-INFERIORS is not paired in from and to ~
1001 patterns:~% ~S ~S" from to))
1002 (res (maybe-diddle-case match diddle-case))))
1003 ((member :wild-inferiors)
1005 (let ((match (pop subs-left)))
1006 (unless (listp match)
1007 (error ":WILD-INFERIORS not paired in from and to ~
1008 patterns:~% ~S ~S" from to))
1010 (res (maybe-diddle-case x diddle-case)))))
1012 (multiple-value-bind
1014 (substitute-into to-part subs-left diddle-case)
1015 (setf subs-left new-subs-left)
1017 (t (res to-part)))))
1020 (defun translate-pathname (source from-wildname to-wildname &key)
1022 "Use the source pathname to translate the from-wildname's wild and
1023 unspecified elements into a completed to-pathname based on the to-wildname."
1024 (declare (type pathname-designator source from-wildname to-wildname))
1025 (with-pathname (source source)
1026 (with-pathname (from from-wildname)
1027 (with-pathname (to to-wildname)
1028 (let* ((source-host (%pathname-host source))
1029 (to-host (%pathname-host to))
1031 (and source-host to-host
1032 (not (eq (host-customary-case source-host)
1033 (host-customary-case to-host))))))
1034 (macrolet ((frob (field &optional (op 'translate-component))
1035 `(let ((result (,op (,field source)
1039 (if (eq result :error)
1040 (error "~S doesn't match ~S." source from)
1042 (%make-maybe-logical-pathname
1043 (or to-host source-host)
1044 (frob %pathname-device)
1045 (frob %pathname-directory translate-directories)
1046 (frob %pathname-name)
1047 (frob %pathname-type)
1048 (frob %pathname-version))))))))
1050 ;;;; logical pathname support. ANSI 92-102 specification.
1052 ;;;; As logical-pathname translations are loaded they are
1053 ;;;; canonicalized as patterns to enable rapid efficent translation
1054 ;;;; into physical pathnames.
1058 ;;; Canonicalize a logical pathname word by uppercasing it checking that it
1059 ;;; contains only legal characters.
1060 (defun logical-word-or-lose (word)
1061 (declare (string word))
1062 (let ((word (string-upcase word)))
1063 (dotimes (i (length word))
1064 (let ((ch (schar word i)))
1065 (unless (or (alpha-char-p ch) (digit-char-p ch) (char= ch #\-))
1066 (error 'namestring-parse-error
1067 :complaint "logical namestring character which ~
1068 is not alphanumeric or hyphen:~% ~S"
1069 :arguments (list ch)
1070 :namestring word :offset i))))
1073 ;;; Given a logical host or string, return a logical host. If ERROR-P
1074 ;;; is NIL, then return NIL when no such host exists.
1075 (defun find-logical-host (thing &optional (errorp t))
1078 (let ((found (gethash (logical-word-or-lose thing)
1080 (if (or found (not errorp))
1082 ;; This is the error signalled from e.g.
1083 ;; LOGICAL-PATHNAME-TRANSLATIONS when host is not a defined
1084 ;; host, and ANSI specifies that that's a TYPE-ERROR.
1085 (error 'simple-type-error
1087 ;; God only knows what ANSI expects us to use for
1088 ;; the EXPECTED-TYPE here. Maybe this will be OK..
1090 '(and string (satisfies logical-pathname-translations))
1091 :format-control "logical host not yet defined: ~S"
1092 :format-arguments (list thing)))))
1093 (logical-host thing)))
1095 ;;; Given a logical host name or host, return a logical host, creating
1096 ;;; a new one if necessary.
1097 (defun intern-logical-host (thing)
1098 (declare (values logical-host))
1099 (or (find-logical-host thing nil)
1100 (let* ((name (logical-word-or-lose thing))
1101 (new (make-logical-host :name name)))
1102 (setf (gethash name *logical-hosts*) new)
1105 ;;;; logical pathname parsing
1107 ;;; Deal with multi-char wildcards in a logical pathname token.
1108 (defun maybe-make-logical-pattern (namestring chunks)
1109 (let ((chunk (caar chunks)))
1110 (collect ((pattern))
1112 (len (length chunk)))
1113 (declare (fixnum last-pos))
1115 (when (= last-pos len) (return))
1116 (let ((pos (or (position #\* chunk :start last-pos) len)))
1117 (if (= pos last-pos)
1119 (error 'namestring-parse-error
1120 :complaint "double asterisk inside of logical ~
1122 :arguments (list chunk)
1123 :namestring namestring
1124 :offset (+ (cdar chunks) pos)))
1125 (pattern (subseq chunk last-pos pos)))
1128 (pattern :multi-char-wild))
1129 (setq last-pos (1+ pos)))))
1132 (make-pattern (pattern))
1133 (let ((x (car (pattern))))
1134 (if (eq x :multi-char-wild)
1138 ;;; Return a list of conses where the CDR is the start position and
1139 ;;; the CAR is a string (token) or character (punctuation.)
1140 (defun logical-chunkify (namestr start end)
1142 (do ((i start (1+ i))
1146 (chunks (cons (nstring-upcase (subseq namestr prev end)) prev))))
1147 (let ((ch (schar namestr i)))
1148 (unless (or (alpha-char-p ch) (digit-char-p ch)
1149 (member ch '(#\- #\*)))
1151 (chunks (cons (nstring-upcase (subseq namestr prev i)) prev)))
1153 (unless (member ch '(#\; #\: #\.))
1154 (error 'namestring-parse-error
1155 :complaint "illegal character for logical pathname:~% ~S"
1156 :arguments (list ch)
1159 (chunks (cons ch i)))))
1162 ;;; Break up a logical-namestring, always a string, into its
1163 ;;; constituent parts.
1164 (defun parse-logical-namestring (namestr start end)
1165 (declare (type simple-base-string namestr)
1166 (type index start end))
1167 (collect ((directory))
1172 (labels ((expecting (what chunks)
1173 (unless (and chunks (simple-string-p (caar chunks)))
1174 (error 'namestring-parse-error
1175 :complaint "expecting ~A, got ~:[nothing~;~S~]."
1176 :arguments (list what (caar chunks) (caar chunks))
1178 :offset (if chunks (cdar chunks) end)))
1180 (parse-host (chunks)
1181 (case (caadr chunks)
1184 (find-logical-host (expecting "a host name" chunks)))
1185 (parse-relative (cddr chunks)))
1187 (parse-relative chunks))))
1188 (parse-relative (chunks)
1191 (directory :relative)
1192 (parse-directory (cdr chunks)))
1194 (directory :absolute) ; Assumption! Maybe revoked later.
1195 (parse-directory chunks))))
1196 (parse-directory (chunks)
1197 (case (caadr chunks)
1200 (let ((res (expecting "a directory name" chunks)))
1201 (cond ((string= res "..") :up)
1202 ((string= res "**") :wild-inferiors)
1204 (maybe-make-logical-pattern namestr chunks)))))
1205 (parse-directory (cddr chunks)))
1207 (parse-name chunks))))
1208 (parse-name (chunks)
1210 (expecting "a file name" chunks)
1211 (setq name (maybe-make-logical-pattern namestr chunks))
1212 (expecting-dot (cdr chunks))))
1213 (expecting-dot (chunks)
1215 (unless (eql (caar chunks) #\.)
1216 (error 'namestring-parse-error
1217 :complaint "expecting a dot, got ~S."
1218 :arguments (list (caar chunks))
1220 :offset (cdar chunks)))
1222 (parse-version (cdr chunks))
1223 (parse-type (cdr chunks)))))
1224 (parse-type (chunks)
1225 (expecting "a file type" chunks)
1226 (setq type (maybe-make-logical-pattern namestr chunks))
1227 (expecting-dot (cdr chunks)))
1228 (parse-version (chunks)
1229 (let ((str (expecting "a positive integer, * or NEWEST"
1232 ((string= str "*") (setq version :wild))
1233 ((string= str "NEWEST") (setq version :newest))
1235 (multiple-value-bind (res pos)
1236 (parse-integer str :junk-allowed t)
1237 (unless (and res (plusp res))
1238 (error 'namestring-parse-error
1239 :complaint "expected a positive integer, ~
1241 :arguments (list str)
1243 :offset (+ pos (cdar chunks))))
1244 (setq version res)))))
1246 (error 'namestring-parse-error
1247 :complaint "extra stuff after end of file name"
1249 :offset (cdadr chunks)))))
1250 (parse-host (logical-chunkify namestr start end)))
1251 (values host :unspecific (directory) name type version))))
1253 ;;; We can't initialize this yet because not all host methods are
1255 (defvar *logical-pathname-defaults*)
1257 (defun logical-pathname (pathspec)
1259 "Converts the pathspec argument to a logical-pathname and returns it."
1260 (declare (type (or logical-pathname string stream) pathspec)
1261 (values logical-pathname))
1262 (if (typep pathspec 'logical-pathname)
1264 (let ((res (parse-namestring pathspec nil *logical-pathname-defaults*)))
1265 (when (eq (%pathname-host res)
1266 (%pathname-host *logical-pathname-defaults*))
1267 (error "This logical namestring does not specify a host:~% ~S"
1271 ;;;; logical pathname unparsing
1273 (defun unparse-logical-directory (pathname)
1274 (declare (type pathname pathname))
1276 (let ((directory (%pathname-directory pathname)))
1278 (ecase (pop directory)
1279 (:absolute) ; nothing special
1280 (:relative (pieces ";")))
1281 (dolist (dir directory)
1282 (cond ((or (stringp dir) (pattern-p dir))
1283 (pieces (unparse-logical-piece dir))
1287 ((eq dir :wild-inferiors)
1290 (error "invalid directory component: ~S" dir))))))
1291 (apply #'concatenate 'simple-string (pieces))))
1293 (defun unparse-logical-piece (thing)
1295 (simple-string thing)
1297 (collect ((strings))
1298 (dolist (piece (pattern-pieces thing))
1300 (simple-string (strings piece))
1302 (cond ((eq piece :wild-inferiors)
1304 ((eq piece :multi-char-wild)
1306 (t (error "invalid keyword: ~S" piece))))))
1307 (apply #'concatenate 'simple-string (strings))))))
1309 ;;; Unparse a logical pathname string.
1310 (defun unparse-enough-namestring (pathname defaults)
1311 (let* ((path-directory (pathname-directory pathname))
1312 (def-directory (pathname-directory defaults))
1314 ;; Go down the directory lists to see what matches. What's
1315 ;; left is what we want, more or less.
1316 (cond ((and (eq (first path-directory) (first def-directory))
1317 (eq (first path-directory) :absolute))
1318 ;; Both paths are :ABSOLUTE, so find where the
1319 ;; common parts end and return what's left
1320 (do* ((p (rest path-directory) (rest p))
1321 (d (rest def-directory) (rest d)))
1322 ((or (endp p) (endp d)
1323 (not (equal (first p) (first d))))
1326 ;; At least one path is :RELATIVE, so just return the
1327 ;; original path. If the original path is :RELATIVE,
1328 ;; then that's the right one. If PATH-DIRECTORY is
1329 ;; :ABSOLUTE, we want to return that except when
1330 ;; DEF-DIRECTORY is :ABSOLUTE, as handled above. so return
1331 ;; the original directory.
1333 (make-pathname :host (pathname-host pathname)
1334 :directory enough-directory
1335 :name (pathname-name pathname)
1336 :type (pathname-type pathname)
1337 :version (pathname-version pathname))))
1339 (defun unparse-logical-namestring (pathname)
1340 (declare (type logical-pathname pathname))
1341 (concatenate 'simple-string
1342 (logical-host-name (%pathname-host pathname)) ":"
1343 (unparse-logical-directory pathname)
1344 (unparse-unix-file pathname)))
1346 ;;;; logical pathname translations
1348 ;;; Verify that the list of translations consists of lists and prepare
1349 ;;; canonical translations. (Parse pathnames and expand out wildcards
1351 (defun canonicalize-logical-pathname-translations (translation-list host)
1352 (declare (type list translation-list) (type host host)
1354 (mapcar (lambda (translation)
1355 (destructuring-bind (from to) translation
1356 (list (if (typep from 'logical-pathname)
1358 (parse-namestring from host))
1362 (defun logical-pathname-translations (host)
1364 "Return the (logical) host object argument's list of translations."
1365 (declare (type (or string logical-host) host)
1367 (logical-host-translations (find-logical-host host)))
1369 (defun (setf logical-pathname-translations) (translations host)
1371 "Set the translations list for the logical host argument.
1372 Return translations."
1373 (declare (type (or string logical-host) host)
1374 (type list translations)
1376 (let ((host (intern-logical-host host)))
1377 (setf (logical-host-canon-transls host)
1378 (canonicalize-logical-pathname-translations translations host))
1379 (setf (logical-host-translations host) translations)))
1381 (defun translate-logical-pathname (pathname &key)
1383 "Translate PATHNAME to a physical pathname, which is returned."
1384 (declare (type pathname-designator pathname)
1385 (values (or null pathname)))
1388 (dolist (x (logical-host-canon-transls (%pathname-host pathname))
1389 (error 'simple-file-error
1391 :format-control "no translation for ~S"
1392 :format-arguments (list pathname)))
1393 (destructuring-bind (from to) x
1394 (when (pathname-match-p pathname from)
1395 (return (translate-logical-pathname
1396 (translate-pathname pathname from to)))))))
1398 (stream (translate-logical-pathname (pathname pathname)))
1399 (t (translate-logical-pathname (logical-pathname pathname)))))
1401 (defvar *logical-pathname-defaults*
1402 (%make-logical-pathname (make-logical-host :name "BOGUS")
1409 (defun load-logical-pathname-translations (host)
1411 (declare (type string host)
1412 (values (member t nil)))
1413 (if (find-logical-host host nil)
1414 ;; This host is already defined, all is well and good.
1416 ;; ANSI: "The specific nature of the search is
1417 ;; implementation-defined." SBCL: doesn't search at all
1418 (error "logical host ~S not found" host)))