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")
17 #!-sb-fluid (declaim (freeze-type logical-pathname logical-host))
21 (def!method print-object ((host host) stream)
22 (print-unreadable-object (host stream :type t :identity t)))
26 (def!method print-object ((pathname pathname) stream)
27 (let ((namestring (handler-case (namestring pathname)
30 (format stream "#P~S" namestring)
31 ;; FIXME: This code was rewritten and should be tested. (How does
32 ;; control get to this case anyhow? Perhaps we could just punt it?)
33 (print-unreadable-object (pathname stream :type t)
35 "(with no namestring) :HOST ~S :DEVICE ~S :DIRECTORY ~S ~
36 :NAME ~S :TYPE ~S :VERSION ~S"
37 (%pathname-host pathname)
38 (%pathname-device pathname)
39 (%pathname-directory pathname)
40 (%pathname-name pathname)
41 (%pathname-type pathname)
42 (%pathname-version pathname))))))
44 (def!method make-load-form ((pathname pathname) &optional environment)
45 (make-load-form-saving-slots pathname :environment environment))
47 ;;; The potential conflict with search-lists requires isolating the printed
48 ;;; representation to use the i/o macro #.(logical-pathname <path-designator>).
50 ;;; FIXME: We don't use search lists any more, so that comment is stale, right?
51 (def!method print-object ((pathname logical-pathname) stream)
52 (let ((namestring (handler-case (namestring pathname)
55 (format stream "#.(logical-pathname ~S)" namestring)
56 (print-unreadable-object (pathname stream :type t)
58 ":HOST ~S :DIRECTORY ~S :FILE ~S :NAME=~S :VERSION ~S"
59 (%pathname-host pathname)
60 (%pathname-directory pathname)
61 (%pathname-name pathname)
62 (%pathname-type pathname)
63 (%pathname-version pathname))))))
65 ;;; A pathname is logical if the host component is a logical-host.
66 ;;; This constructor is used to make an instance of the correct type
67 ;;; from parsed arguments.
68 (defun %make-pathname-object (host device directory name type version)
69 (if (typep host 'logical-host)
70 (%make-logical-pathname host :unspecific directory name type version)
71 (%make-pathname host device directory name type version)))
73 ;;; Hash table searching maps a logical-pathname's host to their physical
74 ;;; pathname translation.
75 (defvar *logical-hosts* (make-hash-table :test 'equal))
79 (def!method make-load-form ((pattern pattern) &optional environment)
80 (make-load-form-saving-slots pattern :environment environment))
82 (def!method print-object ((pattern pattern) stream)
83 (print-unreadable-object (pattern stream :type t)
85 (let ((*print-escape* t))
86 (pprint-fill stream (pattern-pieces pattern) nil))
87 (prin1 (pattern-pieces pattern) stream))))
89 (defun pattern= (pattern1 pattern2)
90 (declare (type pattern pattern1 pattern2))
91 (let ((pieces1 (pattern-pieces pattern1))
92 (pieces2 (pattern-pieces pattern2)))
93 (and (= (length pieces1) (length pieces2))
94 (every #'(lambda (piece1 piece2)
97 (and (simple-string-p piece2)
98 (string= piece1 piece2)))
101 (eq (car piece1) (car piece2))
102 (string= (cdr piece1) (cdr piece2))))
104 (eq piece1 piece2))))
108 ;;; If the string matches the pattern returns the multiple values T and a
109 ;;; list of the matched strings.
110 (defun pattern-matches (pattern string)
111 (declare (type pattern pattern)
112 (type simple-string string))
113 (let ((len (length string)))
114 (labels ((maybe-prepend (subs cur-sub chars)
116 (let* ((len (length chars))
117 (new (make-string len))
120 (setf (schar new (decf index)) char))
123 (matches (pieces start subs cur-sub chars)
126 (values t (maybe-prepend subs cur-sub chars))
128 (let ((piece (car pieces)))
131 (let ((end (+ start (length piece))))
133 (string= piece string
134 :start2 start :end2 end)
135 (matches (cdr pieces) end
136 (maybe-prepend subs cur-sub chars)
142 (let ((char (schar string start)))
143 (if (find char (cdr piece) :test #'char=)
144 (matches (cdr pieces) (1+ start) subs t
145 (cons char chars))))))))
146 ((member :single-char-wild)
148 (matches (cdr pieces) (1+ start) subs t
149 (cons (schar string start) chars))))
150 ((member :multi-char-wild)
151 (multiple-value-bind (won new-subs)
152 (matches (cdr pieces) start subs t chars)
156 (matches pieces (1+ start) subs t
157 (cons (schar string start)
159 (multiple-value-bind (won subs)
160 (matches (pattern-pieces pattern) 0 nil nil nil)
161 (values won (reverse subs))))))
163 ;;; Pathname-match-p for directory components.
164 (defun directory-components-match (thing wild)
168 (let ((wild1 (first wild)))
169 (if (eq wild1 :wild-inferiors)
170 (let ((wild-subdirs (rest wild)))
171 (or (null wild-subdirs)
173 (when (directory-components-match thing wild-subdirs)
176 (unless thing (return nil)))))
178 (components-match (first thing) wild1)
179 (directory-components-match (rest thing)
182 ;;; Return true if pathname component THING is matched by WILD. (not
184 (defun components-match (thing wild)
185 (declare (type (or pattern symbol simple-string integer) thing wild))
190 ;; String is matched by itself, a matching pattern or :WILD.
193 (values (pattern-matches wild thing)))
195 (string= thing wild))))
197 ;; A pattern is only matched by an identical pattern.
198 (and (pattern-p wild) (pattern= thing wild)))
200 ;; an integer (version number) is matched by :WILD or the same
201 ;; integer. This branch will actually always be NIL as long as the
202 ;; version is a fixnum.
205 ;;; A predicate for comparing two pathname slot component sub-entries.
206 (defun compare-component (this that)
210 (and (simple-string-p that)
211 (string= this that)))
213 (and (pattern-p that)
214 (pattern= this that)))
217 (compare-component (car this) (car that))
218 (compare-component (cdr this) (cdr that)))))))
220 ;;;; pathname functions
222 ;;; implementation-determined defaults to pathname slots
223 (defvar *default-pathname-defaults*)
225 (defun pathname= (pathname1 pathname2)
226 (declare (type pathname pathname1)
227 (type pathname pathname2))
228 (and (eq (%pathname-host pathname1)
229 (%pathname-host pathname2))
230 (compare-component (%pathname-device pathname1)
231 (%pathname-device pathname2))
232 (compare-component (%pathname-directory pathname1)
233 (%pathname-directory pathname2))
234 (compare-component (%pathname-name pathname1)
235 (%pathname-name pathname2))
236 (compare-component (%pathname-type pathname1)
237 (%pathname-type pathname2))
238 (compare-component (%pathname-version pathname1)
239 (%pathname-version pathname2))))
241 ;;; Convert PATHNAME-DESIGNATOR (a pathname, or string, or
242 ;;; stream), into a pathname in pathname.
244 ;;; FIXME: was rewritten, should be tested (or rewritten again, this
245 ;;; time using ONCE-ONLY, *then* tested)
246 ;;; FIXME: become SB!XC:DEFMACRO inside EVAL-WHEN (COMPILE EVAL)?
247 (defmacro with-pathname ((pathname pathname-designator) &body body)
248 (let ((pd0 (gensym)))
249 `(let* ((,pd0 ,pathname-designator)
250 (,pathname (etypecase ,pd0
252 (string (parse-namestring ,pd0))
253 (stream (file-name ,pd0)))))
256 ;;; Converts the var, a host or string name for a host, into a logical-host
257 ;;; structure or nil if not defined.
259 ;;; pw notes 1/12/97 this potentially useful macro is not used anywhere
260 ;;; and 'find-host' is not defined. 'find-logical-host' seems to be needed.
262 (defmacro with-host ((var expr) &body body)
263 `(let ((,var (let ((,var ,expr))
266 (string (find-logical-host ,var nil))
271 (defun pathname (thing)
273 "Convert thing (a pathname, string or stream) into a pathname."
274 (declare (type pathname-designator thing))
275 (with-pathname (pathname thing)
278 ;;; Change the case of thing if DIDDLE-P.
279 (defun maybe-diddle-case (thing diddle-p)
280 (if (and diddle-p (not (or (symbolp thing) (integerp thing))))
281 (labels ((check-for (pred in)
284 (dolist (piece (pattern-pieces in))
285 (when (typecase piece
287 (check-for pred piece))
291 (check-for pred (cdr in))))))
295 (when (check-for pred x)
298 (dotimes (i (length in))
299 (when (funcall pred (schar in i))
302 (diddle-with (fun thing)
306 (mapcar #'(lambda (piece)
314 (funcall fun (cdr piece))))
319 (pattern-pieces thing))))
326 (let ((any-uppers (check-for #'upper-case-p thing))
327 (any-lowers (check-for #'lower-case-p thing)))
328 (cond ((and any-uppers any-lowers)
329 ;; Mixed case, stays the same.
332 ;; All uppercase, becomes all lower case.
333 (diddle-with #'(lambda (x) (if (stringp x)
337 ;; All lowercase, becomes all upper case.
338 (diddle-with #'(lambda (x) (if (stringp x)
342 ;; No letters? I guess just leave it.
346 (defun merge-directories (dir1 dir2 diddle-case)
347 (if (or (eq (car dir1) :absolute)
352 (if (and (eq dir :back)
354 (not (eq (car results) :back)))
356 (push dir results))))
357 (dolist (dir (maybe-diddle-case dir2 diddle-case))
359 (dolist (dir (cdr dir1))
363 (defun merge-pathnames (pathname
365 (defaults *default-pathname-defaults*)
366 (default-version :newest))
368 "Construct a filled in pathname by completing the unspecified components
370 (declare (type pathname-designator pathname)
371 (type pathname-designator defaults)
373 (with-pathname (defaults defaults)
374 (let ((pathname (let ((*default-pathname-defaults* defaults))
375 (pathname pathname))))
376 (let* ((default-host (%pathname-host defaults))
377 (pathname-host (%pathname-host pathname))
379 (and default-host pathname-host
380 (not (eq (host-customary-case default-host)
381 (host-customary-case pathname-host))))))
382 (%make-pathname-object
383 (or pathname-host default-host)
384 (or (%pathname-device pathname)
385 (maybe-diddle-case (%pathname-device defaults)
387 (merge-directories (%pathname-directory pathname)
388 (%pathname-directory defaults)
390 (or (%pathname-name pathname)
391 (maybe-diddle-case (%pathname-name defaults)
393 (or (%pathname-type pathname)
394 (maybe-diddle-case (%pathname-type defaults)
396 (or (%pathname-version pathname)
397 default-version))))))
399 (defun import-directory (directory diddle-case)
402 ((member :wild) '(:absolute :wild-inferiors))
403 ((member :unspecific) '(:relative))
406 (ecase (pop directory)
409 (when (search-list-p (car directory))
410 (results (pop directory))))
412 (results :relative)))
413 (dolist (piece directory)
414 (cond ((member piece '(:wild :wild-inferiors :up :back))
416 ((or (simple-string-p piece) (pattern-p piece))
417 (results (maybe-diddle-case piece diddle-case)))
419 (results (maybe-diddle-case (coerce piece 'simple-string)
422 (error "~S is not allowed as a directory component." piece))))
426 ,(maybe-diddle-case directory diddle-case)))
429 ,(maybe-diddle-case (coerce directory 'simple-string)
432 (defun make-pathname (&key host
437 (version nil versionp)
441 "Makes a new pathname from the component arguments. Note that host is
442 a host-structure or string."
443 (declare (type (or string host component-tokens) host)
444 (type (or string component-tokens) device)
445 (type (or list string pattern component-tokens) directory)
446 (type (or string pattern component-tokens) name type)
447 (type (or integer component-tokens (member :newest)) version)
448 (type (or pathname-designator null) defaults)
449 (type (member :common :local) case))
450 (let* ((defaults (when defaults
451 (with-pathname (defaults defaults) defaults)))
452 (default-host (if defaults
453 (%pathname-host defaults)
454 (pathname-host *default-pathname-defaults*)))
455 ;; toy@rtp.ericsson.se: CLHS says make-pathname can take a
456 ;; string (as a logical-host) for the host part. We map that
457 ;; string into the corresponding logical host structure.
460 ;; HyperSpec says for the arg to MAKE-PATHNAME;
461 ;; "host---a valid physical pathname host. ..."
462 ;; where it probably means -- a valid pathname host.
463 ;; "valid pathname host n. a valid physical pathname host or
464 ;; a valid logical pathname host."
466 ;; "valid physical pathname host n. any of a string,
467 ;; a list of strings, or the symbol :unspecific,
468 ;; that is recognized by the implementation as the name of a host."
469 ;; "valid logical pathname host n. a string that has been defined
470 ;; as the name of a logical host. ..."
471 ;; HS is silent on what happens if the :host arg is NOT one of these.
472 ;; It seems an error message is appropriate.
474 (host host) ; A valid host, use it.
475 (string (find-logical-host host t)) ; logical-host or lose.
476 (t default-host))) ; unix-host
477 (diddle-args (and (eq (host-customary-case host) :lower)
480 (not (eq (host-customary-case host)
481 (host-customary-case default-host))))
482 (dev (if devp device (if defaults (%pathname-device defaults))))
483 (dir (import-directory directory diddle-args))
486 (defaults (%pathname-version defaults))
488 (when (and defaults (not dirp))
490 (merge-directories dir
491 (%pathname-directory defaults)
494 (macrolet ((pick (var varp field)
495 `(cond ((or (simple-string-p ,var)
497 (maybe-diddle-case ,var diddle-args))
499 (maybe-diddle-case (coerce ,var 'simple-string)
502 (maybe-diddle-case ,var diddle-args))
504 (maybe-diddle-case (,field defaults)
508 (%make-pathname-object host
509 dev ; forced to :unspecific when logical-host
511 (pick name namep %pathname-name)
512 (pick type typep %pathname-type)
515 (defun pathname-host (pathname &key (case :local))
517 "Accessor for the pathname's host."
518 (declare (type pathname-designator pathname)
519 (type (member :local :common) case)
522 (with-pathname (pathname pathname)
523 (%pathname-host pathname)))
525 (defun pathname-device (pathname &key (case :local))
527 "Accessor for pathname's device."
528 (declare (type pathname-designator pathname)
529 (type (member :local :common) case))
530 (with-pathname (pathname pathname)
531 (maybe-diddle-case (%pathname-device pathname)
532 (and (eq case :common)
533 (eq (host-customary-case
534 (%pathname-host pathname))
537 (defun pathname-directory (pathname &key (case :local))
539 "Accessor for the pathname's directory list."
540 (declare (type pathname-designator pathname)
541 (type (member :local :common) case))
542 (with-pathname (pathname pathname)
543 (maybe-diddle-case (%pathname-directory pathname)
544 (and (eq case :common)
545 (eq (host-customary-case
546 (%pathname-host pathname))
548 (defun pathname-name (pathname &key (case :local))
550 "Accessor for the pathname's name."
551 (declare (type pathname-designator pathname)
552 (type (member :local :common) case))
553 (with-pathname (pathname pathname)
554 (maybe-diddle-case (%pathname-name pathname)
555 (and (eq case :common)
556 (eq (host-customary-case
557 (%pathname-host pathname))
561 (defun pathname-type (pathname &key (case :local))
563 "Accessor for the pathname's name."
564 (declare (type pathname-designator pathname)
565 (type (member :local :common) case))
566 (with-pathname (pathname pathname)
567 (maybe-diddle-case (%pathname-type pathname)
568 (and (eq case :common)
569 (eq (host-customary-case
570 (%pathname-host pathname))
574 (defun pathname-version (pathname)
576 "Accessor for the pathname's version."
577 (declare (type pathname-designator pathname))
578 (with-pathname (pathname pathname)
579 (%pathname-version pathname)))
583 (defun %print-namestring-parse-error (condition stream)
584 (format stream "Parse error in namestring: ~?~% ~A~% ~V@T^"
585 (namestring-parse-error-complaint condition)
586 (namestring-parse-error-arguments condition)
587 (namestring-parse-error-namestring condition)
588 (namestring-parse-error-offset condition)))
590 ;;; Handle the case where parse-namestring is actually parsing a namestring.
591 ;;; We pick off the :JUNK-ALLOWED case then find a host to use for parsing,
592 ;;; call the parser, then check whether the host matches.
593 (defun %parse-namestring (namestr host defaults start end junk-allowed)
594 (declare (type (or host null) host) (type string namestr)
595 (type index start) (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 Host arg is not supplied, Defaults arg must ~
607 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 "Host in namestring: ~S~@
613 does not match explicit host argument: ~S"
615 (let ((pn-host (or new-host parse-host)))
616 (values (%make-pathname-object
617 pn-host device directory file type version)
620 ;;; If namestr begins with a colon-terminated, defined, logical host, then
621 ;;; return that host, otherwise return NIL.
622 (defun extract-logical-host-prefix (namestr start end)
623 (declare (type simple-base-string namestr)
624 (type index start end)
625 (values (or logical-host null)))
626 (let ((colon-pos (position #\: namestr :start start :end end)))
628 (values (gethash (nstring-upcase (subseq namestr start colon-pos))
632 (defun parse-namestring (thing
633 &optional host (defaults *default-pathname-defaults*)
634 &key (start 0) end junk-allowed)
636 "Converts pathname, a pathname designator, into a pathname structure,
637 for a physical pathname, returns the printed representation. Host may be
638 a physical host structure or host namestring."
639 (declare (type pathname-designator thing)
640 (type (or null host) host)
641 (type pathname defaults)
643 (type (or index null) end)
644 (type (or t null) junk-allowed)
645 (values (or null pathname) (or null index)))
648 (%parse-namestring thing host defaults start end junk-allowed))
650 (%parse-namestring (coerce thing 'simple-string)
651 host defaults start end junk-allowed))
653 (let ((host (if host host (%pathname-host defaults))))
654 (unless (eq host (%pathname-host thing))
655 (error "Hosts do not match: ~S and ~S."
656 host (%pathname-host thing))))
657 (values thing start))
659 (let ((name (file-name thing)))
661 (error "Can't figure out the file associated with stream:~% ~S"
665 (defun namestring (pathname)
667 "Construct the full (name)string form of the pathname."
668 (declare (type pathname-designator pathname)
669 (values (or null simple-base-string)))
670 (with-pathname (pathname pathname)
672 (let ((host (%pathname-host pathname)))
674 (error "Cannot determine the namestring for pathnames with no ~
675 host:~% ~S" pathname))
676 (funcall (host-unparse host) pathname)))))
678 (defun host-namestring (pathname)
680 "Returns a string representation of the name of the host in the pathname."
681 (declare (type pathname-designator pathname)
682 (values (or null simple-base-string)))
683 (with-pathname (pathname pathname)
684 (let ((host (%pathname-host pathname)))
686 (funcall (host-unparse-host host) pathname)
688 "Cannot determine the namestring for pathnames with no host:~% ~S"
691 (defun directory-namestring (pathname)
693 "Returns a string representation of the directories used in the pathname."
694 (declare (type pathname-designator pathname)
695 (values (or null simple-base-string)))
696 (with-pathname (pathname pathname)
697 (let ((host (%pathname-host pathname)))
699 (funcall (host-unparse-directory host) pathname)
701 "Cannot determine the namestring for pathnames with no host:~% ~S"
704 (defun file-namestring (pathname)
706 "Returns a string representation of the name used in the pathname."
707 (declare (type pathname-designator pathname)
708 (values (or null simple-base-string)))
709 (with-pathname (pathname pathname)
710 (let ((host (%pathname-host pathname)))
712 (funcall (host-unparse-file host) pathname)
714 "Cannot determine the namestring for pathnames with no host:~% ~S"
717 (defun enough-namestring (pathname
718 &optional (defaults *default-pathname-defaults*))
720 "Returns an abbreviated pathname sufficent to identify the pathname relative
722 (declare (type pathname-designator pathname))
723 (with-pathname (pathname pathname)
724 (let ((host (%pathname-host pathname)))
726 (with-pathname (defaults defaults)
727 (funcall (host-unparse-enough host) pathname defaults))
729 "Cannot determine the namestring for pathnames with no host:~% ~S"
734 (defun wild-pathname-p (pathname &optional field-key)
736 "Predicate for determining whether pathname contains any wildcards."
737 (declare (type pathname-designator pathname)
738 (type (member nil :host :device :directory :name :type :version)
740 (with-pathname (pathname pathname)
742 (or (pattern-p x) (member x '(:wild :wild-inferiors)))))
745 (or (wild-pathname-p pathname :host)
746 (wild-pathname-p pathname :device)
747 (wild-pathname-p pathname :directory)
748 (wild-pathname-p pathname :name)
749 (wild-pathname-p pathname :type)
750 (wild-pathname-p pathname :version)))
751 (:host (frob (%pathname-host pathname)))
752 (:device (frob (%pathname-host pathname)))
753 (:directory (some #'frob (%pathname-directory pathname)))
754 (:name (frob (%pathname-name pathname)))
755 (:type (frob (%pathname-type pathname)))
756 (:version (frob (%pathname-version pathname)))))))
758 (defun pathname-match-p (in-pathname in-wildname)
760 "Pathname matches the wildname template?"
761 (declare (type pathname-designator in-pathname))
762 (with-pathname (pathname in-pathname)
763 (with-pathname (wildname in-wildname)
764 (macrolet ((frob (field &optional (op 'components-match ))
765 `(or (null (,field wildname))
766 (,op (,field pathname) (,field wildname)))))
767 (and (or (null (%pathname-host wildname))
768 (eq (%pathname-host wildname) (%pathname-host pathname)))
769 (frob %pathname-device)
770 (frob %pathname-directory directory-components-match)
771 (frob %pathname-name)
772 (frob %pathname-type)
773 (frob %pathname-version))))))
775 ;;; Place the substitutions into the pattern and return the string or pattern
776 ;;; that results. If DIDDLE-CASE is true, we diddle the result case as well,
777 ;;; in case we are translating between hosts with difference conventional case.
778 ;;; The second value is the tail of subs with all of the values that we used up
779 ;;; stripped off. Note that PATTERN-MATCHES matches all consecutive wildcards
780 ;;; as a single string, so we ignore subsequent contiguous wildcards.
781 (defun substitute-into (pattern subs diddle-case)
782 (declare (type pattern pattern)
784 (values (or simple-base-string pattern)))
785 (let ((in-wildcard nil)
788 (dolist (piece (pattern-pieces pattern))
789 (cond ((simple-string-p piece)
791 (setf in-wildcard nil))
796 (error "Not enough wildcards in FROM pattern to match ~
799 (let ((sub (pop subs)))
803 (push (apply #'concatenate 'simple-string
806 (dolist (piece (pattern-pieces sub))
807 (push piece pieces)))
811 (error "Can't substitute this into the middle of a word:~
816 (push (apply #'concatenate 'simple-string (nreverse strings))
820 (if (and pieces (simple-string-p (car pieces)) (null (cdr pieces)))
822 (make-pattern (nreverse pieces)))
826 ;;; Called when we can't see how source and from matched.
827 (defun didnt-match-error (source from)
828 (error "Pathname components from SOURCE and FROM args to TRANSLATE-PATHNAME~@
829 did not match:~% ~S ~S"
832 ;;; Do TRANSLATE-COMPONENT for all components except host and directory.
833 (defun translate-component (source from to diddle-case)
840 (if (pattern= from source)
842 (didnt-match-error source from)))
844 (multiple-value-bind (won subs) (pattern-matches from source)
846 (values (substitute-into to subs diddle-case))
847 (didnt-match-error source from))))
849 (maybe-diddle-case source diddle-case))))
851 (values (substitute-into to (list source) diddle-case)))
853 (if (components-match source from)
854 (maybe-diddle-case source diddle-case)
855 (didnt-match-error source from)))))
857 (maybe-diddle-case source diddle-case))
859 (if (components-match source from)
861 (didnt-match-error source from)))))
863 ;;; Return a list of all the things that we want to substitute into the TO
864 ;;; pattern (the things matched by from on source.) When From contains
865 ;;; :WILD-INFERIORS, the result contains a sublist of the matched source
867 (defun compute-directory-substitutions (orig-source orig-from)
868 (let ((source orig-source)
873 (unless (every #'(lambda (x) (eq x :wild-inferiors)) from)
874 (didnt-match-error orig-source orig-from))
877 (unless from (didnt-match-error orig-source orig-from))
878 (let ((from-part (pop from))
879 (source-part (pop source)))
882 (typecase source-part
884 (if (pattern= from-part source-part)
886 (didnt-match-error orig-source orig-from)))
888 (multiple-value-bind (won new-subs)
889 (pattern-matches from-part source-part)
891 (dolist (sub new-subs)
893 (didnt-match-error orig-source orig-from))))
895 (didnt-match-error orig-source orig-from))))
898 ((member :wild-inferiors)
899 (let ((remaining-source (cons source-part source)))
902 (when (directory-components-match remaining-source from)
904 (unless remaining-source
905 (didnt-match-error orig-source orig-from))
906 (res (pop remaining-source)))
908 (setq source remaining-source))))
910 (unless (and (simple-string-p source-part)
911 (string= from-part source-part))
912 (didnt-match-error orig-source orig-from)))
914 (didnt-match-error orig-source orig-from)))))
917 ;;; Called by TRANSLATE-PATHNAME on the directory components of its argument
918 ;;; pathanames to produce the result directory component. If any leaves the
919 ;;; directory NIL, we return the source directory. The :RELATIVE or :ABSOLUTE
920 ;;; is always taken from the source directory.
921 (defun translate-directories (source from to diddle-case)
922 (if (not (and source to from))
924 (mapcar #'(lambda (x) (maybe-diddle-case x diddle-case)) source))
927 (let ((subs-left (compute-directory-substitutions (rest source)
929 (dolist (to-part (rest to))
933 (let ((match (pop subs-left)))
935 (error ":WILD-INFERIORS not paired in from and to ~
936 patterns:~% ~S ~S" from to))
937 (res (maybe-diddle-case match diddle-case))))
938 ((member :wild-inferiors)
940 (let ((match (pop subs-left)))
941 (unless (listp match)
942 (error ":WILD-INFERIORS not paired in from and to ~
943 patterns:~% ~S ~S" from to))
945 (res (maybe-diddle-case x diddle-case)))))
947 (multiple-value-bind (new new-subs-left)
948 (substitute-into to-part subs-left diddle-case)
949 (setf subs-left new-subs-left)
954 (defun translate-pathname (source from-wildname to-wildname &key)
956 "Use the source pathname to translate the from-wildname's wild and
957 unspecified elements into a completed to-pathname based on the to-wildname."
958 (declare (type pathname-designator source from-wildname to-wildname))
959 (with-pathname (source source)
960 (with-pathname (from from-wildname)
961 (with-pathname (to to-wildname)
962 (let* ((source-host (%pathname-host source))
963 (to-host (%pathname-host to))
965 (and source-host to-host
966 (not (eq (host-customary-case source-host)
967 (host-customary-case to-host))))))
968 (macrolet ((frob (field &optional (op 'translate-component))
969 `(let ((result (,op (,field source)
973 (if (eq result :error)
974 (error "~S doesn't match ~S." source from)
976 (%make-pathname-object
977 (or to-host source-host)
978 (frob %pathname-device)
979 (frob %pathname-directory translate-directories)
980 (frob %pathname-name)
981 (frob %pathname-type)
982 (frob %pathname-version))))))))
986 (def!struct (search-list (:make-load-form-fun
988 (values `(intern-search-list
989 ',(search-list-name s))
991 ;; The name of this search-list. Always stored in lowercase.
992 (name (required-argument) :type simple-string)
993 ;; T if this search-list has been defined. Otherwise NIL.
994 (defined nil :type (member t nil))
995 ;; The list of expansions for this search-list. Each expansion is the list
996 ;; of directory components to use in place of this search-list.
997 (expansions nil :type list))
998 (def!method print-object ((sl search-list) stream)
999 (print-unreadable-object (sl stream :type t)
1000 (write-string (search-list-name sl) stream)))
1002 ;;; a hash table mapping search-list names to search-list structures
1003 (defvar *search-lists* (make-hash-table :test 'equal))
1005 ;;; When search-lists are encountered in namestrings, they are converted to
1006 ;;; search-list structures right then, instead of waiting until the search
1007 ;;; list used. This allows us to verify ahead of time that there are no
1008 ;;; circularities and makes expansion much quicker.
1009 (defun intern-search-list (name)
1010 (let ((name (string-downcase name)))
1011 (or (gethash name *search-lists*)
1012 (let ((new (make-search-list :name name)))
1013 (setf (gethash name *search-lists*) new)
1016 ;;; Clear the definition. Note: we can't remove it from the hash-table
1017 ;;; because there may be pathnames still refering to it. So we just clear
1018 ;;; out the expansions and ste defined to NIL.
1019 (defun clear-search-list (name)
1021 "Clear the current definition for the search-list NAME. Returns T if such
1022 a definition existed, and NIL if not."
1023 (let* ((name (string-downcase name))
1024 (search-list (gethash name *search-lists*)))
1025 (when (and search-list (search-list-defined search-list))
1026 (setf (search-list-defined search-list) nil)
1027 (setf (search-list-expansions search-list) nil)
1030 ;;; Again, we can't actually remove the entries from the hash-table, so we
1031 ;;; just mark them as being undefined.
1032 (defun clear-all-search-lists ()
1034 "Clear the definition for all search-lists. Only use this if you know
1035 what you are doing."
1036 (maphash #'(lambda (name search-list)
1037 (declare (ignore name))
1038 (setf (search-list-defined search-list) nil)
1039 (setf (search-list-expansions search-list) nil))
1043 ;;; Extract the search-list from PATHNAME and return it. If PATHNAME
1044 ;;; doesn't start with a search-list, then either error (if FLAME-IF-NONE
1045 ;;; is true) or return NIL (if FLAME-IF-NONE is false).
1046 (defun extract-search-list (pathname flame-if-none)
1047 (with-pathname (pathname pathname)
1048 (let* ((directory (%pathname-directory pathname))
1049 (search-list (cadr directory)))
1050 (cond ((search-list-p search-list)
1053 (error "~S doesn't start with a search-list." pathname))
1057 ;;; We have to convert the internal form of the search-list back into a
1058 ;;; bunch of pathnames.
1059 (defun search-list (pathname)
1061 "Return the expansions for the search-list starting PATHNAME. If PATHNAME
1062 does not start with a search-list, then an error is signaled. If
1063 the search-list has not been defined yet, then an error is signaled.
1064 The expansion for a search-list can be set with SETF."
1065 (with-pathname (pathname pathname)
1066 (let ((search-list (extract-search-list pathname t))
1067 (host (pathname-host pathname)))
1068 (if (search-list-defined search-list)
1069 (mapcar #'(lambda (directory)
1070 (make-pathname :host host
1071 :directory (cons :absolute directory)))
1072 (search-list-expansions search-list))
1073 (error "Search list ~S has not been defined yet." pathname)))))
1075 (defun search-list-defined-p (pathname)
1077 "Returns T if the search-list starting PATHNAME is currently defined, and
1078 NIL otherwise. An error is signaled if PATHNAME does not start with a
1080 (with-pathname (pathname pathname)
1081 (search-list-defined (extract-search-list pathname t))))
1083 ;;; Set the expansion for the search-list in PATHNAME. If this would result
1084 ;;; in any circularities, we flame out. If anything goes wrong, we leave the
1085 ;;; old definition intact.
1086 (defun %set-search-list (pathname values)
1087 (let ((search-list (extract-search-list pathname t)))
1089 ((check (target-list path)
1090 (when (eq search-list target-list)
1091 (error "That would result in a circularity:~% ~
1093 (search-list-name search-list)
1095 (search-list-name target-list)))
1096 (when (search-list-p target-list)
1097 (push (search-list-name target-list) path)
1098 (dolist (expansion (search-list-expansions target-list))
1099 (check (car expansion) path))))
1101 (with-pathname (pathname pathname)
1102 (when (or (pathname-name pathname)
1103 (pathname-type pathname)
1104 (pathname-version pathname))
1105 (error "Search-lists cannot expand into pathnames that have ~
1106 a name, type, or ~%version specified:~% ~S"
1108 (let ((directory (pathname-directory pathname)))
1111 (ecase (car directory)
1112 (:absolute (cdr directory))
1113 (:relative (cons (intern-search-list "default")
1115 (list (intern-search-list "default")))))
1116 (check (car expansion) nil)
1118 (setf (search-list-expansions search-list)
1120 (mapcar #'convert values)
1121 (list (convert values)))))
1122 (setf (search-list-defined search-list) t))
1125 (defun %enumerate-search-list (pathname function)
1126 (/show0 "entering %ENUMERATE-SEARCH-LIST")
1127 (let* ((pathname (if (typep pathname 'logical-pathname)
1128 (translate-logical-pathname pathname)
1130 (search-list (extract-search-list pathname nil)))
1131 (/show0 "PATHNAME and SEARCH-LIST computed")
1134 (/show0 "no search list")
1135 (funcall function pathname))
1136 ((not (search-list-defined search-list))
1137 (/show0 "undefined search list")
1138 (error "Undefined search list: ~A"
1139 (search-list-name search-list)))
1141 (/show0 "general case")
1142 (let ((tail (cddr (pathname-directory pathname))))
1143 (/show0 "TAIL computed")
1145 (search-list-expansions search-list))
1146 (/show0 "tail recursing in %ENUMERATE-SEARCH-LIST")
1147 (%enumerate-search-list (make-pathname :defaults pathname
1154 ;;;; logical pathname support. ANSI 92-102 specification.
1155 ;;;; As logical-pathname translations are loaded they are canonicalized as
1156 ;;;; patterns to enable rapid efficent translation into physical pathnames.
1160 ;;; Canonicalize a logical pathanme word by uppercasing it checking that it
1161 ;;; contains only legal characters.
1162 (defun logical-word-or-lose (word)
1163 (declare (string word))
1164 (let ((word (string-upcase word)))
1165 (dotimes (i (length word))
1166 (let ((ch (schar word i)))
1167 (unless (or (alpha-char-p ch) (digit-char-p ch) (char= ch #\-))
1168 (error 'namestring-parse-error
1169 :complaint "Logical namestring character ~
1170 is not alphanumeric or hyphen:~% ~S"
1171 :arguments (list ch)
1172 :namestring word :offset i))))
1175 ;;; Given a logical host or string, return a logical host. If Error-p is
1176 ;;; NIL, then return NIL when no such host exists.
1177 (defun find-logical-host (thing &optional (errorp t))
1180 (let ((found (gethash (logical-word-or-lose thing)
1182 (if (or found (not errorp))
1184 (error 'simple-file-error
1186 :format-control "Logical host not yet defined: ~S"
1187 :format-arguments (list thing)))))
1188 (logical-host thing)))
1190 ;;; Given a logical host name or host, return a logical host, creating a new
1191 ;;; one if necessary.
1192 (defun intern-logical-host (thing)
1193 (declare (values logical-host))
1194 (or (find-logical-host thing nil)
1195 (let* ((name (logical-word-or-lose thing))
1196 (new (make-logical-host :name name)))
1197 (setf (gethash name *logical-hosts*) new)
1200 ;;;; logical pathname parsing
1202 ;;; Deal with multi-char wildcards in a logical pathname token.
1203 (defun maybe-make-logical-pattern (namestring chunks)
1204 (let ((chunk (caar chunks)))
1205 (collect ((pattern))
1207 (len (length chunk)))
1208 (declare (fixnum last-pos))
1210 (when (= last-pos len) (return))
1211 (let ((pos (or (position #\* chunk :start last-pos) len)))
1212 (if (= pos last-pos)
1214 (error 'namestring-parse-error
1215 :complaint "Double asterisk inside of logical ~
1217 :arguments (list chunk)
1218 :namestring namestring
1219 :offset (+ (cdar chunks) pos)))
1220 (pattern (subseq chunk last-pos pos)))
1223 (pattern :multi-char-wild))
1224 (setq last-pos (1+ pos)))))
1227 (make-pattern (pattern))
1228 (let ((x (car (pattern))))
1229 (if (eq x :multi-char-wild)
1233 ;;; Return a list of conses where the cdr is the start position and the car
1234 ;;; is a string (token) or character (punctuation.)
1235 (defun logical-chunkify (namestr start end)
1237 (do ((i start (1+ i))
1241 (chunks (cons (nstring-upcase (subseq namestr prev end)) prev))))
1242 (let ((ch (schar namestr i)))
1243 (unless (or (alpha-char-p ch) (digit-char-p ch)
1244 (member ch '(#\- #\*)))
1246 (chunks (cons (nstring-upcase (subseq namestr prev i)) prev)))
1248 (unless (member ch '(#\; #\: #\.))
1249 (error 'namestring-parse-error
1250 :complaint "Illegal character for logical pathname:~% ~S"
1251 :arguments (list ch)
1254 (chunks (cons ch i)))))
1257 ;;; Break up a logical-namestring, always a string, into its constituent parts.
1258 (defun parse-logical-namestring (namestr start end)
1259 (declare (type simple-base-string namestr)
1260 (type index start end))
1261 (collect ((directory))
1266 (labels ((expecting (what chunks)
1267 (unless (and chunks (simple-string-p (caar chunks)))
1268 (error 'namestring-parse-error
1269 :complaint "Expecting ~A, got ~:[nothing~;~S~]."
1270 :arguments (list what (caar chunks))
1272 :offset (if chunks (cdar chunks) end)))
1274 (parse-host (chunks)
1275 (case (caadr chunks)
1278 (find-logical-host (expecting "a host name" chunks)))
1279 (parse-relative (cddr chunks)))
1281 (parse-relative chunks))))
1282 (parse-relative (chunks)
1285 (directory :relative)
1286 (parse-directory (cdr chunks)))
1288 (directory :absolute) ; Assumption! Maybe revoked later.
1289 (parse-directory chunks))))
1290 (parse-directory (chunks)
1291 (case (caadr chunks)
1294 (let ((res (expecting "a directory name" chunks)))
1295 (cond ((string= res "..") :up)
1296 ((string= res "**") :wild-inferiors)
1298 (maybe-make-logical-pattern namestr chunks)))))
1299 (parse-directory (cddr chunks)))
1301 (parse-name chunks))))
1302 (parse-name (chunks)
1304 (expecting "a file name" chunks)
1305 (setq name (maybe-make-logical-pattern namestr chunks))
1306 (expecting-dot (cdr chunks))))
1307 (expecting-dot (chunks)
1309 (unless (eql (caar chunks) #\.)
1310 (error 'namestring-parse-error
1311 :complaint "Expecting a dot, got ~S."
1312 :arguments (list (caar chunks))
1314 :offset (cdar chunks)))
1316 (parse-version (cdr chunks))
1317 (parse-type (cdr chunks)))))
1318 (parse-type (chunks)
1319 (expecting "a file type" chunks)
1320 (setq type (maybe-make-logical-pattern namestr chunks))
1321 (expecting-dot (cdr chunks)))
1322 (parse-version (chunks)
1323 (let ((str (expecting "a positive integer, * or NEWEST"
1326 ((string= str "*") (setq version :wild))
1327 ((string= str "NEWEST") (setq version :newest))
1329 (multiple-value-bind (res pos)
1330 (parse-integer str :junk-allowed t)
1331 (unless (and res (plusp res))
1332 (error 'namestring-parse-error
1333 :complaint "Expected a positive integer, ~
1335 :arguments (list str)
1337 :offset (+ pos (cdar chunks))))
1338 (setq version res)))))
1340 (error 'namestring-parse-error
1341 :complaint "Extra stuff after end of file name."
1343 :offset (cdadr chunks)))))
1344 (parse-host (logical-chunkify namestr start end)))
1345 (values host :unspecific
1346 (and (not (equal (directory)'(:absolute)))(directory))
1347 name type version))))
1349 ;;; can't defvar here because not all host methods are loaded yet
1350 (declaim (special *logical-pathname-defaults*))
1352 (defun logical-pathname (pathspec)
1354 "Converts the pathspec argument to a logical-pathname and returns it."
1355 (declare (type (or logical-pathname string stream) pathspec)
1356 (values logical-pathname))
1357 (if (typep pathspec 'logical-pathname)
1359 (let ((res (parse-namestring pathspec nil *logical-pathname-defaults*)))
1360 (when (eq (%pathname-host res)
1361 (%pathname-host *logical-pathname-defaults*))
1362 (error "Logical namestring does not specify a host:~% ~S"
1366 ;;;; logical pathname unparsing
1368 (defun unparse-logical-directory (pathname)
1369 (declare (type pathname pathname))
1371 (let ((directory (%pathname-directory pathname)))
1373 (ecase (pop directory)
1374 (:absolute) ;; Nothing special.
1375 (:relative (pieces ";")))
1376 (dolist (dir directory)
1377 (cond ((or (stringp dir) (pattern-p dir))
1378 (pieces (unparse-logical-piece dir))
1382 ((eq dir :wild-inferiors)
1385 (error "Invalid directory component: ~S" dir))))))
1386 (apply #'concatenate 'simple-string (pieces))))
1388 (defun unparse-logical-piece (thing)
1390 (simple-string thing)
1392 (collect ((strings))
1393 (dolist (piece (pattern-pieces thing))
1395 (simple-string (strings piece))
1397 (cond ((eq piece :wild-inferiors)
1399 ((eq piece :multi-char-wild)
1401 (t (error "Invalid keyword: ~S" piece))))))
1402 (apply #'concatenate 'simple-string (strings))))))
1404 (defun unparse-logical-namestring (pathname)
1405 (declare (type logical-pathname pathname))
1406 (concatenate 'simple-string
1407 (logical-host-name (%pathname-host pathname)) ":"
1408 (unparse-logical-directory pathname)
1409 (unparse-unix-file pathname)))
1411 ;;;; logical pathname translations
1413 ;;; Verify that the list of translations consists of lists and prepare
1414 ;;; canonical translations (parse pathnames and expand out wildcards into
1416 (defun canonicalize-logical-pathname-translations (transl-list host)
1417 (declare (type list transl-list) (type host host)
1420 (dolist (tr transl-list)
1421 (unless (and (consp tr) (= (length tr) 2))
1422 (error "Logical pathname translation is not a two-list:~% ~S"
1424 (let ((from (first tr)))
1425 (res (list (if (typep from 'logical-pathname)
1427 (parse-namestring from host))
1428 (pathname (second tr))))))
1431 (defun logical-pathname-translations (host)
1433 "Return the (logical) host object argument's list of translations."
1434 (declare (type (or string logical-host) host)
1436 (logical-host-translations (find-logical-host host)))
1438 (defun (setf logical-pathname-translations) (translations host)
1440 "Set the translations list for the logical host argument.
1441 Return translations."
1442 (declare (type (or string logical-host) host)
1443 (type list translations)
1446 (let ((host (intern-logical-host host)))
1447 (setf (logical-host-canon-transls host)
1448 (canonicalize-logical-pathname-translations translations host))
1449 (setf (logical-host-translations host) translations)))
1451 ;;; The search mechanism for loading pathname translations uses the CMU CL
1452 ;;; extension of search-lists. The user can add to the "library:" search-list
1453 ;;; using setf. The file for translations should have the name defined by
1454 ;;; the hostname (a string) and with type component "translations".
1456 (defun load-logical-pathname-translations (host)
1458 "Search for a logical pathname named host, if not already defined. If already
1459 defined no attempt to find or load a definition is attempted and NIL is
1460 returned. If host is not already defined, but definition is found and loaded
1461 successfully, T is returned, else error."
1462 (declare (type string host)
1463 (values (member t nil)))
1464 (unless (find-logical-host host nil)
1465 (with-open-file (in-str (make-pathname :defaults "library:"
1467 :type "translations"))
1469 (format *error-output*
1470 ";; loading pathname translations from ~A~%"
1471 (namestring (truename in-str))))
1472 (setf (logical-pathname-translations host) (read in-str)))
1475 (defun translate-logical-pathname (pathname &key)
1477 "Translates pathname to a physical pathname, which is returned."
1478 (declare (type pathname-designator pathname)
1479 (values (or null pathname)))
1482 (dolist (x (logical-host-canon-transls (%pathname-host pathname))
1483 (error 'simple-file-error
1485 :format-control "No translation for ~S"
1486 :format-arguments (list pathname)))
1487 (destructuring-bind (from to) x
1488 (when (pathname-match-p pathname from)
1489 (return (translate-logical-pathname
1490 (translate-pathname pathname from to)))))))
1492 (stream (translate-logical-pathname (pathname pathname)))
1493 (t (translate-logical-pathname (logical-pathname pathname)))))
1495 (defvar *logical-pathname-defaults*
1496 (%make-logical-pathname (make-logical-host :name "BOGUS")