1 ;;;; machine/filesystem-independent pathname functions
3 ;;;; This software is part of the SBCL system. See the README file for
6 ;;;; This software is derived from the CMU CL system, which was
7 ;;;; written at Carnegie Mellon University and released into the
8 ;;;; public domain. The software is in the public domain and is
9 ;;;; provided with absolutely no warranty. See the COPYING and CREDITS
10 ;;;; files for more information.
12 (in-package "SB!IMPL")
14 #!-sb-fluid (declaim (freeze-type logical-pathname logical-host))
18 (def!struct (unix-host
19 (:make-load-form-fun make-unix-host-load-form)
21 (parse #'parse-unix-namestring)
22 (unparse #'unparse-unix-namestring)
23 (unparse-host #'unparse-unix-host)
24 (unparse-directory #'unparse-unix-directory)
25 (unparse-file #'unparse-unix-file)
26 (unparse-enough #'unparse-unix-enough)
27 (customary-case :lower))))
29 (defvar *unix-host* (make-unix-host))
31 (defun make-unix-host-load-form (host)
32 (declare (ignore host))
35 ;;; Return a value suitable, e.g., for preinitializing
36 ;;; *DEFAULT-PATHNAME-DEFAULTS* before *DEFAULT-PATHNAME-DEFAULTS* is
37 ;;; initialized (at which time we can't safely call e.g. #'PATHNAME).
38 (defun make-trivial-default-pathname ()
39 (%make-pathname *unix-host* nil nil nil nil :newest))
43 (def!method print-object ((pathname pathname) stream)
44 (let ((namestring (handler-case (namestring pathname)
47 (format stream "#P~S" namestring)
48 (print-unreadable-object (pathname stream :type t)
50 "~@<(with no namestring) ~_:HOST ~S ~_:DEVICE ~S ~_:DIRECTORY ~S ~
51 ~_:NAME ~S ~_:TYPE ~S ~_:VERSION ~S~:>"
52 (%pathname-host pathname)
53 (%pathname-device pathname)
54 (%pathname-directory pathname)
55 (%pathname-name pathname)
56 (%pathname-type pathname)
57 (%pathname-version pathname))))))
59 (def!method make-load-form ((pathname pathname) &optional environment)
60 (make-load-form-saving-slots pathname :environment environment))
62 ;;; The potential conflict with search lists requires isolating the
63 ;;; printed representation to use the i/o macro #.(logical-pathname
64 ;;; <path-designator>).
66 ;;; FIXME: We don't use search lists any more, so that comment is
68 (def!method print-object ((pathname logical-pathname) stream)
69 (let ((namestring (handler-case (namestring pathname)
72 (format stream "#.(CL:LOGICAL-PATHNAME ~S)" namestring)
73 (print-unreadable-object (pathname stream :type t)
76 "~_:HOST ~S ~_:DIRECTORY ~S ~_:FILE ~S ~_:NAME ~S ~_:VERSION ~S"
77 (%pathname-host pathname)
78 (%pathname-directory pathname)
79 (%pathname-name pathname)
80 (%pathname-type pathname)
81 (%pathname-version pathname))))))
83 ;;; A pathname is logical if the host component is a logical host.
84 ;;; This constructor is used to make an instance of the correct type
85 ;;; from parsed arguments.
86 (defun %make-maybe-logical-pathname (host device directory name type version)
87 ;; We canonicalize logical pathname components to uppercase. ANSI
88 ;; doesn't strictly require this, leaving it up to the implementor;
89 ;; but the arguments given in the X3J13 cleanup issue
90 ;; PATHNAME-LOGICAL:ADD seem compelling: we should canonicalize the
91 ;; case, and uppercase is the ordinary way to do that.
92 (flet ((upcase-maybe (x) (typecase x (string (logical-word-or-lose x)) (t x))))
93 (if (typep host 'logical-host)
94 (%make-logical-pathname host
96 (mapcar #'upcase-maybe directory)
100 (%make-pathname host device directory name type version))))
102 ;;; Hash table searching maps a logical pathname's host to its
103 ;;; physical pathname translation.
104 (defvar *logical-hosts* (make-hash-table :test 'equal))
108 (def!method make-load-form ((pattern pattern) &optional environment)
109 (make-load-form-saving-slots pattern :environment environment))
111 (def!method print-object ((pattern pattern) stream)
112 (print-unreadable-object (pattern stream :type t)
114 (let ((*print-escape* t))
115 (pprint-fill stream (pattern-pieces pattern) nil))
116 (prin1 (pattern-pieces pattern) stream))))
118 (defun pattern= (pattern1 pattern2)
119 (declare (type pattern pattern1 pattern2))
120 (let ((pieces1 (pattern-pieces pattern1))
121 (pieces2 (pattern-pieces pattern2)))
122 (and (= (length pieces1) (length pieces2))
123 (every (lambda (piece1 piece2)
126 (and (simple-string-p piece2)
127 (string= piece1 piece2)))
130 (eq (car piece1) (car piece2))
131 (string= (cdr piece1) (cdr piece2))))
133 (eq piece1 piece2))))
137 ;;; If the string matches the pattern returns the multiple values T
138 ;;; and a list of the matched strings.
139 (defun pattern-matches (pattern string)
140 (declare (type pattern pattern)
141 (type simple-string string))
142 (let ((len (length string)))
143 (labels ((maybe-prepend (subs cur-sub chars)
145 (let* ((len (length chars))
146 (new (make-string len))
149 (setf (schar new (decf index)) char))
152 (matches (pieces start subs cur-sub chars)
155 (values t (maybe-prepend subs cur-sub chars))
157 (let ((piece (car pieces)))
160 (let ((end (+ start (length piece))))
162 (string= piece string
163 :start2 start :end2 end)
164 (matches (cdr pieces) end
165 (maybe-prepend subs cur-sub chars)
171 (let ((char (schar string start)))
172 (if (find char (cdr piece) :test #'char=)
173 (matches (cdr pieces) (1+ start) subs t
174 (cons char chars))))))))
175 ((member :single-char-wild)
177 (matches (cdr pieces) (1+ start) subs t
178 (cons (schar string start) chars))))
179 ((member :multi-char-wild)
180 (multiple-value-bind (won new-subs)
181 (matches (cdr pieces) start subs t chars)
185 (matches pieces (1+ start) subs t
186 (cons (schar string start)
188 (multiple-value-bind (won subs)
189 (matches (pattern-pieces pattern) 0 nil nil nil)
190 (values won (reverse subs))))))
192 ;;; PATHNAME-MATCH-P for directory components
193 (defun directory-components-match (thing wild)
196 ;; If THING has a null directory, assume that it matches
197 ;; (:ABSOLUTE :WILD-INFERIORS) or (:RELATIVE :WILD-INFERIORS).
200 (member (first wild) '(:absolute :relative))
201 (eq (second wild) :wild-inferiors))
203 (let ((wild1 (first wild)))
204 (if (eq wild1 :wild-inferiors)
205 (let ((wild-subdirs (rest wild)))
206 (or (null wild-subdirs)
208 (when (directory-components-match thing wild-subdirs)
211 (unless thing (return nil)))))
213 (components-match (first thing) wild1)
214 (directory-components-match (rest thing)
217 ;;; Return true if pathname component THING is matched by WILD. (not
219 (defun components-match (thing wild)
220 (declare (type (or pattern symbol simple-string integer) thing wild))
225 ;; String is matched by itself, a matching pattern or :WILD.
228 (values (pattern-matches wild thing)))
230 (string= thing wild))))
232 ;; A pattern is only matched by an identical pattern.
233 (and (pattern-p wild) (pattern= thing wild)))
235 ;; An integer (version number) is matched by :WILD or the
236 ;; same integer. This branch will actually always be NIL as
237 ;; long as the version is a fixnum.
240 ;;; a predicate for comparing two pathname slot component sub-entries
241 (defun compare-component (this that)
245 (and (simple-string-p that)
246 (string= this that)))
248 (and (pattern-p that)
249 (pattern= this that)))
252 (compare-component (car this) (car that))
253 (compare-component (cdr this) (cdr that)))))))
255 ;;;; pathname functions
257 (defun pathname= (pathname1 pathname2)
258 (declare (type pathname pathname1)
259 (type pathname pathname2))
260 (and (eq (%pathname-host pathname1)
261 (%pathname-host pathname2))
262 (compare-component (%pathname-device pathname1)
263 (%pathname-device pathname2))
264 (compare-component (%pathname-directory pathname1)
265 (%pathname-directory pathname2))
266 (compare-component (%pathname-name pathname1)
267 (%pathname-name pathname2))
268 (compare-component (%pathname-type pathname1)
269 (%pathname-type pathname2))
270 (compare-component (%pathname-version pathname1)
271 (%pathname-version pathname2))))
273 ;;; Convert PATHNAME-DESIGNATOR (a pathname, or string, or
274 ;;; stream), into a pathname in pathname.
276 ;;; FIXME: was rewritten, should be tested (or rewritten again, this
277 ;;; time using ONCE-ONLY, *then* tested)
278 ;;; FIXME: become SB!XC:DEFMACRO inside EVAL-WHEN (COMPILE EVAL)?
279 (defmacro with-pathname ((pathname pathname-designator) &body body)
280 (let ((pd0 (gensym)))
281 `(let* ((,pd0 ,pathname-designator)
282 (,pathname (etypecase ,pd0
284 (string (parse-namestring ,pd0))
285 (stream (file-name ,pd0)))))
288 ;;; Convert the var, a host or string name for a host, into a
289 ;;; LOGICAL-HOST structure or nil if not defined.
291 ;;; pw notes 1/12/97 this potentially useful macro is not used anywhere
292 ;;; and 'find-host' is not defined. 'find-logical-host' seems to be needed.
294 (defmacro with-host ((var expr) &body body)
295 `(let ((,var (let ((,var ,expr))
298 (string (find-logical-host ,var nil))
303 (defun pathname (thing)
305 "Convert thing (a pathname, string or stream) into a pathname."
306 (declare (type pathname-designator thing))
307 (with-pathname (pathname thing)
310 ;;; Change the case of thing if DIDDLE-P.
311 (defun maybe-diddle-case (thing diddle-p)
312 (if (and diddle-p (not (or (symbolp thing) (integerp thing))))
313 (labels ((check-for (pred in)
316 (dolist (piece (pattern-pieces in))
317 (when (typecase piece
319 (check-for pred piece))
323 (check-for pred (cdr in))))))
327 (when (check-for pred x)
330 (dotimes (i (length in))
331 (when (funcall pred (schar in i))
334 (diddle-with (fun thing)
338 (mapcar (lambda (piece)
346 (funcall fun (cdr piece))))
351 (pattern-pieces thing))))
358 (let ((any-uppers (check-for #'upper-case-p thing))
359 (any-lowers (check-for #'lower-case-p thing)))
360 (cond ((and any-uppers any-lowers)
361 ;; mixed case, stays the same
364 ;; all uppercase, becomes all lower case
365 (diddle-with (lambda (x) (if (stringp x)
369 ;; all lowercase, becomes all upper case
370 (diddle-with (lambda (x) (if (stringp x)
374 ;; no letters? I guess just leave it.
378 (defun merge-directories (dir1 dir2 diddle-case)
379 (if (or (eq (car dir1) :absolute)
384 (if (and (eq dir :back)
386 (not (eq (car results) :back)))
388 (push dir results))))
389 (dolist (dir (maybe-diddle-case dir2 diddle-case))
391 (dolist (dir (cdr dir1))
395 (defun merge-pathnames (pathname
397 (defaults *default-pathname-defaults*)
398 (default-version :newest))
400 "Construct a filled in pathname by completing the unspecified components
402 (declare (type pathname-designator pathname)
403 (type pathname-designator defaults)
405 (with-pathname (defaults defaults)
406 (let ((pathname (let ((*default-pathname-defaults* defaults))
407 (pathname pathname))))
408 (let* ((default-host (%pathname-host defaults))
409 (pathname-host (%pathname-host pathname))
411 (and default-host pathname-host
412 (not (eq (host-customary-case default-host)
413 (host-customary-case pathname-host))))))
414 (%make-maybe-logical-pathname
415 (or pathname-host default-host)
416 (or (%pathname-device pathname)
417 (maybe-diddle-case (%pathname-device defaults)
419 (merge-directories (%pathname-directory pathname)
420 (%pathname-directory defaults)
422 (or (%pathname-name pathname)
423 (maybe-diddle-case (%pathname-name defaults)
425 (or (%pathname-type pathname)
426 (maybe-diddle-case (%pathname-type defaults)
428 (or (%pathname-version pathname)
429 default-version))))))
431 (defun import-directory (directory diddle-case)
434 ((member :wild) '(:absolute :wild-inferiors))
435 ((member :unspecific) '(:relative))
438 (results (pop directory))
439 (dolist (piece directory)
440 (cond ((member piece '(:wild :wild-inferiors :up :back))
442 ((or (simple-string-p piece) (pattern-p piece))
443 (results (maybe-diddle-case piece diddle-case)))
445 (results (maybe-diddle-case (coerce piece 'simple-string)
448 (error "~S is not allowed as a directory component." piece))))
452 ,(maybe-diddle-case directory diddle-case)))
455 ,(maybe-diddle-case (coerce directory 'simple-string)
458 (defun make-pathname (&key host
463 (version nil versionp)
467 "Makes a new pathname from the component arguments. Note that host is
468 a host-structure or string."
469 (declare (type (or string host pathname-component-tokens) host)
470 (type (or string pathname-component-tokens) device)
471 (type (or list string pattern pathname-component-tokens) directory)
472 (type (or string pattern pathname-component-tokens) name type)
473 (type (or integer pathname-component-tokens (member :newest))
475 (type (or pathname-designator null) defaults)
476 (type (member :common :local) case))
477 (let* ((defaults (when defaults
478 (with-pathname (defaults defaults) defaults)))
479 (default-host (if defaults
480 (%pathname-host defaults)
481 (pathname-host *default-pathname-defaults*)))
482 ;; toy@rtp.ericsson.se: CLHS says make-pathname can take a
483 ;; string (as a logical-host) for the host part. We map that
484 ;; string into the corresponding logical host structure.
487 ;; HyperSpec says for the arg to MAKE-PATHNAME;
488 ;; "host---a valid physical pathname host. ..."
489 ;; where it probably means -- a valid pathname host.
490 ;; "valid pathname host n. a valid physical pathname host or
491 ;; a valid logical pathname host."
493 ;; "valid physical pathname host n. any of a string,
494 ;; a list of strings, or the symbol :unspecific,
495 ;; that is recognized by the implementation as the name of a host."
496 ;; "valid logical pathname host n. a string that has been defined
497 ;; as the name of a logical host. ..."
498 ;; HS is silent on what happens if the :HOST arg is NOT one of these.
499 ;; It seems an error message is appropriate.
501 (host host) ; A valid host, use it.
502 (string (find-logical-host host t)) ; logical-host or lose.
503 (t default-host))) ; unix-host
504 (diddle-args (and (eq (host-customary-case host) :lower)
507 (not (eq (host-customary-case host)
508 (host-customary-case default-host))))
509 (dev (if devp device (if defaults (%pathname-device defaults))))
510 (dir (import-directory directory diddle-args))
513 (defaults (%pathname-version defaults))
515 (when (and defaults (not dirp))
517 (merge-directories dir
518 (%pathname-directory defaults)
521 (macrolet ((pick (var varp field)
522 `(cond ((or (simple-string-p ,var)
524 (maybe-diddle-case ,var diddle-args))
526 (maybe-diddle-case (coerce ,var 'simple-string)
529 (maybe-diddle-case ,var diddle-args))
531 (maybe-diddle-case (,field defaults)
535 (%make-maybe-logical-pathname host
536 dev ; forced to :UNSPECIFIC when logical
538 (pick name namep %pathname-name)
539 (pick type typep %pathname-type)
542 (defun pathname-host (pathname &key (case :local))
544 "Return PATHNAME's host."
545 (declare (type pathname-designator pathname)
546 (type (member :local :common) case)
549 (with-pathname (pathname pathname)
550 (%pathname-host pathname)))
552 (defun pathname-device (pathname &key (case :local))
554 "Return PATHNAME's device."
555 (declare (type pathname-designator pathname)
556 (type (member :local :common) case))
557 (with-pathname (pathname pathname)
558 (maybe-diddle-case (%pathname-device pathname)
559 (and (eq case :common)
560 (eq (host-customary-case
561 (%pathname-host pathname))
564 (defun pathname-directory (pathname &key (case :local))
566 "Return PATHNAME's directory."
567 (declare (type pathname-designator pathname)
568 (type (member :local :common) case))
569 (with-pathname (pathname pathname)
570 (maybe-diddle-case (%pathname-directory pathname)
571 (and (eq case :common)
572 (eq (host-customary-case
573 (%pathname-host pathname))
575 (defun pathname-name (pathname &key (case :local))
577 "Return PATHNAME's name."
578 (declare (type pathname-designator pathname)
579 (type (member :local :common) case))
580 (with-pathname (pathname pathname)
581 (maybe-diddle-case (%pathname-name pathname)
582 (and (eq case :common)
583 (eq (host-customary-case
584 (%pathname-host pathname))
587 (defun pathname-type (pathname &key (case :local))
589 "Return PATHNAME's type."
590 (declare (type pathname-designator pathname)
591 (type (member :local :common) case))
592 (with-pathname (pathname pathname)
593 (maybe-diddle-case (%pathname-type pathname)
594 (and (eq case :common)
595 (eq (host-customary-case
596 (%pathname-host pathname))
599 (defun pathname-version (pathname)
601 "Return PATHNAME's version."
602 (declare (type pathname-designator pathname))
603 (with-pathname (pathname pathname)
604 (%pathname-version pathname)))
608 ;;; Handle the case for PARSE-NAMESTRING parsing a potentially
609 ;;; syntactically valid logical namestring with an explicit host.
611 ;;; This then isn't fully general -- we are relying on the fact that
612 ;;; we will only pass to parse-namestring namestring with an explicit
613 ;;; logical host, so that we can pass the host return from
614 ;;; parse-logical-namestring through to %PARSE-NAMESTRING as a truth
615 ;;; value. Yeah, this is probably a KLUDGE - CSR, 2002-04-18
616 (defun parseable-logical-namestring-p (namestr start end)
619 ((namestring-parse-error (lambda (c)
622 (let ((colon (position #\: namestr :start start :end end)))
624 (let ((potential-host
625 (logical-word-or-lose (subseq namestr start colon))))
626 ;; depending on the outcome of CSR comp.lang.lisp post
627 ;; "can PARSE-NAMESTRING create logical hosts, we may need
628 ;; to do things with potential-host (create it
629 ;; temporarily, parse the namestring and unintern the
630 ;; logical host potential-host on failure.
631 (declare (ignore potential-host))
634 ((simple-type-error (lambda (c)
637 (parse-logical-namestring namestr start end))))
638 ;; if we got this far, we should have an explicit host
639 ;; (first return value of parse-logical-namestring)
643 ;;; Handle the case where PARSE-NAMESTRING is actually parsing a
644 ;;; namestring. We pick off the :JUNK-ALLOWED case then find a host to
645 ;;; use for parsing, call the parser, then check whether the host matches.
646 (defun %parse-namestring (namestr host defaults start end junk-allowed)
647 (declare (type (or host null) host)
648 (type string namestr)
650 (type (or index null) end))
653 (%parse-namestring namestr host defaults start end nil)
654 (namestring-parse-error (condition)
655 (values nil (namestring-parse-error-offset condition))))
656 (let* ((end (or end (length namestr))))
657 (multiple-value-bind (new-host device directory file type version)
658 ;; Comments below are quotes from the HyperSpec
659 ;; PARSE-NAMESTRING entry, reproduced here to demonstrate
660 ;; that we actually have to do things this way rather than
661 ;; some possibly more logical way. - CSR, 2002-04-18
663 ;; "If host is a logical host then thing is parsed as a
664 ;; logical pathname namestring on the host."
665 (host (funcall (host-parse host) namestr start end))
666 ;; "If host is nil and thing is a syntactically valid
667 ;; logical pathname namestring containing an explicit
668 ;; host, then it is parsed as a logical pathname
670 ((parseable-logical-namestring-p namestr start end)
671 (parse-logical-namestring namestr start end))
672 ;; "If host is nil, default-pathname is a logical
673 ;; pathname, and thing is a syntactically valid logical
674 ;; pathname namestring without an explicit host, then it
675 ;; is parsed as a logical pathname namestring on the
676 ;; host that is the host component of default-pathname."
678 ;; "Otherwise, the parsing of thing is
679 ;; implementation-defined."
681 ;; Both clauses are handled here, as the default
682 ;; *DEFAULT-PATHNAME-DEFAULTS has a SB-IMPL::UNIX-HOST
684 ((pathname-host defaults)
685 (funcall (host-parse (pathname-host defaults)) namestr start end))
686 ;; I don't think we should ever get here, as the default
687 ;; host will always have a non-null HOST, given that we
688 ;; can't create a new pathname without going through
689 ;; *DEFAULT-PATHNAME-DEFAULTS*, which has a non-null
691 (t (bug "Fallen through COND in %PARSE-NAMESTRING")))
692 (when (and host new-host (not (eq new-host host)))
693 (error 'simple-type-error
695 ;; Note: ANSI requires that this be a TYPE-ERROR,
696 ;; but there seems to be no completely correct
697 ;; value to use for TYPE-ERROR-EXPECTED-TYPE.
698 ;; Instead, we return a sort of "type error allowed
699 ;; type", trying to say "it would be OK if you
700 ;; passed NIL as the host value" but not mentioning
701 ;; that a matching string would be OK too.
704 "The host in the namestring, ~S,~@
705 does not match the explicit HOST argument, ~S."
706 :format-arguments (list new-host host)))
707 (let ((pn-host (or new-host host (pathname-host defaults))))
708 (values (%make-maybe-logical-pathname
709 pn-host device directory file type version)
712 ;;; If NAMESTR begins with a colon-terminated, defined, logical host,
713 ;;; then return that host, otherwise return NIL.
714 (defun extract-logical-host-prefix (namestr start end)
715 (declare (type simple-base-string namestr)
716 (type index start end)
717 (values (or logical-host null)))
718 (let ((colon-pos (position #\: namestr :start start :end end)))
720 (values (gethash (nstring-upcase (subseq namestr start colon-pos))
724 (defun parse-namestring (thing
727 (defaults *default-pathname-defaults*)
728 &key (start 0) end junk-allowed)
729 (declare (type pathname-designator thing)
730 (type (or list host string (member :unspecific)) host)
731 (type pathname defaults)
733 (type (or index null) end)
734 (type (or t null) junk-allowed)
735 (values (or null pathname) (or null index)))
736 ;; Generally, redundant specification of information in software,
737 ;; whether in code or in comments, is bad. However, the ANSI spec
738 ;; for this is messy enough that it's hard to hold in short-term
739 ;; memory, so I've recorded these redundant notes on the
740 ;; implications of the ANSI spec.
742 ;; According to the ANSI spec, HOST can be a valid pathname host, or
743 ;; a logical host, or NIL.
745 ;; A valid pathname host can be a valid physical pathname host or a
746 ;; valid logical pathname host.
748 ;; A valid physical pathname host is "any of a string, a list of
749 ;; strings, or the symbol :UNSPECIFIC, that is recognized by the
750 ;; implementation as the name of a host". In SBCL as of 0.6.9.8,
751 ;; that means :UNSPECIFIC: though someday we might want to
752 ;; generalize it to allow strings like "RTFM.MIT.EDU" or lists like
753 ;; '("RTFM" "MIT" "EDU"), that's not supported now.
755 ;; A valid logical pathname host is a string which has been defined as
756 ;; the name of a logical host, as with LOAD-LOGICAL-PATHNAME-TRANSLATIONS.
758 ;; A logical host is an object of implementation-dependent nature. In
759 ;; SBCL, it's a member of the HOST class (a subclass of STRUCTURE-OBJECT).
760 (let ((found-host (etypecase host
762 ;; In general ANSI-compliant Common Lisps, a
763 ;; string might also be a physical pathname host,
764 ;; but ANSI leaves this up to the implementor,
765 ;; and in SBCL we don't do it, so it must be a
767 (find-logical-host host))
768 ((or null (member :unspecific))
769 ;; CLHS says that HOST=:UNSPECIFIC has
770 ;; implementation-defined behavior. We
771 ;; just turn it into NIL.
774 ;; ANSI also allows LISTs to designate hosts,
775 ;; but leaves its interpretation
776 ;; implementation-defined. Our interpretation
777 ;; is that it's unsupported.:-|
778 (error "A LIST representing a pathname host is not ~
779 supported in this implementation:~% ~S"
783 (declare (type (or null host) found-host))
786 (%parse-namestring thing found-host defaults start end junk-allowed))
788 (%parse-namestring (coerce thing 'simple-string)
789 found-host defaults start end junk-allowed))
791 (let ((defaulted-host (or found-host (%pathname-host defaults))))
792 (declare (type host defaulted-host))
793 (unless (eq defaulted-host (%pathname-host thing))
794 (error "The HOST argument doesn't match the pathname host:~% ~
796 defaulted-host (%pathname-host thing))))
797 (values thing start))
799 (let ((name (file-name thing)))
801 (error "can't figure out the file associated with stream:~% ~S"
803 (values name nil))))))
805 (defun namestring (pathname)
807 "Construct the full (name)string form of the pathname."
808 (declare (type pathname-designator pathname)
809 (values (or null simple-base-string)))
810 (with-pathname (pathname pathname)
812 (let ((host (%pathname-host pathname)))
814 (error "can't determine the namestring for pathnames with no ~
815 host:~% ~S" pathname))
816 (funcall (host-unparse host) pathname)))))
818 (defun host-namestring (pathname)
820 "Return a string representation of the name of the host in the pathname."
821 (declare (type pathname-designator pathname)
822 (values (or null simple-base-string)))
823 (with-pathname (pathname pathname)
824 (let ((host (%pathname-host pathname)))
826 (funcall (host-unparse-host host) pathname)
828 "can't determine the namestring for pathnames with no host:~% ~S"
831 (defun directory-namestring (pathname)
833 "Return a string representation of the directories used in the pathname."
834 (declare (type pathname-designator pathname)
835 (values (or null simple-base-string)))
836 (with-pathname (pathname pathname)
837 (let ((host (%pathname-host pathname)))
839 (funcall (host-unparse-directory host) pathname)
841 "can't determine the namestring for pathnames with no host:~% ~S"
844 (defun file-namestring (pathname)
846 "Return a string representation of the name used in the pathname."
847 (declare (type pathname-designator pathname)
848 (values (or null simple-base-string)))
849 (with-pathname (pathname pathname)
850 (let ((host (%pathname-host pathname)))
852 (funcall (host-unparse-file host) pathname)
854 "can't determine the namestring for pathnames with no host:~% ~S"
857 (defun enough-namestring (pathname
859 (defaults *default-pathname-defaults*))
861 "Return an abbreviated pathname sufficent to identify the pathname relative
863 (declare (type pathname-designator pathname))
864 (with-pathname (pathname pathname)
865 (let ((host (%pathname-host pathname)))
867 (with-pathname (defaults defaults)
868 (funcall (host-unparse-enough host) pathname defaults))
870 "can't determine the namestring for pathnames with no host:~% ~S"
875 (defun wild-pathname-p (pathname &optional field-key)
877 "Predicate for determining whether pathname contains any wildcards."
878 (declare (type pathname-designator pathname)
879 (type (member nil :host :device :directory :name :type :version)
881 (with-pathname (pathname pathname)
883 (or (pattern-p x) (member x '(:wild :wild-inferiors)))))
886 (or (wild-pathname-p pathname :host)
887 (wild-pathname-p pathname :device)
888 (wild-pathname-p pathname :directory)
889 (wild-pathname-p pathname :name)
890 (wild-pathname-p pathname :type)
891 (wild-pathname-p pathname :version)))
892 (:host (frob (%pathname-host pathname)))
893 (:device (frob (%pathname-host pathname)))
894 (:directory (some #'frob (%pathname-directory pathname)))
895 (:name (frob (%pathname-name pathname)))
896 (:type (frob (%pathname-type pathname)))
897 (:version (frob (%pathname-version pathname)))))))
899 (defun pathname-match-p (in-pathname in-wildname)
901 "Pathname matches the wildname template?"
902 (declare (type pathname-designator in-pathname))
903 (with-pathname (pathname in-pathname)
904 (with-pathname (wildname in-wildname)
905 (macrolet ((frob (field &optional (op 'components-match ))
906 `(or (null (,field wildname))
907 (,op (,field pathname) (,field wildname)))))
908 (and (or (null (%pathname-host wildname))
909 (eq (%pathname-host wildname) (%pathname-host pathname)))
910 (frob %pathname-device)
911 (frob %pathname-directory directory-components-match)
912 (frob %pathname-name)
913 (frob %pathname-type)
914 (frob %pathname-version))))))
916 ;;; Place the substitutions into the pattern and return the string or pattern
917 ;;; that results. If DIDDLE-CASE is true, we diddle the result case as well,
918 ;;; in case we are translating between hosts with difference conventional case.
919 ;;; The second value is the tail of subs with all of the values that we used up
920 ;;; stripped off. Note that PATTERN-MATCHES matches all consecutive wildcards
921 ;;; as a single string, so we ignore subsequent contiguous wildcards.
922 (defun substitute-into (pattern subs diddle-case)
923 (declare (type pattern pattern)
925 (values (or simple-base-string pattern) list))
926 (let ((in-wildcard nil)
929 (dolist (piece (pattern-pieces pattern))
930 (cond ((simple-string-p piece)
932 (setf in-wildcard nil))
937 (error "not enough wildcards in FROM pattern to match ~
940 (let ((sub (pop subs)))
944 (push (apply #'concatenate 'simple-string
947 (dolist (piece (pattern-pieces sub))
948 (push piece pieces)))
952 (error "can't substitute this into the middle of a word:~
957 (push (apply #'concatenate 'simple-string (nreverse strings))
961 (if (and pieces (simple-string-p (car pieces)) (null (cdr pieces)))
963 (make-pattern (nreverse pieces)))
967 ;;; Called when we can't see how source and from matched.
968 (defun didnt-match-error (source from)
969 (error "Pathname components from SOURCE and FROM args to TRANSLATE-PATHNAME~@
970 did not match:~% ~S ~S"
973 ;;; Do TRANSLATE-COMPONENT for all components except host and directory.
974 (defun translate-component (source from to diddle-case)
981 (if (pattern= from source)
983 (didnt-match-error source from)))
985 (multiple-value-bind (won subs) (pattern-matches from source)
987 (values (substitute-into to subs diddle-case))
988 (didnt-match-error source from))))
990 (maybe-diddle-case source diddle-case))))
992 (values (substitute-into to (list source) diddle-case)))
994 (if (components-match source from)
995 (maybe-diddle-case source diddle-case)
996 (didnt-match-error source from)))))
998 (maybe-diddle-case source diddle-case))
1000 (if (components-match source from)
1002 (didnt-match-error source from)))))
1004 ;;; Return a list of all the things that we want to substitute into the TO
1005 ;;; pattern (the things matched by from on source.) When From contains
1006 ;;; :WILD-INFERIORS, the result contains a sublist of the matched source
1008 (defun compute-directory-substitutions (orig-source orig-from)
1009 (let ((source orig-source)
1014 (unless (every (lambda (x) (eq x :wild-inferiors)) from)
1015 (didnt-match-error orig-source orig-from))
1018 (unless from (didnt-match-error orig-source orig-from))
1019 (let ((from-part (pop from))
1020 (source-part (pop source)))
1023 (typecase source-part
1025 (if (pattern= from-part source-part)
1027 (didnt-match-error orig-source orig-from)))
1029 (multiple-value-bind (won new-subs)
1030 (pattern-matches from-part source-part)
1032 (dolist (sub new-subs)
1034 (didnt-match-error orig-source orig-from))))
1036 (didnt-match-error orig-source orig-from))))
1039 ((member :wild-inferiors)
1040 (let ((remaining-source (cons source-part source)))
1043 (when (directory-components-match remaining-source from)
1045 (unless remaining-source
1046 (didnt-match-error orig-source orig-from))
1047 (res (pop remaining-source)))
1049 (setq source remaining-source))))
1051 (unless (and (simple-string-p source-part)
1052 (string= from-part source-part))
1053 (didnt-match-error orig-source orig-from)))
1055 (didnt-match-error orig-source orig-from)))))
1058 ;;; This is called by TRANSLATE-PATHNAME on the directory components
1059 ;;; of its argument pathnames to produce the result directory
1060 ;;; component. If this leaves the directory NIL, we return the source
1061 ;;; directory. The :RELATIVE or :ABSOLUTE is taken from the source
1062 ;;; directory, except if TO is :ABSOLUTE, in which case the result
1063 ;;; will be :ABSOLUTE.
1064 (defun translate-directories (source from to diddle-case)
1065 (if (not (and source to from))
1066 (or (and to (null source) (remove :wild-inferiors to))
1067 (mapcar (lambda (x) (maybe-diddle-case x diddle-case)) source))
1069 ;; If TO is :ABSOLUTE, the result should still be :ABSOLUTE.
1070 (res (if (eq (first to) :absolute)
1073 (let ((subs-left (compute-directory-substitutions (rest source)
1075 (dolist (to-part (rest to))
1079 (let ((match (pop subs-left)))
1081 (error ":WILD-INFERIORS is not paired in from and to ~
1082 patterns:~% ~S ~S" from to))
1083 (res (maybe-diddle-case match diddle-case))))
1084 ((member :wild-inferiors)
1086 (let ((match (pop subs-left)))
1087 (unless (listp match)
1088 (error ":WILD-INFERIORS not paired in from and to ~
1089 patterns:~% ~S ~S" from to))
1091 (res (maybe-diddle-case x diddle-case)))))
1093 (multiple-value-bind
1095 (substitute-into to-part subs-left diddle-case)
1096 (setf subs-left new-subs-left)
1098 (t (res to-part)))))
1101 (defun translate-pathname (source from-wildname to-wildname &key)
1103 "Use the source pathname to translate the from-wildname's wild and
1104 unspecified elements into a completed to-pathname based on the to-wildname."
1105 (declare (type pathname-designator source from-wildname to-wildname))
1106 (with-pathname (source source)
1107 (with-pathname (from from-wildname)
1108 (with-pathname (to to-wildname)
1109 (let* ((source-host (%pathname-host source))
1110 (to-host (%pathname-host to))
1112 (and source-host to-host
1113 (not (eq (host-customary-case source-host)
1114 (host-customary-case to-host))))))
1115 (macrolet ((frob (field &optional (op 'translate-component))
1116 `(let ((result (,op (,field source)
1120 (if (eq result :error)
1121 (error "~S doesn't match ~S." source from)
1123 (%make-maybe-logical-pathname
1124 (or to-host source-host)
1125 (frob %pathname-device)
1126 (frob %pathname-directory translate-directories)
1127 (frob %pathname-name)
1128 (frob %pathname-type)
1129 (frob %pathname-version))))))))
1131 ;;;; logical pathname support. ANSI 92-102 specification.
1133 ;;;; As logical-pathname translations are loaded they are
1134 ;;;; canonicalized as patterns to enable rapid efficient translation
1135 ;;;; into physical pathnames.
1139 ;;; Canonicalize a logical pathname word by uppercasing it checking that it
1140 ;;; contains only legal characters.
1141 (defun logical-word-or-lose (word)
1142 (declare (string word))
1143 (let ((word (string-upcase word)))
1144 (dotimes (i (length word))
1145 (let ((ch (schar word i)))
1146 (unless (or (alpha-char-p ch) (digit-char-p ch) (char= ch #\-))
1147 (error 'namestring-parse-error
1148 :complaint "logical namestring character which ~
1149 is not alphanumeric or hyphen:~% ~S"
1151 :namestring word :offset i))))
1154 ;;; Given a logical host or string, return a logical host. If ERROR-P
1155 ;;; is NIL, then return NIL when no such host exists.
1156 (defun find-logical-host (thing &optional (errorp t))
1159 (let ((found (gethash (logical-word-or-lose thing)
1161 (if (or found (not errorp))
1163 ;; This is the error signalled from e.g.
1164 ;; LOGICAL-PATHNAME-TRANSLATIONS when host is not a defined
1165 ;; host, and ANSI specifies that that's a TYPE-ERROR.
1166 (error 'simple-type-error
1168 ;; God only knows what ANSI expects us to use for
1169 ;; the EXPECTED-TYPE here. Maybe this will be OK..
1171 '(and string (satisfies logical-pathname-translations))
1172 :format-control "logical host not yet defined: ~S"
1173 :format-arguments (list thing)))))
1174 (logical-host thing)))
1176 ;;; Given a logical host name or host, return a logical host, creating
1177 ;;; a new one if necessary.
1178 (defun intern-logical-host (thing)
1179 (declare (values logical-host))
1180 (or (find-logical-host thing nil)
1181 (let* ((name (logical-word-or-lose thing))
1182 (new (make-logical-host :name name)))
1183 (setf (gethash name *logical-hosts*) new)
1186 ;;;; logical pathname parsing
1188 ;;; Deal with multi-char wildcards in a logical pathname token.
1189 (defun maybe-make-logical-pattern (namestring chunks)
1190 (let ((chunk (caar chunks)))
1191 (collect ((pattern))
1193 (len (length chunk)))
1194 (declare (fixnum last-pos))
1196 (when (= last-pos len) (return))
1197 (let ((pos (or (position #\* chunk :start last-pos) len)))
1198 (if (= pos last-pos)
1200 (error 'namestring-parse-error
1201 :complaint "double asterisk inside of logical ~
1204 :namestring namestring
1205 :offset (+ (cdar chunks) pos)))
1206 (pattern (subseq chunk last-pos pos)))
1209 (pattern :multi-char-wild))
1210 (setq last-pos (1+ pos)))))
1213 (make-pattern (pattern))
1214 (let ((x (car (pattern))))
1215 (if (eq x :multi-char-wild)
1219 ;;; Return a list of conses where the CDR is the start position and
1220 ;;; the CAR is a string (token) or character (punctuation.)
1221 (defun logical-chunkify (namestr start end)
1223 (do ((i start (1+ i))
1227 (chunks (cons (nstring-upcase (subseq namestr prev end)) prev))))
1228 (let ((ch (schar namestr i)))
1229 (unless (or (alpha-char-p ch) (digit-char-p ch)
1230 (member ch '(#\- #\*)))
1232 (chunks (cons (nstring-upcase (subseq namestr prev i)) prev)))
1234 (unless (member ch '(#\; #\: #\.))
1235 (error 'namestring-parse-error
1236 :complaint "illegal character for logical pathname:~% ~S"
1240 (chunks (cons ch i)))))
1243 ;;; Break up a logical-namestring, always a string, into its
1244 ;;; constituent parts.
1245 (defun parse-logical-namestring (namestr start end)
1246 (declare (type simple-base-string namestr)
1247 (type index start end))
1248 (collect ((directory))
1253 (labels ((expecting (what chunks)
1254 (unless (and chunks (simple-string-p (caar chunks)))
1255 (error 'namestring-parse-error
1256 :complaint "expecting ~A, got ~:[nothing~;~S~]."
1257 :args (list what (caar chunks) (caar chunks))
1259 :offset (if chunks (cdar chunks) end)))
1261 (parse-host (chunks)
1262 (case (caadr chunks)
1265 (find-logical-host (expecting "a host name" chunks)))
1266 (parse-relative (cddr chunks)))
1268 (parse-relative chunks))))
1269 (parse-relative (chunks)
1272 (directory :relative)
1273 (parse-directory (cdr chunks)))
1275 (directory :absolute) ; Assumption! Maybe revoked later.
1276 (parse-directory chunks))))
1277 (parse-directory (chunks)
1278 (case (caadr chunks)
1281 (let ((res (expecting "a directory name" chunks)))
1282 (cond ((string= res "..") :up)
1283 ((string= res "**") :wild-inferiors)
1285 (maybe-make-logical-pattern namestr chunks)))))
1286 (parse-directory (cddr chunks)))
1288 (parse-name chunks))))
1289 (parse-name (chunks)
1291 (expecting "a file name" chunks)
1292 (setq name (maybe-make-logical-pattern namestr chunks))
1293 (expecting-dot (cdr chunks))))
1294 (expecting-dot (chunks)
1296 (unless (eql (caar chunks) #\.)
1297 (error 'namestring-parse-error
1298 :complaint "expecting a dot, got ~S."
1299 :args (list (caar chunks))
1301 :offset (cdar chunks)))
1303 (parse-version (cdr chunks))
1304 (parse-type (cdr chunks)))))
1305 (parse-type (chunks)
1306 (expecting "a file type" chunks)
1307 (setq type (maybe-make-logical-pattern namestr chunks))
1308 (expecting-dot (cdr chunks)))
1309 (parse-version (chunks)
1310 (let ((str (expecting "a positive integer, * or NEWEST"
1313 ((string= str "*") (setq version :wild))
1314 ((string= str "NEWEST") (setq version :newest))
1316 (multiple-value-bind (res pos)
1317 (parse-integer str :junk-allowed t)
1318 (unless (and res (plusp res))
1319 (error 'namestring-parse-error
1320 :complaint "expected a positive integer, ~
1324 :offset (+ pos (cdar chunks))))
1325 (setq version res)))))
1327 (error 'namestring-parse-error
1328 :complaint "extra stuff after end of file name"
1330 :offset (cdadr chunks)))))
1331 (parse-host (logical-chunkify namestr start end)))
1332 (values host :unspecific (directory) name type version))))
1334 ;;; We can't initialize this yet because not all host methods are
1336 (defvar *logical-pathname-defaults*)
1338 (defun logical-pathname (pathspec)
1340 "Converts the pathspec argument to a logical-pathname and returns it."
1341 (declare (type (or logical-pathname string stream) pathspec)
1342 (values logical-pathname))
1343 (if (typep pathspec 'logical-pathname)
1345 (let ((res (parse-namestring pathspec nil *logical-pathname-defaults*)))
1346 (when (eq (%pathname-host res)
1347 (%pathname-host *logical-pathname-defaults*))
1348 (error "This logical namestring does not specify a host:~% ~S"
1352 ;;;; logical pathname unparsing
1354 (defun unparse-logical-directory (pathname)
1355 (declare (type pathname pathname))
1357 (let ((directory (%pathname-directory pathname)))
1359 (ecase (pop directory)
1360 (:absolute) ; nothing special
1361 (:relative (pieces ";")))
1362 (dolist (dir directory)
1363 (cond ((or (stringp dir) (pattern-p dir))
1364 (pieces (unparse-logical-piece dir))
1368 ((eq dir :wild-inferiors)
1371 (error "invalid directory component: ~S" dir))))))
1372 (apply #'concatenate 'simple-string (pieces))))
1374 (defun unparse-logical-piece (thing)
1376 (simple-string thing)
1378 (collect ((strings))
1379 (dolist (piece (pattern-pieces thing))
1381 (simple-string (strings piece))
1383 (cond ((eq piece :wild-inferiors)
1385 ((eq piece :multi-char-wild)
1387 (t (error "invalid keyword: ~S" piece))))))
1388 (apply #'concatenate 'simple-string (strings))))))
1390 ;;; Unparse a logical pathname string.
1391 (defun unparse-enough-namestring (pathname defaults)
1392 (let* ((path-directory (pathname-directory pathname))
1393 (def-directory (pathname-directory defaults))
1395 ;; Go down the directory lists to see what matches. What's
1396 ;; left is what we want, more or less.
1397 (cond ((and (eq (first path-directory) (first def-directory))
1398 (eq (first path-directory) :absolute))
1399 ;; Both paths are :ABSOLUTE, so find where the
1400 ;; common parts end and return what's left
1401 (do* ((p (rest path-directory) (rest p))
1402 (d (rest def-directory) (rest d)))
1403 ((or (endp p) (endp d)
1404 (not (equal (first p) (first d))))
1407 ;; At least one path is :RELATIVE, so just return the
1408 ;; original path. If the original path is :RELATIVE,
1409 ;; then that's the right one. If PATH-DIRECTORY is
1410 ;; :ABSOLUTE, we want to return that except when
1411 ;; DEF-DIRECTORY is :ABSOLUTE, as handled above. so return
1412 ;; the original directory.
1414 (make-pathname :host (pathname-host pathname)
1415 :directory enough-directory
1416 :name (pathname-name pathname)
1417 :type (pathname-type pathname)
1418 :version (pathname-version pathname))))
1420 (defun unparse-logical-namestring (pathname)
1421 (declare (type logical-pathname pathname))
1422 (concatenate 'simple-string
1423 (logical-host-name (%pathname-host pathname)) ":"
1424 (unparse-logical-directory pathname)
1425 (unparse-unix-file pathname)))
1427 ;;;; logical pathname translations
1429 ;;; Verify that the list of translations consists of lists and prepare
1430 ;;; canonical translations. (Parse pathnames and expand out wildcards
1432 (defun canonicalize-logical-pathname-translations (translation-list host)
1433 (declare (type list translation-list) (type host host)
1435 (mapcar (lambda (translation)
1436 (destructuring-bind (from to) translation
1437 (list (if (typep from 'logical-pathname)
1439 (parse-namestring from host))
1443 (defun logical-pathname-translations (host)
1445 "Return the (logical) host object argument's list of translations."
1446 (declare (type (or string logical-host) host)
1448 (logical-host-translations (find-logical-host host)))
1450 (defun (setf logical-pathname-translations) (translations host)
1452 "Set the translations list for the logical host argument."
1453 (declare (type (or string logical-host) host)
1454 (type list translations)
1456 (let ((host (intern-logical-host host)))
1457 (setf (logical-host-canon-transls host)
1458 (canonicalize-logical-pathname-translations translations host))
1459 (setf (logical-host-translations host) translations)))
1461 ;;; KLUDGE: Ordinarily known functions aren't defined recursively, and
1462 ;;; it's common for compiler problems (e.g. missing/broken
1463 ;;; optimization transforms) to cause them to recurse inadvertently,
1464 ;;; so the compiler should warn about it. But the natural definition
1465 ;;; of TRANSLATE-LOGICAL-PATHNAME *is* recursive; and we don't want
1466 ;;; the warning, so we hide the definition of T-L-P in this
1467 ;;; differently named function so that the compiler won't warn about
1468 ;;; it. -- WHN 2001-09-16
1469 (defun %translate-logical-pathname (pathname)
1470 (declare (type pathname-designator pathname)
1471 (values (or null pathname)))
1474 (dolist (x (logical-host-canon-transls (%pathname-host pathname))
1475 (error 'simple-file-error
1477 :format-control "no translation for ~S"
1478 :format-arguments (list pathname)))
1479 (destructuring-bind (from to) x
1480 (when (pathname-match-p pathname from)
1481 (return (translate-logical-pathname
1482 (translate-pathname pathname from to)))))))
1484 (stream (translate-logical-pathname (pathname pathname)))
1485 (t (translate-logical-pathname (logical-pathname pathname)))))
1487 (defun translate-logical-pathname (pathname &key)
1489 "Translate PATHNAME to a physical pathname, which is returned."
1490 (declare (type pathname-designator pathname)
1491 (values (or null pathname)))
1492 (%translate-logical-pathname pathname))
1494 (defvar *logical-pathname-defaults*
1495 (%make-logical-pathname (make-logical-host :name "BOGUS")
1502 (defun load-logical-pathname-translations (host)
1504 (declare (type string host)
1505 (values (member t nil)))
1506 (if (find-logical-host host nil)
1507 ;; This host is already defined, all is well and good.
1509 ;; ANSI: "The specific nature of the search is
1510 ;; implementation-defined." SBCL: doesn't search at all
1511 (error "logical host ~S not found" host)))