1 ;;;; machine/filesystem-independent pathname functions
3 ;;;; This software is part of the SBCL system. See the README file for
6 ;;;; This software is derived from the CMU CL system, which was
7 ;;;; written at Carnegie Mellon University and released into the
8 ;;;; public domain. The software is in the public domain and is
9 ;;;; provided with absolutely no warranty. See the COPYING and CREDITS
10 ;;;; files for more information.
12 (in-package "SB!IMPL")
14 #!-sb-fluid
(declaim (freeze-type logical-pathname logical-host
))
16 ;;; To be initialized in unix/win32-pathname.lisp
17 (defglobal *physical-host
* nil
)
19 ;;; Return a value suitable, e.g., for preinitializing
20 ;;; *DEFAULT-PATHNAME-DEFAULTS* before *DEFAULT-PATHNAME-DEFAULTS* is
21 ;;; initialized (at which time we can't safely call e.g. #'PATHNAME).
22 (defun make-trivial-default-pathname ()
23 (%%make-pathname
*physical-host
* nil nil nil nil
:newest
))
27 ;;; SXHASH does a really poor job on pathname directory, especially if in your
28 ;;; environment, the directories of interest are all many levels down from the
29 ;;; filesystem root- every directory in your work space might hash to the same
30 ;;; value under SXHASH. Mixing in all pieces of the directory path solves that.
31 (defun pathname-dir-hash (directory)
32 (let ((hash (sxhash (car directory
))))
33 (dolist (piece (cdr directory
) hash
)
34 (mixf hash
(sxhash piece
)))))
36 (defmethod print-object ((pathname pathname
) stream
)
37 (let ((namestring (handler-case (namestring pathname
)
41 (if (or *print-readably
* *print-escape
*)
44 (coerce namestring
'(simple-array character
(*))))
45 (print-unreadable-object (pathname stream
:type t
)
47 "~@<(with no namestring) ~_:HOST ~S ~_:DEVICE ~S ~_:DIRECTORY ~S ~
48 ~_:NAME ~S ~_:TYPE ~S ~_:VERSION ~S~:>"
49 (%pathname-host pathname
)
50 (%pathname-device pathname
)
51 (%pathname-directory pathname
)
52 (%pathname-name pathname
)
53 (%pathname-type pathname
)
54 (%pathname-version pathname
))))))
56 (defmethod make-load-form ((pathname pathname
) &optional environment
)
57 (make-load-form-saving-slots pathname
:environment environment
))
59 ;;; A pathname is logical if the host component is a logical host.
60 ;;; This constructor is used to make an instance of the correct type
61 ;;; from parsed arguments.
62 (defun %make-maybe-logical-pathname
(host device directory name type version
)
63 ;; We canonicalize logical pathname components to uppercase. ANSI
64 ;; doesn't strictly require this, leaving it up to the implementor;
65 ;; but the arguments given in the X3J13 cleanup issue
66 ;; PATHNAME-LOGICAL:ADD seem compelling: we should canonicalize the
67 ;; case, and uppercase is the ordinary way to do that.
68 (flet ((upcase-maybe (x) (typecase x
(string (logical-word-or-lose x
)) (t x
))))
69 (if (typep host
'logical-host
)
70 (%make-logical-pathname host
72 (mapcar #'upcase-maybe directory
)
77 (aver (eq host
*physical-host
*))
78 (%make-pathname host device directory name type version
)))))
80 ;;; Hash table searching maps a logical pathname's host to its
81 ;;; physical pathname translation.
82 (define-load-time-global *logical-hosts
*
83 (make-hash-table :test
'equal
:synchronized t
))
87 (defmethod make-load-form ((pattern pattern
) &optional environment
)
88 (make-load-form-saving-slots pattern
:environment environment
))
90 (defmethod print-object ((pattern pattern
) stream
)
91 (print-unreadable-object (pattern stream
:type t
)
93 (let ((*print-escape
* t
))
94 (pprint-fill stream
(pattern-pieces pattern
) nil
))
95 (prin1 (pattern-pieces pattern
) stream
))))
97 (defun pattern= (pattern1 pattern2
)
98 (declare (type pattern pattern1 pattern2
))
99 (let ((pieces1 (pattern-pieces pattern1
))
100 (pieces2 (pattern-pieces pattern2
)))
101 (and (= (length pieces1
) (length pieces2
))
102 (every (lambda (piece1 piece2
)
105 (and (simple-string-p piece2
)
106 (string= piece1 piece2
)))
109 (eq (car piece1
) (car piece2
))
110 (string= (cdr piece1
) (cdr piece2
))))
112 (eq piece1 piece2
))))
116 ;;; If the string matches the pattern returns the multiple values T
117 ;;; and a list of the matched strings.
118 (defun pattern-matches (pattern string
)
119 (declare (type pattern pattern
)
120 (type simple-string string
))
121 (let ((len (length string
)))
122 (labels ((maybe-prepend (subs cur-sub chars
)
124 (let* ((len (length chars
))
125 (new (make-string len
))
128 (setf (schar new
(decf index
)) char
))
131 (matches (pieces start subs cur-sub chars
)
134 (values t
(maybe-prepend subs cur-sub chars
))
136 (let ((piece (car pieces
)))
139 (let ((end (+ start
(length piece
))))
141 (string= piece string
142 :start2 start
:end2 end
)
143 (matches (cdr pieces
) end
144 (maybe-prepend subs cur-sub chars
)
150 (let ((char (schar string start
)))
151 (if (find char
(cdr piece
) :test
#'char
=)
152 (matches (cdr pieces
) (1+ start
) subs t
153 (cons char chars
))))))))
154 ((member :single-char-wild
)
156 (matches (cdr pieces
) (1+ start
) subs t
157 (cons (schar string start
) chars
))))
158 ((member :multi-char-wild
)
159 (multiple-value-bind (won new-subs
)
160 (matches (cdr pieces
) start subs t chars
)
164 (matches pieces
(1+ start
) subs t
165 (cons (schar string start
)
167 (multiple-value-bind (won subs
)
168 (matches (pattern-pieces pattern
) 0 nil nil nil
)
169 (values won
(reverse subs
))))))
171 ;;; PATHNAME-MATCH-P for directory components
172 (defun directory-components-match (thing wild
)
175 ;; If THING has a null directory, assume that it matches
176 ;; (:ABSOLUTE :WILD-INFERIORS) or (:RELATIVE :WILD-INFERIORS).
179 (member (first wild
) '(:absolute
:relative
))
180 (eq (second wild
) :wild-inferiors
))
182 (let ((wild1 (first wild
)))
183 (if (eq wild1
:wild-inferiors
)
184 (let ((wild-subdirs (rest wild
)))
185 (or (null wild-subdirs
)
187 (when (directory-components-match thing wild-subdirs
)
190 (unless thing
(return nil
)))))
192 (components-match (first thing
) wild1
)
193 (directory-components-match (rest thing
)
196 ;;; Return true if pathname component THING is matched by WILD. (not
198 (defun components-match (thing wild
)
199 (declare (type (or pattern symbol simple-string integer
) thing wild
))
204 ;; String is matched by itself, a matching pattern or :WILD.
207 (values (pattern-matches wild thing
)))
209 (string= thing wild
))))
211 ;; A pattern is only matched by an identical pattern.
212 (and (pattern-p wild
) (pattern= thing wild
)))
214 ;; An integer (version number) is matched by :WILD or the
215 ;; same integer. This branch will actually always be NIL as
216 ;; long as the version is a fixnum.
219 ;;; a predicate for comparing two pathname slot component sub-entries
220 (defun compare-component (this that
)
224 (and (simple-string-p that
)
225 (string= this that
)))
227 (and (pattern-p that
)
228 (pattern= this that
)))
231 (compare-component (car this
) (car that
))
232 (compare-component (cdr this
) (cdr that
)))))))
234 ;;;; pathname functions
236 (defun pathname= (pathname1 pathname2
)
237 (declare (type pathname pathname1
)
238 (type pathname pathname2
))
239 (or (eq pathname1 pathname2
)
240 (and (eq (%pathname-host pathname1
)
241 (%pathname-host pathname2
))
242 (= (%pathname-dir-hash pathname1
) (%pathname-dir-hash pathname2
))
243 (= (%pathname-stem-hash pathname1
) (%pathname-stem-hash pathname2
))
244 (compare-component (%pathname-device pathname1
)
245 (%pathname-device pathname2
))
246 (compare-component (%pathname-directory pathname1
)
247 (%pathname-directory pathname2
))
248 (compare-component (%pathname-name pathname1
)
249 (%pathname-name pathname2
))
250 (compare-component (%pathname-type pathname1
)
251 (%pathname-type pathname2
))
252 (or (eq (%pathname-host pathname1
) *physical-host
*)
253 (compare-component (%pathname-version pathname1
)
254 (%pathname-version pathname2
))))))
256 ;;; This is conceptually like (DEFUN-CACHED (%MAKE-PATHNAME ...))
257 ;;; except that we try hard never to evict entries until SAVE-LISP-AND-DIE.
258 ;;; Entries can still be kicked out randomly though.
259 ;;; A two-level lookup is used- it works better than mixing all
260 ;;; pathname components into a hash key.
261 (define-load-time-global *pathnames
* (make-array 211 :initial-element nil
))
262 (defglobal *pathnames-lock
* (sb!thread
:make-mutex
:name
"Pathnames"))
264 (defun %make-pathname
(host device directory name type version
)
265 (if (or device
(neq host
*physical-host
*))
266 (%%make-pathname host device directory name type version
)
267 (let* ((table *pathnames
*)
268 (index (rem (pathname-dir-hash directory
) (length table
)))
270 ;; Candidates is a list of ((dir . contents) ...)
272 with candidates
= (svref table index
) and new
= nil
274 (let ((n-candidates 0))
275 (dolist (candidate candidates
)
277 (when (compare-component (car candidate
) directory
)
278 (return-from outer candidate
)))
280 (setq new
(cons directory
(make-array 3 :initial-element nil
))))
281 (cond ((< n-candidates
10)
282 (let* ((cell (cons new candidates
))
283 (actual-old (cas (svref table index
) candidates cell
)))
284 (when (eq actual-old candidates
)
285 (return-from outer new
))
286 (setq candidates actual-old
)))
288 ;; Clobber this cache entry, losing all directories in it.
289 ;; Hopefully this doesn't happen often.
290 #+nil
(format t
"~&*** Pathname cache overflow: ~D ~S~%"
291 index
(mapcar 'car candidates
))
292 (setf (svref table index
) (list new
))
293 (return-from outer new
)))))))
294 (flet ((matchp (stem-hash candidates
)
295 (let ((n-candidates 0))
296 (dolist (pathname candidates
(values nil n-candidates
))
297 (when (and (= (%pathname-stem-hash pathname
) stem-hash
)
298 (compare-component (%pathname-version pathname
) version
)
299 (compare-component (%pathname-name pathname
) name
)
300 (compare-component (%pathname-type pathname
) type
))
301 (return (values pathname
0)))
302 (incf n-candidates
)))))
303 ;; We have tests asserting that the distinction between :NEWEST
304 ;; and NIL is preserved, though there is no effective difference.
305 (binding* ((stem-hash (mix (sxhash name
) (sxhash type
)))
306 (vector (the simple-vector
(cdr dir-holder
)))
307 (index (rem stem-hash
(length vector
)))
308 (candidates (svref vector index
))
309 ((found n-candidates
) (matchp stem-hash candidates
)))
311 (return-from %make-pathname found
))
312 ;; Optimistically assuming that the pathname won't be found
313 ;; on the double-check, allocate it now
314 (let ((pathname (%%make-pathname
*physical-host
* nil
(car dir-holder
)
316 (sb!thread
::with-system-mutex
(*pathnames-lock
*)
317 (when (>= n-candidates
10)
318 ;; Rehash into a larger vector
319 (let* ((old-len (length vector
))
320 (new-len (+ old-len
4))
321 (new-vector (make-array new-len
:initial-element nil
)))
322 (dovector (list vector
)
324 (push p
(svref new-vector
(rem (%pathname-stem-hash p
)
326 (rplacd dir-holder new-vector
)
327 (setq vector new-vector
328 index
(rem stem-hash new-len
)
329 candidates
(svref vector index
))))
330 (let ((found (matchp stem-hash candidates
)))
332 (setq pathname found
)
333 (push pathname
(svref vector index
)))))
336 ;;; Convert PATHNAME-DESIGNATOR (a pathname, or string, or
337 ;;; stream), into a pathname in PATHNAME.
338 (eval-when (:compile-toplevel
:execute
)
339 (sb!xc
:defmacro with-pathname
((pathname pathname-designator
) &body body
)
340 (once-only ((pathname-designator pathname-designator
))
341 `(let ((,pathname
(etypecase ,pathname-designator
342 (pathname ,pathname-designator
)
343 (string (parse-namestring ,pathname-designator
))
344 ((or file-stream synonym-stream
)
345 (stream-file-name-or-lose ,pathname-designator
)))))
348 (sb!xc
:defmacro with-native-pathname
((pathname pathname-designator
) &body body
)
349 (once-only ((pathname-designator pathname-designator
))
350 `(let ((,pathname
(etypecase ,pathname-designator
351 (pathname ,pathname-designator
)
352 (string (parse-native-namestring ,pathname-designator
))
355 (file-stream (file-name ,pathname-designator
)))))
358 (sb!xc
:defmacro with-host
((host host-designator
) &body body
)
359 ;; Generally, redundant specification of information in software,
360 ;; whether in code or in comments, is bad. However, the ANSI spec
361 ;; for this is messy enough that it's hard to hold in short-term
362 ;; memory, so I've recorded these redundant notes on the
363 ;; implications of the ANSI spec.
365 ;; According to the ANSI spec, HOST can be a valid pathname host, or
366 ;; a logical host, or NIL.
368 ;; A valid pathname host can be a valid physical pathname host or a
369 ;; valid logical pathname host.
371 ;; A valid physical pathname host is "any of a string, a list of
372 ;; strings, or the symbol :UNSPECIFIC, that is recognized by the
373 ;; implementation as the name of a host". In SBCL as of 0.6.9.8,
374 ;; that means :UNSPECIFIC: though someday we might want to
375 ;; generalize it to allow strings like "RTFM.MIT.EDU" or lists like
376 ;; '("RTFM" "MIT" "EDU"), that's not supported now.
378 ;; A valid logical pathname host is a string which has been defined as
379 ;; the name of a logical host, as with LOAD-LOGICAL-PATHNAME-TRANSLATIONS.
381 ;; A logical host is an object of implementation-dependent nature. In
382 ;; SBCL, it's a member of the HOST class (a subclass of STRUCTURE-OBJECT).
383 (once-only ((host-designator host-designator
))
384 `(let ((,host
(etypecase ,host-designator
386 ;; This is a special host. It's not valid as a
387 ;; logical host, so it is a sensible thing to
388 ;; designate the physical host object. So we do
392 ;; In general ANSI-compliant Common Lisps, a
393 ;; string might also be a physical pathname
394 ;; host, but ANSI leaves this up to the
395 ;; implementor, and in SBCL we don't do it, so
396 ;; it must be a logical host.
397 (find-logical-host ,host-designator
))
398 (absent-pathname-component
399 ;; CLHS says that HOST=:UNSPECIFIC has
400 ;; implementation-defined behavior. We
401 ;; just turn it into NIL.
404 ;; ANSI also allows LISTs to designate hosts,
405 ;; but leaves its interpretation
406 ;; implementation-defined. Our interpretation
407 ;; is that it's unsupported.:-|
408 (error "A LIST representing a pathname host is not ~
409 supported in this implementation:~% ~S"
411 (host ,host-designator
))))
415 (defun find-host (host-designator &optional
(errorp t
))
416 (with-host (host host-designator
)
417 (when (and errorp
(not host
))
418 (error "Couldn't find host: ~S" host-designator
))
421 (defun pathname (pathspec)
422 "Convert PATHSPEC (a pathname designator) into a pathname."
423 (declare (type pathname-designator pathspec
))
424 (with-pathname (pathname pathspec
)
427 (defun native-pathname (pathspec)
428 "Convert PATHSPEC (a pathname designator) into a pathname, assuming
429 the operating system native pathname conventions."
430 (with-native-pathname (pathname pathspec
)
433 ;;; Recursively (e.g. for the directory component) change the case of
434 ;;; the pathname component THING.
435 (declaim (type (sfunction ((or symbol integer string pattern list
))
436 (or symbol integer string pattern list
))
438 (defun diddle-case (thing)
439 (labels ((check-for (pred in
)
442 (some (lambda (piece)
445 (check-for pred piece
))
446 ((cons (eql :character-set
))
447 (check-for pred
(cdr piece
)))))
448 (pattern-pieces in
)))
451 (diddle-with (fun thing
)
455 (mapcar (lambda (piece)
459 ((cons (eql :character-set
))
460 (funcall fun
(cdr piece
)))
463 (pattern-pieces thing
))))
468 (maybe-diddle-part (thing)
470 (mapcar #'maybe-diddle-part thing
)
471 (let ((any-uppers (check-for #'upper-case-p thing
))
472 (any-lowers (check-for #'lower-case-p thing
)))
473 (cond ((and any-uppers any-lowers
) ; mixed case, stays the same
475 (any-uppers ; all uppercase, becomes all lower case
476 (diddle-with 'string-downcase thing
))
477 (any-lowers ; all lowercase, becomes all upper case
478 (diddle-with 'string-upcase thing
))
479 (t ; no letters? I guess just leave it.
481 (if (not (or (symbolp thing
) (integerp thing
)))
482 (maybe-diddle-part thing
)
485 (declaim (inline maybe-diddle-case
))
486 (defun maybe-diddle-case (thing diddle-p
)
491 (defun merge-directories (dir1 dir2 diddle-case
)
492 (if (or (eq (car dir1
) :absolute
)
497 (if (and (eq dir
:back
)
499 (typep (car results
) '(or string pattern
500 (member :wild
:wild-inferiors
))))
502 (push dir results
))))
503 (dolist (dir (maybe-diddle-case dir2 diddle-case
))
505 (dolist (dir (cdr dir1
))
509 (defun merge-pathnames (pathname
511 (defaults *default-pathname-defaults
*)
512 (default-version :newest
))
513 "Construct a filled in pathname by completing the unspecified components
515 (declare (type pathname-designator pathname
)
516 (type pathname-designator defaults
)
518 (with-pathname (defaults defaults
)
519 (let* ((pathname (let ((*default-pathname-defaults
* defaults
))
520 (pathname pathname
)))
521 (default-host (%pathname-host defaults
))
522 (pathname-host (%pathname-host pathname
))
524 (and default-host pathname-host
525 (not (eq (host-customary-case default-host
)
526 (host-customary-case pathname-host
)))))
527 (directory (merge-directories (%pathname-directory pathname
)
528 (%pathname-directory defaults
)
530 (macrolet ((merged-component (component)
531 `(or (,component pathname
)
532 (let ((default (,component defaults
)))
534 (diddle-case default
)
536 (%make-maybe-logical-pathname
537 (or pathname-host default-host
)
538 ;; The device of ~/ shouldn't be merged, because the
539 ;; expansion may have a different device
540 (unless (typep directory
'(cons (eql :absolute
) (cons (eql :home
))))
541 (merged-component %pathname-device
))
543 (merged-component %pathname-name
)
544 (merged-component %pathname-type
)
545 (or (%pathname-version pathname
)
546 (and (not (%pathname-name pathname
)) (%pathname-version defaults
))
547 default-version
))))))
549 (defun import-directory (directory diddle-case
)
552 ((member :wild
) '(:absolute
:wild-inferiors
))
553 ((member :unspecific
) '(:relative
))
555 (let ((root (pop directory
))
557 (if (member root
'(:relative
:absolute
))
559 (error "List of directory components must start with ~S or ~S."
560 :absolute
:relative
))
562 (let ((next (car directory
)))
563 (when (or (eq :home next
)
564 (typep next
'(cons (eql :home
) (cons string null
))))
565 (push (pop directory
) results
)))
566 (dolist (piece directory
)
568 ((member :wild
:wild-inferiors
:up
)
569 (push piece results
))
571 (if (typep (car results
) '(or string pattern
572 (member :wild
:wild-inferiors
)))
574 (push piece results
)))
576 (when (typep piece
'(and string
(not simple-array
)))
577 (setq piece
(coerce piece
'simple-string
)))
578 ;; Unix namestrings allow embedded "//" within them. Consecutive
579 ;; slashes are treated as one, which is weird but often convenient.
580 ;; However, preserving empty directory components:
582 ;; - makes (NAMESTRING (MAKE-PATHNAME :DIRECTORY '(:RELATIVE "" "d")))
583 ;; visually indistinguishable from the absolute pathname "/d/"
584 ;; - can causes a pathname equality test to return NIL
585 ;; on semantically equivalent pathnames. This can happen for
586 ;; other reasons, but fewer false negatives is better.
587 (unless (and (stringp piece
) (zerop (length piece
)))
588 (push (maybe-diddle-case piece diddle-case
) results
)))
590 (error "~S is not allowed as a directory component." piece
)))))
593 (cond ((zerop (length directory
)) `(:absolute
))
595 (when (typep directory
'(not simple-array
))
596 (setq directory
(coerce directory
'simple-string
)))
597 `(:absolute
,(maybe-diddle-case directory diddle-case
)))))))
599 (defun make-pathname (&key host
604 (version nil versionp
)
607 "Makes a new pathname from the component arguments. Note that host is
608 a host-structure or string."
609 (declare (type (or string host pathname-component-tokens
) host
)
610 (type (or string pathname-component-tokens
) device
)
611 (type (or list string pattern pathname-component-tokens
) directory
)
612 (type (or string pattern pathname-component-tokens
) name type
)
613 (type (or integer pathname-component-tokens
(member :newest
))
615 (type (or pathname-designator null
) defaults
)
616 (type pathname-component-case case
))
617 (let* ((defaults (when defaults
618 (with-pathname (defaults defaults
) defaults
)))
619 (default-host (if defaults
620 (%pathname-host defaults
)
621 (pathname-host *default-pathname-defaults
*)))
622 ;; Raymond Toy writes: CLHS says make-pathname can take a
623 ;; string (as a logical-host) for the host part. We map that
624 ;; string into the corresponding logical host structure.
626 ;; Paul Werkowski writes:
627 ;; HyperSpec says for the arg to MAKE-PATHNAME;
628 ;; "host---a valid physical pathname host. ..."
629 ;; where it probably means -- a valid pathname host.
630 ;; "valid pathname host n. a valid physical pathname host or
631 ;; a valid logical pathname host."
633 ;; "valid physical pathname host n. any of a string,
634 ;; a list of strings, or the symbol :unspecific,
635 ;; that is recognized by the implementation as the name of a host."
636 ;; "valid logical pathname host n. a string that has been defined
637 ;; as the name of a logical host. ..."
638 ;; HS is silent on what happens if the :HOST arg is NOT one of these.
639 ;; It seems an error message is appropriate.
640 (host (or (find-host host nil
) default-host
))
641 (diddle-args (and (eq (host-customary-case host
) :lower
)
644 (not (eq (host-customary-case host
)
645 (host-customary-case default-host
))))
646 (dir (import-directory directory diddle-args
))
649 (defaults (%pathname-version defaults
))
651 (when (and defaults
(not dirp
))
653 (merge-directories dir
654 (%pathname-directory defaults
)
657 (macrolet ((pick (var varp field
)
658 `(cond ((or (simple-string-p ,var
)
660 (maybe-diddle-case ,var diddle-args
))
662 (maybe-diddle-case (coerce ,var
'simple-string
)
665 (maybe-diddle-case ,var diddle-args
))
667 (maybe-diddle-case (,field defaults
)
671 (%make-maybe-logical-pathname
673 (pick device devp %pathname-device
) ; forced to :UNSPECIFIC when logical
675 (pick name namep %pathname-name
)
676 (pick type typep %pathname-type
)
679 (defun pathname-host (pathname &key
(case :local
))
680 "Return PATHNAME's host."
681 (declare (ignore case
))
682 (with-pathname (pathname pathname
)
683 (%pathname-host pathname
)))
685 (macrolet ((frob (name component docstring
)
686 `(defun ,name
(pathname &key
(case :local
))
688 (with-pathname (pathname pathname
)
689 (let ((effective-case (and (eq case
:common
)
690 (eq (host-customary-case
691 (%pathname-host pathname
))
693 (maybe-diddle-case (,component pathname
) effective-case
))))))
695 (frob pathname-device %pathname-device
"Return PATHNAME's device.")
696 (frob pathname-directory %pathname-directory
"Return PATHNAME's directory.")
697 (frob pathname-name %pathname-name
"Return PATHNAME's name.")
698 (frob pathname-type %pathname-type
"Return PATHNAME's type."))
700 (defun pathname-version (pathname)
701 "Return PATHNAME's version."
702 (with-pathname (pathname pathname
)
703 (%pathname-version pathname
)))
707 ;;; Handle the case for PARSE-NAMESTRING parsing a potentially
708 ;;; syntactically valid logical namestring with an explicit host.
710 ;;; This then isn't fully general -- we are relying on the fact that
711 ;;; we will only pass to parse-namestring namestring with an explicit
712 ;;; logical host, so that we can pass the host return from
713 ;;; parse-logical-namestring through to %PARSE-NAMESTRING as a truth
714 ;;; value. Yeah, this is probably a KLUDGE - CSR, 2002-04-18
715 (defun parseable-logical-namestring-p (namestr start end
)
718 ((namestring-parse-error (lambda (c)
721 (let ((colon (position #\
: namestr
:start start
:end end
)))
723 (let ((potential-host
724 (logical-word-or-lose (subseq namestr start colon
))))
725 ;; depending on the outcome of CSR comp.lang.lisp post
726 ;; "can PARSE-NAMESTRING create logical hosts", we may need
727 ;; to do things with potential-host (create it
728 ;; temporarily, parse the namestring and unintern the
729 ;; logical host potential-host on failure.
730 (declare (ignore potential-host
))
733 ((simple-type-error (lambda (c)
736 (parse-logical-namestring namestr start end
))))
737 ;; if we got this far, we should have an explicit host
738 ;; (first return value of parse-logical-namestring)
742 ;;; Handle the case where PARSE-NAMESTRING is actually parsing a
743 ;;; namestring. We pick off the :JUNK-ALLOWED case then find a host to
744 ;;; use for parsing, call the parser, then check whether the host matches.
745 (defun %parse-namestring
(namestr host defaults start end junk-allowed
)
746 (declare (type (or host null
) host
)
747 (type string namestr
)
749 (type (or index null
) end
))
753 (%parse-namestring namestr host defaults start end nil
)
754 (namestring-parse-error (condition)
755 (values nil
(namestring-parse-error-offset condition
)))))
757 (let ((end (%check-vector-sequence-bounds namestr start end
)))
758 (multiple-value-bind (new-host device directory file type version
)
759 ;; Comments below are quotes from the HyperSpec
760 ;; PARSE-NAMESTRING entry, reproduced here to demonstrate
761 ;; that we actually have to do things this way rather than
762 ;; some possibly more logical way. - CSR, 2002-04-18
764 ;; "If host is a logical host then thing is parsed as a
765 ;; logical pathname namestring on the host."
766 (host (funcall (host-parse host
) namestr start end
))
767 ;; "If host is nil and thing is a syntactically valid
768 ;; logical pathname namestring containing an explicit
769 ;; host, then it is parsed as a logical pathname
771 ((parseable-logical-namestring-p namestr start end
)
772 (parse-logical-namestring namestr start end
))
773 ;; "If host is nil, default-pathname is a logical
774 ;; pathname, and thing is a syntactically valid logical
775 ;; pathname namestring without an explicit host, then it
776 ;; is parsed as a logical pathname namestring on the
777 ;; host that is the host component of default-pathname."
779 ;; "Otherwise, the parsing of thing is
780 ;; implementation-defined."
782 ;; Both clauses are handled here, as the default
783 ;; *DEFAULT-PATHNAME-DEFAULTS* has a SB-IMPL::UNIX-HOST
785 ((pathname-host defaults
)
786 (funcall (host-parse (pathname-host defaults
))
790 ;; I don't think we should ever get here, as the default
791 ;; host will always have a non-null HOST, given that we
792 ;; can't create a new pathname without going through
793 ;; *DEFAULT-PATHNAME-DEFAULTS*, which has a non-null
795 (t (bug "Fallen through COND in %PARSE-NAMESTRING")))
796 (when (and host new-host
(not (eq new-host host
)))
797 (error 'simple-type-error
799 ;; Note: ANSI requires that this be a TYPE-ERROR,
800 ;; but there seems to be no completely correct
801 ;; value to use for TYPE-ERROR-EXPECTED-TYPE.
802 ;; Instead, we return a sort of "type error allowed
803 ;; type", trying to say "it would be OK if you
804 ;; passed NIL as the host value" but not mentioning
805 ;; that a matching string would be OK too.
808 "The host in the namestring, ~S,~@
809 does not match the explicit HOST argument, ~S."
810 :format-arguments
(list new-host host
)))
811 (let ((pn-host (or new-host host
(pathname-host defaults
))))
812 (values (%make-maybe-logical-pathname
813 pn-host device directory file type version
)
816 ;;; If NAMESTR begins with a colon-terminated, defined, logical host,
817 ;;; then return that host, otherwise return NIL.
818 (defun extract-logical-host-prefix (namestr start end
)
819 (declare (type simple-string namestr
)
820 (type index start end
)
821 (values (or logical-host null
)))
822 (let ((colon-pos (position #\
: namestr
:start start
:end end
)))
824 (values (gethash (nstring-upcase (subseq namestr start colon-pos
))
828 (defun parse-namestring (thing
831 (defaults *default-pathname-defaults
*)
832 &key
(start 0) end junk-allowed
)
833 (declare (ftype (function * (values (or null pathname
) (or null index
)))
835 (with-host (found-host host
)
836 (let (;; According to ANSI defaults may be any valid pathname designator
837 (defaults (etypecase defaults
841 (aver (pathnamep *default-pathname-defaults
*))
842 (parse-namestring defaults
))
844 (truename defaults
)))))
845 (declare (type pathname defaults
))
848 (with-array-data ((thing thing
) (start start
) (end end
)
849 :check-fill-pointer t
)
850 (multiple-value-bind (pathname position
)
851 (%parse-namestring thing found-host defaults start end junk-allowed
)
852 (values pathname
(- position start
)))))
854 (let ((defaulted-host (or found-host
(%pathname-host defaults
))))
855 (declare (type host defaulted-host
))
856 (unless (eq defaulted-host
(%pathname-host thing
))
857 (error "The HOST argument doesn't match the pathname host:~% ~
859 defaulted-host
(%pathname-host thing
))))
860 (values thing start
))
861 ((or file-stream synonym-stream
)
862 (values (stream-file-name-or-lose thing
) nil
))))))
864 (defun %parse-native-namestring
(namestr host defaults start end junk-allowed
866 (declare (type (or host null
) host
)
867 (type string namestr
)
869 (type (or index null
) end
))
873 (%parse-native-namestring namestr host defaults start end nil as-directory
)
874 (namestring-parse-error (condition)
875 (values nil
(namestring-parse-error-offset condition
)))))
877 (let* ((end (%check-vector-sequence-bounds namestr start end
)))
878 (multiple-value-bind (new-host device directory file type version
)
881 (funcall (host-parse-native host
) namestr start end as-directory
))
882 ((pathname-host defaults
)
883 (funcall (host-parse-native (pathname-host defaults
))
888 ;; I don't think we should ever get here, as the default
889 ;; host will always have a non-null HOST, given that we
890 ;; can't create a new pathname without going through
891 ;; *DEFAULT-PATHNAME-DEFAULTS*, which has a non-null
893 (t (bug "Fallen through COND in %PARSE-NAMESTRING")))
894 (when (and host new-host
(not (eq new-host host
)))
895 (error 'simple-type-error
897 :expected-type
`(or null
(eql ,host
))
899 "The host in the namestring, ~S,~@
900 does not match the explicit HOST argument, ~S."
901 :format-arguments
(list new-host host
)))
902 (let ((pn-host (or new-host host
(pathname-host defaults
))))
903 (values (%make-pathname
904 pn-host device directory file type version
)
907 (defun parse-native-namestring (thing
910 (defaults *default-pathname-defaults
*)
911 &key
(start 0) end junk-allowed
913 "Convert THING into a pathname, using the native conventions
914 appropriate for the pathname host HOST, or if not specified the
915 host of DEFAULTS. If THING is a string, the parse is bounded by
916 START and END, and error behaviour is controlled by JUNK-ALLOWED,
917 as with PARSE-NAMESTRING. For file systems whose native
918 conventions allow directories to be indicated as files, if
919 AS-DIRECTORY is true, return a pathname denoting THING as a
921 (declare (type pathname-designator thing defaults
)
922 (type (or list host string
(member :unspecific
)) host
)
924 (type (or index null
) end
)
925 (type (or t null
) junk-allowed
)
926 (values (or null pathname
) (or null index
)))
927 (declare (ftype (function * (values (or null pathname
) (or null index
)))
928 %parse-native-namestring
))
929 (with-host (found-host host
)
930 (let ((defaults (etypecase defaults
934 (aver (pathnamep *default-pathname-defaults
*))
935 (parse-native-namestring defaults
))
937 (truename defaults
)))))
938 (declare (type pathname defaults
))
941 (with-array-data ((thing thing
) (start start
) (end end
)
942 :check-fill-pointer t
)
943 (multiple-value-bind (pathname position
)
944 (%parse-native-namestring thing
945 found-host defaults start end junk-allowed
947 (values pathname
(- position start
)))))
949 (let ((defaulted-host (or found-host
(%pathname-host defaults
))))
950 (declare (type host defaulted-host
))
951 (unless (eq defaulted-host
(%pathname-host thing
))
952 (error "The HOST argument doesn't match the pathname host:~% ~
954 defaulted-host
(%pathname-host thing
))))
955 (values thing start
))
956 ((or file-stream synonym-stream
)
957 (values (stream-file-name-or-lose thing
) nil
))))))
959 (defun native-namestring (pathname &key as-file
)
960 "Construct the full native (name)string form of PATHNAME. For
961 file systems whose native conventions allow directories to be
962 indicated as files, if AS-FILE is true and the name, type, and
963 version components of PATHNAME are all NIL or :UNSPECIFIC,
964 construct a string that names the directory according to the file
965 system's syntax for files."
966 (declare (type pathname-designator pathname
))
967 (with-native-pathname (pathname pathname
)
969 (let ((host (or (%pathname-host pathname
)
970 (no-native-namestring-error
971 pathname
"there is no ~S component." :host
))))
972 (funcall (host-unparse-native host
) pathname as-file
)))))
974 (flet ((pathname-host-or-no-namestring (pathname)
975 (or (%pathname-host pathname
)
977 pathname
"there is no ~S component." :host
))))
979 (defun namestring (pathname)
980 "Construct the full (name)string form PATHNAME."
981 (with-pathname (pathname pathname
)
983 (or (%pathname-namestring pathname
)
984 (let ((host (pathname-host-or-no-namestring pathname
)))
985 (setf (%pathname-namestring pathname
)
986 (logically-readonlyize
987 (possibly-base-stringize
988 (funcall (host-unparse host
) pathname
)))))))))
990 (defun host-namestring (pathname)
991 "Return a string representation of the name of the host in PATHNAME."
992 (with-pathname (pathname pathname
)
993 (let ((host (pathname-host-or-no-namestring pathname
)))
994 (funcall (host-unparse-host host
) pathname
))))
996 (defun directory-namestring (pathname)
997 "Return a string representation of the directory in PATHNAME."
998 (with-pathname (pathname pathname
)
999 (let ((host (pathname-host-or-no-namestring pathname
)))
1000 (funcall (host-unparse-directory host
) pathname
))))
1002 (defun file-namestring (pathname)
1003 "Return a string representation of the name in PATHNAME."
1004 (with-pathname (pathname pathname
)
1005 (let ((host (pathname-host-or-no-namestring pathname
)))
1006 (funcall (host-unparse-file host
) pathname
))))
1008 (defun enough-namestring (pathname
1010 (defaults *default-pathname-defaults
*))
1011 "Return an abbreviated pathname sufficient to identify PATHNAME
1012 relative to DEFAULTS."
1013 (with-pathname (pathname pathname
)
1014 (let ((host (pathname-host-or-no-namestring pathname
)))
1015 (with-pathname (defaults defaults
)
1016 (funcall (host-unparse-enough host
) pathname defaults
))))))
1020 (defun wild-pathname-p (pathname &optional field-key
)
1021 "Predicate for determining whether pathname contains any wildcards."
1022 (declare (type pathname-designator pathname
)
1023 (type (member nil
:host
:device
:directory
:name
:type
:version
)
1025 (with-pathname (pathname pathname
)
1027 (or (pattern-p x
) (member x
'(:wild
:wild-inferiors
)))))
1030 (or (wild-pathname-p pathname
:host
)
1031 (wild-pathname-p pathname
:device
)
1032 (wild-pathname-p pathname
:directory
)
1033 (wild-pathname-p pathname
:name
)
1034 (wild-pathname-p pathname
:type
)
1035 (wild-pathname-p pathname
:version
)))
1036 (:host
(frob (%pathname-host pathname
)))
1037 (:device
(frob (%pathname-host pathname
)))
1038 (:directory
(some #'frob
(%pathname-directory pathname
)))
1039 (:name
(frob (%pathname-name pathname
)))
1040 (:type
(frob (%pathname-type pathname
)))
1041 (:version
(frob (%pathname-version pathname
)))))))
1043 (defun pathname-match-p (in-pathname in-wildname
)
1044 "Pathname matches the wildname template?"
1045 (declare (type pathname-designator in-pathname
))
1046 (with-pathname (pathname in-pathname
)
1047 (with-pathname (wildname in-wildname
)
1048 (macrolet ((frob (field &optional
(op 'components-match
))
1049 `(or (null (,field wildname
))
1050 (,op
(,field pathname
) (,field wildname
)))))
1051 (and (or (null (%pathname-host wildname
))
1052 (eq (%pathname-host wildname
) (%pathname-host pathname
)))
1053 (frob %pathname-device
)
1054 (frob %pathname-directory directory-components-match
)
1055 (frob %pathname-name
)
1056 (frob %pathname-type
)
1057 (or (eq (%pathname-host wildname
) *physical-host
*)
1058 (frob %pathname-version
)))))))
1060 ;;; Place the substitutions into the pattern and return the string or pattern
1061 ;;; that results. If DIDDLE-CASE is true, we diddle the result case as well,
1062 ;;; in case we are translating between hosts with difference conventional case.
1063 ;;; The second value is the tail of subs with all of the values that we used up
1064 ;;; stripped off. Note that PATTERN-MATCHES matches all consecutive wildcards
1065 ;;; as a single string, so we ignore subsequent contiguous wildcards.
1066 (defun substitute-into (pattern subs diddle-case
)
1067 (declare (type pattern pattern
)
1069 (values (or simple-string pattern
) list
))
1070 (let ((in-wildcard nil
)
1073 (dolist (piece (pattern-pieces pattern
))
1074 (cond ((simple-string-p piece
)
1075 (push piece strings
)
1076 (setf in-wildcard nil
))
1079 (setf in-wildcard t
)
1081 (error "not enough wildcards in FROM pattern to match ~
1084 (let ((sub (pop subs
)))
1088 (push (apply #'concatenate
'simple-string
1091 (dolist (piece (pattern-pieces sub
))
1092 (push piece pieces
)))
1096 (error "can't substitute this into the middle of a word:~
1101 (push (apply #'concatenate
'simple-string
(nreverse strings
))
1105 (if (and pieces
(simple-string-p (car pieces
)) (null (cdr pieces
)))
1107 (make-pattern (nreverse pieces
)))
1111 ;;; Called when we can't see how source and from matched.
1112 (defun didnt-match-error (source from
)
1113 (error "Pathname components from SOURCE and FROM args to TRANSLATE-PATHNAME~@
1114 did not match:~% ~S ~S"
1117 ;;; Do TRANSLATE-COMPONENT for all components except host, directory
1119 (defun translate-component (source from to diddle-case
)
1126 (if (pattern= from source
)
1128 (didnt-match-error source from
)))
1130 (multiple-value-bind (won subs
) (pattern-matches from source
)
1132 (values (substitute-into to subs diddle-case
))
1133 (didnt-match-error source from
))))
1135 (maybe-diddle-case source diddle-case
))))
1137 (values (substitute-into to
(list source
) diddle-case
)))
1139 (if (components-match source from
)
1140 (maybe-diddle-case source diddle-case
)
1141 (didnt-match-error source from
)))))
1143 (maybe-diddle-case source diddle-case
))
1145 (if (components-match source from
)
1147 (didnt-match-error source from
)))))
1149 ;;; Return a list of all the things that we want to substitute into the TO
1150 ;;; pattern (the things matched by from on source.) When From contains
1151 ;;; :WILD-INFERIORS, the result contains a sublist of the matched source
1153 (defun compute-directory-substitutions (orig-source orig-from
)
1154 (let ((source orig-source
)
1159 (unless (every (lambda (x) (eq x
:wild-inferiors
)) from
)
1160 (didnt-match-error orig-source orig-from
))
1163 (unless from
(didnt-match-error orig-source orig-from
))
1164 (let ((from-part (pop from
))
1165 (source-part (pop source
)))
1168 (typecase source-part
1170 (if (pattern= from-part source-part
)
1172 (didnt-match-error orig-source orig-from
)))
1174 (multiple-value-bind (won new-subs
)
1175 (pattern-matches from-part source-part
)
1177 (dolist (sub new-subs
)
1179 (didnt-match-error orig-source orig-from
))))
1181 (didnt-match-error orig-source orig-from
))))
1184 ((member :wild-inferiors
)
1185 (let ((remaining-source (cons source-part source
)))
1188 (when (directory-components-match remaining-source from
)
1190 (unless remaining-source
1191 (didnt-match-error orig-source orig-from
))
1192 (res (pop remaining-source
)))
1194 (setq source remaining-source
))))
1196 (unless (and (simple-string-p source-part
)
1197 (string= from-part source-part
))
1198 (didnt-match-error orig-source orig-from
)))
1200 (didnt-match-error orig-source orig-from
)))))
1203 ;;; This is called by TRANSLATE-PATHNAME on the directory components
1204 ;;; of its argument pathnames to produce the result directory
1205 ;;; component. If this leaves the directory NIL, we return the source
1206 ;;; directory. The :RELATIVE or :ABSOLUTE is taken from the source
1207 ;;; directory, except if TO is :ABSOLUTE, in which case the result
1208 ;;; will be :ABSOLUTE.
1209 (defun translate-directories (source from to diddle-case
)
1210 (if (not (and source to from
))
1211 (or (and to
(null source
) (remove :wild-inferiors to
))
1212 (mapcar (lambda (x) (maybe-diddle-case x diddle-case
)) source
))
1214 ;; If TO is :ABSOLUTE, the result should still be :ABSOLUTE.
1215 (res (if (eq (first to
) :absolute
)
1218 (let ((subs-left (compute-directory-substitutions (rest source
)
1220 (dolist (to-part (rest to
))
1224 (let ((match (pop subs-left
)))
1226 (error ":WILD-INFERIORS is not paired in from and to ~
1227 patterns:~% ~S ~S" from to
))
1228 (res (maybe-diddle-case match diddle-case
))))
1229 ((member :wild-inferiors
)
1231 (let ((match (pop subs-left
)))
1232 (unless (listp match
)
1233 (error ":WILD-INFERIORS not paired in from and to ~
1234 patterns:~% ~S ~S" from to
))
1236 (res (maybe-diddle-case x diddle-case
)))))
1238 (multiple-value-bind
1240 (substitute-into to-part subs-left diddle-case
)
1241 (setf subs-left new-subs-left
)
1243 (t (res to-part
)))))
1246 (defun translate-pathname (source from-wildname to-wildname
&key
)
1247 "Use the source pathname to translate the from-wildname's wild and
1248 unspecified elements into a completed to-pathname based on the to-wildname."
1249 (declare (type pathname-designator source from-wildname to-wildname
))
1250 (with-pathname (source source
)
1251 (with-pathname (from from-wildname
)
1252 (with-pathname (to to-wildname
)
1253 (let* ((source-host (%pathname-host source
))
1254 (from-host (%pathname-host from
))
1255 (to-host (%pathname-host to
))
1257 (and source-host to-host
1258 (not (eq (host-customary-case source-host
)
1259 (host-customary-case to-host
))))))
1260 (macrolet ((frob (field &optional
(op 'translate-component
))
1261 `(let ((result (,op
(,field source
)
1265 (if (eq result
:error
)
1266 (error "~S doesn't match ~S." source from
)
1268 (%make-maybe-logical-pathname
1269 (or to-host source-host
)
1270 (frob %pathname-device
)
1271 (frob %pathname-directory translate-directories
)
1272 (frob %pathname-name
)
1273 (frob %pathname-type
)
1274 (if (eq from-host
*physical-host
*)
1275 (if (or (eq (%pathname-version to
) :wild
)
1276 (eq (%pathname-version to
) nil
))
1277 (%pathname-version source
)
1278 (%pathname-version to
))
1279 (frob %pathname-version
)))))))))
1281 ;;;; logical pathname support. ANSI 92-102 specification.
1283 ;;;; As logical-pathname translations are loaded they are
1284 ;;;; canonicalized as patterns to enable rapid efficient translation
1285 ;;;; into physical pathnames.
1289 ;;; Access *DEFAULT-PATHNAME-DEFAULTS*, issuing a warning if its value
1290 ;;; is silly. (Unlike the vaguely-analogous SANE-PACKAGE, we don't
1291 ;;; actually need to reset the variable when it's silly, since even
1292 ;;; crazy values of *DEFAULT-PATHNAME-DEFAULTS* don't leave the system
1293 ;;; in a state where it's hard to recover interactively.)
1294 (defun sane-default-pathname-defaults ()
1295 (let* ((dfd *default-pathname-defaults
*)
1296 (dfd-dir (pathname-directory dfd
)))
1297 ;; It's generally not good to use a relative pathname for
1298 ;; *DEFAULT-PATHNAME-DEFAULTS*, since relative pathnames
1299 ;; are defined by merging into a default pathname (which is,
1300 ;; by default, *DEFAULT-PATHNAME-DEFAULTS*).
1301 (when (and (consp dfd-dir
)
1302 (eql (first dfd-dir
) :relative
))
1304 "~@<~S is a relative pathname. (But we'll try using it anyway.)~@:>"
1305 '*default-pathname-defaults
*))
1308 (defun simplify-namestring (namestring &optional host
)
1309 (funcall (host-simplify-namestring
1311 (pathname-host (sane-default-pathname-defaults))))
1314 ;;; Canonicalize a logical pathname word by uppercasing it checking that it
1315 ;;; contains only legal characters.
1316 (defun logical-word-or-lose (word)
1317 (declare (string word
))
1318 (when (string= word
"")
1319 (error 'namestring-parse-error
1320 :complaint
"Attempted to treat invalid logical hostname ~
1321 as a logical host:~% ~S"
1323 :namestring word
:offset
0))
1324 (let ((word (string-upcase word
)))
1325 (dotimes (i (length word
))
1326 (let ((ch (schar word i
)))
1327 (unless (and (typep ch
'standard-char
)
1328 (or (alpha-char-p ch
) (digit-char-p ch
) (char= ch
#\-
)))
1329 (error 'namestring-parse-error
1330 :complaint
"logical namestring character which ~
1331 is not alphanumeric or hyphen:~% ~S"
1333 :namestring word
:offset i
))))
1334 (coerce word
'string
))) ; why not simple-string?
1336 ;;; Given a logical host or string, return a logical host. If ERROR-P
1337 ;;; is NIL, then return NIL when no such host exists.
1338 (defun find-logical-host (thing &optional
(errorp t
))
1341 (let ((found (gethash (logical-word-or-lose thing
)
1343 (if (or found
(not errorp
))
1345 ;; This is the error signalled from e.g.
1346 ;; LOGICAL-PATHNAME-TRANSLATIONS when host is not a defined
1347 ;; host, and ANSI specifies that that's a TYPE-ERROR.
1348 (error 'simple-type-error
1350 ;; God only knows what ANSI expects us to use for
1351 ;; the EXPECTED-TYPE here. Maybe this will be OK..
1353 '(and string
(satisfies logical-pathname-translations
))
1354 :format-control
"logical host not yet defined: ~S"
1355 :format-arguments
(list thing
)))))
1356 (logical-host thing
)))
1358 ;;; Given a logical host name or host, return a logical host, creating
1359 ;;; a new one if necessary.
1360 (defun intern-logical-host (thing)
1361 (with-locked-system-table (*logical-hosts
*)
1362 (or (find-logical-host thing nil
)
1363 (let* ((name (logical-word-or-lose thing
))
1364 (new (make-logical-host :name name
)))
1365 (setf (gethash name
*logical-hosts
*) new
)
1368 ;;;; logical pathname parsing
1370 ;;; Deal with multi-char wildcards in a logical pathname token.
1371 (defun maybe-make-logical-pattern (namestring chunks
)
1372 (let ((chunk (caar chunks
)))
1373 (collect ((pattern))
1375 (len (length chunk
)))
1376 (declare (fixnum last-pos
))
1378 (when (= last-pos len
) (return))
1379 (let ((pos (or (position #\
* chunk
:start last-pos
) len
)))
1380 (if (= pos last-pos
)
1382 (error 'namestring-parse-error
1383 :complaint
"double asterisk inside of logical ~
1386 :namestring namestring
1387 :offset
(+ (cdar chunks
) pos
)))
1388 (pattern (subseq chunk last-pos pos
)))
1391 (pattern :multi-char-wild
))
1392 (setq last-pos
(1+ pos
)))))
1395 (make-pattern (pattern))
1396 (let ((x (car (pattern))))
1397 (if (eq x
:multi-char-wild
)
1401 ;;; Return a list of conses where the CDR is the start position and
1402 ;;; the CAR is a string (token) or character (punctuation.)
1403 (defun logical-chunkify (namestr start end
)
1405 (do ((i start
(1+ i
))
1409 (chunks (cons (nstring-upcase (subseq namestr prev end
)) prev
))))
1410 (let ((ch (schar namestr i
)))
1411 (unless (or (alpha-char-p ch
) (digit-char-p ch
)
1412 (member ch
'(#\-
#\
*)))
1414 (chunks (cons (nstring-upcase (subseq namestr prev i
)) prev
)))
1416 (unless (member ch
'(#\
; #\: #\.))
1417 (error 'namestring-parse-error
1418 :complaint
"illegal character for logical pathname:~% ~S"
1422 (chunks (cons ch i
)))))
1425 ;;; Break up a logical-namestring, always a string, into its
1426 ;;; constituent parts.
1427 (defun parse-logical-namestring (namestr start end
)
1428 (declare (type simple-string namestr
)
1429 (type index start end
))
1430 (collect ((directory))
1435 (labels ((expecting (what chunks
)
1436 (unless (and chunks
(simple-string-p (caar chunks
)))
1437 (error 'namestring-parse-error
1438 :complaint
"expecting ~A, got ~:[nothing~;~S~]."
1439 :args
(list what
(caar chunks
) (caar chunks
))
1441 :offset
(if chunks
(cdar chunks
) end
)))
1443 (parse-host (chunks)
1444 (case (caadr chunks
)
1447 (find-logical-host (expecting "a host name" chunks
)))
1448 (parse-relative (cddr chunks
)))
1450 (parse-relative chunks
))))
1451 (parse-relative (chunks)
1454 (directory :relative
)
1455 (parse-directory (cdr chunks
)))
1457 (directory :absolute
) ; Assumption! Maybe revoked later.
1458 (parse-directory chunks
))))
1459 (parse-directory (chunks)
1460 (case (caadr chunks
)
1463 (let ((res (expecting "a directory name" chunks
)))
1464 (cond ((string= res
"..") :up
)
1465 ((string= res
"**") :wild-inferiors
)
1467 (maybe-make-logical-pattern namestr chunks
)))))
1468 (parse-directory (cddr chunks
)))
1470 (parse-name chunks
))))
1471 (parse-name (chunks)
1473 (expecting "a file name" chunks
)
1474 (setq name
(maybe-make-logical-pattern namestr chunks
))
1475 (expecting-dot (cdr chunks
))))
1476 (expecting-dot (chunks)
1478 (unless (eql (caar chunks
) #\.
)
1479 (error 'namestring-parse-error
1480 :complaint
"expecting a dot, got ~S."
1481 :args
(list (caar chunks
))
1483 :offset
(cdar chunks
)))
1485 (parse-version (cdr chunks
))
1486 (parse-type (cdr chunks
)))))
1487 (parse-type (chunks)
1488 (expecting "a file type" chunks
)
1489 (setq type
(maybe-make-logical-pattern namestr chunks
))
1490 (expecting-dot (cdr chunks
)))
1491 (parse-version (chunks)
1492 (let ((str (expecting "a positive integer, * or NEWEST"
1495 ((string= str
"*") (setq version
:wild
))
1496 ((string= str
"NEWEST") (setq version
:newest
))
1498 (multiple-value-bind (res pos
)
1499 (parse-integer str
:junk-allowed t
)
1500 (unless (and res
(plusp res
))
1501 (error 'namestring-parse-error
1502 :complaint
"expected a positive integer, ~
1506 :offset
(+ pos
(cdar chunks
))))
1507 (setq version res
)))))
1509 (error 'namestring-parse-error
1510 :complaint
"extra stuff after end of file name"
1512 :offset
(cdadr chunks
)))))
1513 (parse-host (logical-chunkify namestr start end
)))
1514 (values host
:unspecific
(directory) name type version
))))
1516 ;;; We can't initialize this yet because not all host methods are
1518 (defvar *logical-pathname-defaults
*)
1520 (defun logical-namestring-p (x)
1523 (typep (pathname x
) 'logical-pathname
))))
1525 (deftype logical-namestring
()
1526 `(satisfies logical-namestring-p
))
1528 (defun logical-pathname (pathspec)
1529 "Converts the pathspec argument to a logical-pathname and returns it."
1530 (declare (type (or logical-pathname string stream
) pathspec
)
1531 (values logical-pathname
))
1532 (if (typep pathspec
'logical-pathname
)
1534 (flet ((oops (problem)
1535 (error 'simple-type-error
1537 :expected-type
'logical-namestring
1538 :format-control
"~S is not a valid logical namestring:~% ~A"
1539 :format-arguments
(list pathspec problem
))))
1540 (let ((res (handler-case
1541 (parse-namestring pathspec nil
*logical-pathname-defaults
*)
1542 (error (e) (oops e
)))))
1543 (when (eq (%pathname-host res
)
1544 (%pathname-host
*logical-pathname-defaults
*))
1545 (oops "no host specified"))
1548 ;;;; logical pathname unparsing
1550 (defun unparse-logical-directory (pathname)
1551 (declare (type pathname pathname
))
1553 (let ((directory (%pathname-directory pathname
)))
1555 (ecase (pop directory
)
1556 (:absolute
) ; nothing special
1557 (:relative
(pieces ";")))
1558 (dolist (dir directory
)
1559 (cond ((or (stringp dir
) (pattern-p dir
))
1560 (pieces (unparse-logical-piece dir
))
1564 ((eq dir
:wild-inferiors
)
1567 (error "invalid directory component: ~S" dir
))))))
1568 (apply #'concatenate
'simple-string
(pieces))))
1570 (defun unparse-logical-piece (thing)
1572 ((member :wild
) "*")
1573 (simple-string thing
)
1575 (collect ((strings))
1576 (dolist (piece (pattern-pieces thing
))
1578 (simple-string (strings piece
))
1580 (cond ((eq piece
:wild-inferiors
)
1582 ((eq piece
:multi-char-wild
)
1584 (t (error "invalid keyword: ~S" piece
))))))
1585 (apply #'concatenate
'simple-string
(strings))))))
1587 (defun unparse-logical-file (pathname)
1588 (declare (type pathname pathname
))
1589 (collect ((strings))
1590 (let* ((name (%pathname-name pathname
))
1591 (type (%pathname-type pathname
))
1592 (version (%pathname-version pathname
))
1593 (type-supplied (pathname-component-present-p type
))
1594 (version-supplied (pathname-component-present-p version
)))
1596 (when (and (null type
)
1597 (typep name
'string
)
1598 (position #\. name
:start
1))
1599 (error "too many dots in the name: ~S" pathname
))
1600 (strings (unparse-logical-piece name
)))
1603 (error "cannot specify the type without a file: ~S" pathname
))
1604 (when (typep type
'string
)
1605 (when (position #\. type
)
1606 (error "type component can't have a #\. inside: ~S" pathname
)))
1608 (strings (unparse-logical-piece type
)))
1609 (when version-supplied
1610 (unless type-supplied
1611 (error "cannot specify the version without a type: ~S" pathname
))
1613 ((member :newest
) (strings ".NEWEST")) ; really? not in LPNIFY-NAMESTRING
1614 ((member :wild
) (strings ".*"))
1615 (fixnum (strings ".") (strings (format nil
"~D" version
))))))
1616 (apply #'concatenate
'simple-string
(strings))))
1618 ;;; Unparse a logical pathname string.
1619 (defun unparse-enough-namestring (pathname defaults
)
1620 (let* ((path-directory (pathname-directory pathname
))
1621 (def-directory (pathname-directory defaults
))
1623 ;; Go down the directory lists to see what matches. What's
1624 ;; left is what we want, more or less.
1625 (cond ((and (eq (first path-directory
) (first def-directory
))
1626 (eq (first path-directory
) :absolute
))
1627 ;; Both paths are :ABSOLUTE, so find where the
1628 ;; common parts end and return what's left
1629 (do* ((p (rest path-directory
) (rest p
))
1630 (d (rest def-directory
) (rest d
)))
1631 ((or (endp p
) (endp d
)
1632 (not (equal (first p
) (first d
))))
1635 ;; At least one path is :RELATIVE, so just return the
1636 ;; original path. If the original path is :RELATIVE,
1637 ;; then that's the right one. If PATH-DIRECTORY is
1638 ;; :ABSOLUTE, we want to return that except when
1639 ;; DEF-DIRECTORY is :ABSOLUTE, as handled above. so return
1640 ;; the original directory.
1642 (unparse-logical-namestring
1643 (make-pathname :host
(pathname-host pathname
)
1644 :directory enough-directory
1645 :name
(pathname-name pathname
)
1646 :type
(pathname-type pathname
)
1647 :version
(pathname-version pathname
)))))
1649 (defun unparse-logical-namestring (pathname)
1650 (declare (type logical-pathname pathname
))
1651 (concatenate 'simple-string
1652 (logical-host-name (%pathname-host pathname
)) ":"
1653 (unparse-logical-directory pathname
)
1654 (unparse-logical-file pathname
)))
1656 ;;;; logical pathname translations
1658 ;;; Verify that the list of translations consists of lists and prepare
1659 ;;; canonical translations. (Parse pathnames and expand out wildcards
1661 (defun canonicalize-logical-pathname-translations (translation-list host
)
1662 (declare (type list translation-list
) (type host host
)
1664 (mapcar (lambda (translation)
1665 (destructuring-bind (from to
) translation
1666 (list (if (typep from
'logical-pathname
)
1668 (parse-namestring from host
))
1672 (defun logical-pathname-translations (host)
1673 "Return the (logical) host object argument's list of translations."
1674 (declare (type (or string logical-host
) host
)
1676 (logical-host-translations (find-logical-host host
)))
1678 (defun (setf logical-pathname-translations
) (translations host
)
1679 "Set the translations list for the logical host argument."
1680 (declare (type (or string logical-host
) host
)
1681 (type list translations
)
1683 (let ((host (intern-logical-host host
)))
1684 (setf (logical-host-canon-transls host
)
1685 (canonicalize-logical-pathname-translations translations host
))
1686 (setf (logical-host-translations host
) translations
)))
1688 (defun translate-logical-pathname (pathname &key
)
1689 "Translate PATHNAME to a physical pathname, which is returned."
1690 (declare (type pathname-designator pathname
)
1691 (values (or null pathname
)))
1694 (dolist (x (logical-host-canon-transls (%pathname-host pathname
))
1695 (error 'simple-file-error
1697 :format-control
"no translation for ~S"
1698 :format-arguments
(list pathname
)))
1699 (destructuring-bind (from to
) x
1700 (when (pathname-match-p pathname from
)
1701 (return (translate-logical-pathname
1702 (translate-pathname pathname from to
)))))))
1704 (t (translate-logical-pathname (pathname pathname
)))))
1706 (defvar *logical-pathname-defaults
*
1707 (%make-logical-pathname
1708 (make-logical-host :name
(logical-word-or-lose "BOGUS"))
1709 :unspecific nil nil nil nil
))
1711 (defun load-logical-pathname-translations (host)
1712 "Reads logical pathname translations from SYS:SITE;HOST.TRANSLATIONS.NEWEST,
1713 with HOST replaced by the supplied parameter. Returns T on success.
1715 If HOST is already defined as logical pathname host, no file is loaded and NIL
1718 The file should contain a single form, suitable for use with
1719 \(SETF LOGICAL-PATHNAME-TRANSLATIONS).
1721 Note: behaviour of this function is highly implementation dependent, and
1722 historically it used to be a no-op in SBCL -- the current approach is somewhat
1723 experimental and subject to change."
1724 (declare (type string host
)
1725 (values (member t nil
)))
1726 (if (find-logical-host host nil
)
1727 ;; This host is already defined, all is well and good.
1729 ;; ANSI: "The specific nature of the search is
1730 ;; implementation-defined."
1732 (setf (logical-pathname-translations host
)
1733 (with-open-file (lpt (make-pathname :host
"SYS"
1734 :directory
'(:absolute
"SITE")
1736 :type
"TRANSLATIONS"
1740 (defun !pathname-cold-init
()
1741 (let* ((sys *default-pathname-defaults
*)
1744 (make-pathname :directory
'(:relative
"src" :wild-inferiors
)
1745 :name
:wild
:type
:wild
)
1749 (make-pathname :directory
'(:relative
"contrib" :wild-inferiors
)
1750 :name
:wild
:type
:wild
)
1754 (make-pathname :directory
'(:relative
"output" :wild-inferiors
)
1755 :name
:wild
:type
:wild
)
1757 (setf (logical-pathname-translations "SYS")
1758 `(("SYS:SRC;**;*.*.*" ,src
)
1759 ("SYS:CONTRIB;**;*.*.*" ,contrib
)
1760 ("SYS:OUTPUT;**;*.*.*" ,output
)))))
1762 (defun set-sbcl-source-location (pathname)
1763 "Initialize the SYS logical host based on PATHNAME, which should be
1764 the top-level directory of the SBCL sources. This will replace any
1765 existing translations for \"SYS:SRC;\", \"SYS:CONTRIB;\", and
1766 \"SYS:OUTPUT;\". Other \"SYS:\" translations are preserved."
1767 (let ((truename (truename pathname
))
1768 (current-translations
1769 (remove-if (lambda (translation)
1770 (or (pathname-match-p "SYS:SRC;" translation
)
1771 (pathname-match-p "SYS:CONTRIB;" translation
)
1772 (pathname-match-p "SYS:OUTPUT;" translation
)))
1773 (logical-pathname-translations "SYS")
1775 (flet ((physical-target (component)
1777 (make-pathname :directory
(list :relative component
1782 (setf (logical-pathname-translations "SYS")
1783 `(("SYS:SRC;**;*.*.*" ,(physical-target "src"))
1784 ("SYS:CONTRIB;**;*.*.*" ,(physical-target "contrib"))
1785 ("SYS:OUTPUT;**;*.*.*" ,(physical-target "output"))
1786 ,@current-translations
)))))