;;;; machine/filesystem-independent pathname functions
;;;; This software is part of the SBCL system. See the README file for
;;;; more information.
;;;;
;;;; This software is derived from the CMU CL system, which was
;;;; written at Carnegie Mellon University and released into the
;;;; public domain. The software is in the public domain and is
;;;; provided with absolutely no warranty. See the COPYING and CREDITS
;;;; files for more information.
(in-package "SB-IMPL")
(defstruct (logical-host
(:copier nil)
(:print-object
(lambda (logical-host stream)
(print-unreadable-object (logical-host stream :type t)
(prin1 (logical-host-name logical-host) stream))))
(:include host
(parse #'parse-logical-namestring)
(parse-native
(lambda (&rest x)
(error "called PARSE-NATIVE-NAMESTRING using a ~
logical host: ~S" (first x))))
(unparse #'unparse-logical-namestring)
(unparse-native
(lambda (&rest x)
(error "called NATIVE-NAMESTRING using a ~
logical host: ~S" (first x))))
(unparse-host
(lambda (x)
(logical-host-name (%pathname-host x))))
(unparse-directory #'unparse-logical-directory)
(unparse-file #'unparse-logical-file)
(unparse-enough #'unparse-enough-namestring)
(unparse-directory-separator ";")
(simplify-namestring #'identity)
(customary-case :upper)))
(name-hash 0 :type fixnum)
(name "" :type simple-string :read-only t)
(translations nil :type list)
(canon-transls nil :type list))
;;; Logical pathnames have the following format:
;;;
;;; logical-namestring ::=
;;; [host ":"] [";"] {directory ";"}* [name] ["." type ["." version]]
;;;
;;; host ::= word
;;; directory ::= word | wildcard-word | **
;;; name ::= word | wildcard-word
;;; type ::= word | wildcard-word
;;; version ::= pos-int | newest | NEWEST | *
;;; word ::= {uppercase-letter | digit | -}+
;;; wildcard-word ::= [word] '* {word '*}* [word]
;;; pos-int ::= integer > 0
;;;
;;; Physical pathnames include all these slots and a device slot.
;;; We can't freeze HOST because later on we define either UNIX-HOST or WIN32-HOST.
(declaim (freeze-type logical-host))
;;; Utility functions
(deftype absent-pathname-component ()
'(member nil :unspecific))
(defun make-pattern (pieces)
;; Ensure that the hash will meet the SXASH persistence requirement:
;; "2. For any two objects, x and y, both of which are ... pathnames ... and which are similar,
;; (sxhash x) and (sxhash y) yield the same mathematical value even if x and y exist in
;; different Lisp images of the same implementation."
;; Specifically, hashes that depend on object identity (address) are impermissible.
(dolist (piece pieces)
(aver (typep piece '(or string symbol (cons (eql :character-set) string)))))
(%make-pattern (sxhash pieces) pieces))
(declaim (inline %pathname-directory))
(defun %pathname-directory (pathname) (car (%pathname-dir+hash pathname)))
(declaim (inline pathname-component-present-p))
(defun pathname-component-present-p (component)
(not (typep component 'absent-pathname-component)))
;;; The following functions are used both for Unix and Windows: while
;;; we accept both \ and / as directory separators on Windows, we
;;; print our own always with /, which is much less confusing what
;;; with being \ needing to be escaped.
(defun unparse-physical-directory (pathname escape-char)
(declare (pathname pathname))
(unparse-physical-directory-list (%pathname-directory pathname) escape-char))
(defun unparse-physical-directory-list (directory escape-char)
(declare (list directory))
(collect ((pieces))
(when directory
(ecase (pop directory)
(:absolute
(let ((next (pop directory)))
(cond ((eq :home next)
(pieces "~"))
((and (consp next) (eq :home (car next)))
(pieces "~")
(pieces (second next)))
((and (stringp next)
(plusp (length next))
(char= #\~ (char next 0)))
;; The only place we need to escape the tilde.
(pieces "\\")
(pieces next))
(next
(push next directory)))
(pieces "/")))
(:relative))
(dolist (dir directory)
(typecase dir
((member :up)
(pieces "../"))
((member :back)
(error ":BACK cannot be represented in namestrings."))
((member :wild-inferiors)
(pieces "**/"))
((or simple-string pattern (member :wild))
(pieces (unparse-physical-piece dir escape-char))
(pieces "/"))
(t
(error "invalid directory component: ~S" dir)))))
(apply #'concatenate 'simple-string (pieces))))
(defun unparse-physical-file (pathname escape-char)
(declare (type pathname pathname))
(let ((name (%pathname-name pathname))
(type (%pathname-type pathname)))
(collect ((fragments))
;; Note: by ANSI 19.3.1.1.5, we ignore the version slot when
;; translating logical pathnames to a filesystem without
;; versions (like Unix and Win32).
(when name
(when (and (typep name 'string)
(string= name ""))
(no-namestring-error
pathname "the ~S component ~S is of length 0" :name name))
(fragments (unparse-physical-piece
name escape-char
:escape-dot (when (null type) :unless-at-start))))
(when (pathname-component-present-p type)
(unless name
(no-namestring-error
pathname
"there is a ~S component but no ~S component" :type :name))
(fragments ".")
(fragments (unparse-physical-piece
type escape-char :escape-dot t)))
(apply #'concatenate 'simple-string (fragments)))))
(defun unparse-native-physical-file (pathname)
(let ((name (pathname-name pathname))
(type (pathname-type pathname)))
(collect ((fragments))
(cond
((pathname-component-present-p name)
(unless (stringp name) ; some kind of wild field
(no-native-namestring-error
pathname "of the ~S component ~S." :name name))
(fragments name)
(when (pathname-component-present-p type)
(unless (stringp type) ; some kind of wild field
(no-native-namestring-error
pathname "of the ~S component ~S" :type type))
(fragments ".")
(fragments type)))
((pathname-component-present-p type) ; type without a name
(no-native-namestring-error
pathname
"there is a ~S component but no ~S component" :type :name)))
(apply #'concatenate 'simple-string (fragments)))))
(defun unparse-physical-enough (pathname defaults escape-char)
(declare (type pathname pathname defaults))
(flet ((lose ()
(error "~S cannot be represented relative to ~S."
pathname defaults)))
(collect ((strings))
(let* ((pathname-directory (%pathname-directory pathname))
(defaults-directory (%pathname-directory defaults))
(prefix-len (length defaults-directory))
(result-directory
(cond ((null pathname-directory) '(:relative))
((eq (car pathname-directory) :relative)
pathname-directory)
((and (> prefix-len 0)
(>= (length pathname-directory) prefix-len)
(compare-component (subseq pathname-directory
0 prefix-len)
defaults-directory))
;; Pathname starts with a prefix of default. So
;; just use a relative directory from then on out.
(cons :relative (nthcdr prefix-len pathname-directory)))
((eq (car pathname-directory) :absolute)
;; We are an absolute pathname, so we can just use it.
pathname-directory)
(t
(bug "Bad fallthrough in ~S" 'unparse-physical-enough)))))
(strings (unparse-physical-directory-list result-directory escape-char)))
(let* ((pathname-type (%pathname-type pathname))
(type-needed (pathname-component-present-p pathname-type))
(pathname-name (%pathname-name pathname))
(name-needed (or type-needed
(and pathname-name
(not (compare-component pathname-name
(%pathname-name
defaults)))))))
(when name-needed
(unless pathname-name (lose))
(strings (unparse-physical-piece
pathname-name escape-char
:escape-dot (when (not pathname-type) :unless-at-start))))
(when type-needed
(unless (pathname-component-present-p pathname-type)
(lose))
(strings ".")
(strings (unparse-physical-piece pathname-type
escape-char :escape-dot t))))
(apply #'concatenate 'simple-string (strings)))))
;;; To be initialized in unix/win32-pathname.lisp
(define-load-time-global *physical-host* nil)
;;; Return a value suitable, e.g., for preinitializing
;;; *DEFAULT-PATHNAME-DEFAULTS* before *DEFAULT-PATHNAME-DEFAULTS* is
;;; initialized (at which time we can't safely call e.g. #'PATHNAME).
(defun make-trivial-default-pathname ()
(intern-pathname *physical-host* nil nil nil nil :newest))
;;; pathname methods
(defun pathname-sxhash (x)
(declare (pathname x))
(pathname-key-hash x))
(defmethod print-object ((pathname pathname) stream)
(let ((namestring (handler-case (namestring pathname)
(error nil))))
(if namestring
(format stream
(if (or *print-readably* *print-escape*)
"#P~S"
"~A")
(coerce namestring '(simple-array character (*))))
(print-unreadable-object (pathname stream :type t)
(format stream
"~@<(with no namestring) ~_:HOST ~S ~_:DEVICE ~S ~_:DIRECTORY ~S ~
~_:NAME ~S ~_:TYPE ~S ~_:VERSION ~S~:>"
(%pathname-host pathname)
(%pathname-device pathname)
(%pathname-directory pathname)
(%pathname-name pathname)
(%pathname-type pathname)
(%pathname-version pathname))))))
;;; Use an unsynchronized weak hash table with explicit locking to "try"
;;; to intern pathnames. "Try" because there are several factors that preclude
;;; ensuring uniqueness:
;;; - pathname is a STRUCTURE-OBJECT, so users might call COPY-STRUCTURE.
;;; We can make that fail by inventing a subtype of instance that is not
;;; a STRUCTURE-OBJECT. Whatever that metatype is could be useful for
;;; PATTERN (parts of the pathname) as well as THREAD, MUTEX, HASH-TABLE
;;; and maybe some other things that yield strange semantics if copied.
;;; - the load form methods use MAKE-LOAD-FORM-SAVING-SLOTS thereby
;;; bypassing the interning operation. That seems totally fixable.
;;;
;;; Additionally, it would be nice if this table would act to reduce
;;; EQUAL to EQ on pathnames by ensuring that we never intern two distinct
;;; pathnames that are EQUAL.
;;; That would require performing some canonicalization immediately which may
;;; or may not pose a problem for fixing https://bugs.launchpad.net/sbcl/+bug/1834266
;;; which is to say, if hosts can actually be :UNSPECIFIC, then the version
;;; collapsing that is done here would not be done. I don't know if it's that simple.
;;; If it isn't that simple, then the answer is that hash function and comparator
;;; function used for the *PATHNAMES* table needs to be more fine-grained than
;;; the hash value that SXHASH returns for a pathname.
;;;
;;; The spec is actually extremely underspecified in regard to the meaning of
;;; "pathnames that are equal should be functionally equivalent."
;;; The simple test:
;;; (equal (make-pathname :name "a" :version nil) (make-pathname :name "a" :version :newest))
;;; shows that EQUAL is inconsistent in terms of what "functionally equivalent" means:
;;; SBCL, ABCL, and CCL => T
;;; CLISP and ECL => NIL
;;; Also, on case-sensitive-case-preserving filesystems it's not possible
;;; to know which pathnames are equivalent without asking the filesystem.
;;;
;;; This table uses %MAKE-HASH-TABLE, not MAKE-HASH-TABLE, because the latter
;;; always creates a synchronized table if :WEAKNESS is specified.
;;; But to correctly use the "put-if-absent" operation, the locking must occur
;;; *around* the get and put operations. It makes no sense to lock the table around
;;; individual operations, hence the unsynchronized table.
(define-load-time-global *pathnames*
(let ((h (%make-hash-table (logior (pack-ht-flags-weakness +ht-weak-value+)
(pack-ht-flags-kind 3)
hash-table-userfun-flag)
'pathname-key=
#'pathname-key=
#'pathname-key-hash
10
default-rehash-size
$1.0)))
(install-hash-table-lock h)
h))
;;; A pathname is logical if the host component is a logical host.
;;; This constructor is used to make an instance of the correct type
;;; from parsed arguments.
(defun intern-pathname (host device directory name type version)
;; We canonicalize logical pathname components to uppercase. ANSI
;; doesn't strictly require this, leaving it up to the implementor;
;; but the arguments given in the X3J13 cleanup issue
;; PATHNAME-LOGICAL:ADD seem compelling: we should canonicalize the
;; case, and uppercase is the ordinary way to do that.
(flet ((upcase-maybe (x) (typecase x (string (logical-word-or-lose x)) (t x))))
(when (typep host 'logical-host)
(setq device :unspecific
directory (mapcar #'upcase-maybe directory)
name (upcase-maybe name)
type (upcase-maybe type))))
(let ((table *pathnames*))
(declare (inline !allocate-pathname)) ; for DXability
(with-system-mutex ((hash-table-%lock table))
(let* ((dir+hash (when directory
(ensure-gethash
directory table
(cons directory (pathname-key-hash directory)))))
(key (!allocate-pathname host device dir+hash name type version)))
(declare (truly-dynamic-extent key))
(or (gethash key table)
(let ((key (!allocate-pathname host device dir+hash name type version)))
(when (typep host 'logical-host)
(setf (%instance-wrapper key) #.(find-layout 'logical-pathname)))
(setf (gethash key table) key)))))))
;;; Vector of logical host objects, each of which contains its translations.
;;; The vector is never mutated- always a new vector is created when adding
;;; translations for a new host. So nothing needs locking.
;;; And the fact that hosts are never deleted keeps things really simple.
(define-load-time-global *logical-hosts* #())
(declaim (simple-vector *logical-hosts*))
;;;; patterns
(defmethod print-object ((pattern pattern) stream)
(print-unreadable-object (pattern stream :type t)
(if *print-pretty*
(let ((*print-escape* t))
(pprint-fill stream (pattern-pieces pattern) nil))
(prin1 (pattern-pieces pattern) stream))))
(defun pattern= (pattern1 pattern2)
(declare (type pattern pattern1 pattern2))
(let ((pieces1 (pattern-pieces pattern1))
(pieces2 (pattern-pieces pattern2)))
(and (= (length pieces1) (length pieces2))
(every (lambda (piece1 piece2)
(typecase piece1
(simple-string
(and (simple-string-p piece2)
(string= piece1 piece2)))
(cons
(and (consp piece2)
(eq (car piece1) (car piece2))
(string= (cdr piece1) (cdr piece2))))
(t
(eq piece1 piece2))))
pieces1
pieces2))))
;;; If the string matches the pattern returns the multiple values T
;;; and a list of the matched strings.
(defun pattern-matches (pattern string)
(declare (type pattern pattern)
(type simple-string string))
(let ((len (length string)))
(labels ((maybe-prepend (subs cur-sub chars)
(if cur-sub
(let* ((len (length chars))
(new (make-string len))
(index len))
(dolist (char chars)
(setf (schar new (decf index)) char))
(cons new subs))
subs))
(matches (pieces start subs cur-sub chars)
(if (null pieces)
(if (= start len)
(values t (maybe-prepend subs cur-sub chars))
(values nil nil))
(let ((piece (car pieces)))
(etypecase piece
(simple-string
(let ((end (+ start (length piece))))
(and (<= end len)
(string= piece string
:start2 start :end2 end)
(matches (cdr pieces) end
(maybe-prepend subs cur-sub chars)
nil nil))))
(list
(ecase (car piece)
(:character-set
(and (< start len)
(let ((char (schar string start)))
(if (find char (cdr piece) :test #'char=)
(matches (cdr pieces) (1+ start) subs t
(cons char chars))))))))
((member :single-char-wild)
(and (< start len)
(matches (cdr pieces) (1+ start) subs t
(cons (schar string start) chars))))
((member :multi-char-wild)
(multiple-value-bind (won new-subs)
(matches (cdr pieces) start subs t chars)
(if won
(values t new-subs)
(and (< start len)
(matches pieces (1+ start) subs t
(cons (schar string start)
chars)))))))))))
(multiple-value-bind (won subs)
(matches (pattern-pieces pattern) 0 nil nil nil)
(values won (reverse subs))))))
;;; PATHNAME-MATCH-P for directory components
(defun directory-components-match (thing wild)
(or (eq thing wild)
(eq wild :wild)
;; If THING has a null directory, assume that it matches
;; (:ABSOLUTE :WILD-INFERIORS) or (:RELATIVE :WILD-INFERIORS).
(and (consp wild)
(null thing)
(member (first wild) '(:absolute :relative))
(eq (second wild) :wild-inferiors))
(and (consp wild)
(let ((wild1 (first wild)))
(if (eq wild1 :wild-inferiors)
(let ((wild-subdirs (rest wild)))
(or (null wild-subdirs)
(loop
(when (directory-components-match thing wild-subdirs)
(return t))
(pop thing)
(unless thing (return nil)))))
(and (consp thing)
(components-match (first thing) wild1)
(directory-components-match (rest thing)
(rest wild))))))))
;;; Return true if pathname component THING is matched by WILD. (not
;;; commutative)
(defun components-match (thing wild)
(declare (type (or pattern symbol simple-string integer) thing wild))
(or (eq thing wild)
(eq wild :wild)
(typecase thing
(simple-string
;; String is matched by itself, a matching pattern or :WILD.
(typecase wild
(pattern
(values (pattern-matches wild thing)))
(simple-string
(string= thing wild))))
(pattern
;; A pattern is only matched by an identical pattern.
(and (pattern-p wild) (pattern= thing wild)))
(integer
;; An integer (version number) is matched by :WILD or the
;; same integer. This branch will actually always be NIL as
;; long as the version is a fixnum.
(eql thing wild)))))
;;; a predicate for comparing two pathname slot component sub-entries
(defun compare-component (this that)
(or (eql this that)
(typecase this
(simple-string
(and (simple-string-p that)
(string= this that)))
(pattern
;; PATTERN instances should probably become interned objects
;; so that we can use EQ on them. But that currently has the same
;; problem as PATHAME= has - the cache can be bypassed.
(and (pattern-p that)
(pattern= this that)))
(cons
(and (consp that)
(compare-component (car this) (car that))
(compare-component (cdr this) (cdr that)))))))
;;;; pathname functions
(macrolet ((compare-most-components ()
`(and (eq (%pathname-host a) (%pathname-host b)) ; Interned
;; Unless the pathname cache can be made 100% reliable,
;; strength-reducing EQUAL to EQ is inadmissible here.
;; To fix that, MAKE-LOAD-FORM methods need not to bypass
;; INTERN-PATHNAME.
(let ((dir-a (%pathname-dir+hash a))
(dir-b (%pathname-dir+hash b)))
(or (eq dir-a dir-b)
(compare-component (car dir-a) (car dir-b))))
(compare-component (%pathname-device a) (%pathname-device b))
(compare-component (%pathname-name a) (%pathname-name b))
(compare-component (%pathname-type a) (%pathname-type b)))))
;;; PATHNAME-KEY= can receive two different subsets of keys:
;;; - non-nil LIST is the directory part of a pathname
;;; - entire PATHNAME
(defun pathname-key= (a b)
(etypecase a
(list (and (listp b) (compare-component a b)))
(pathname (and (pathnamep b)
(compare-most-components)
(eql (pathname-version a) (pathname-version b))))))
(defun pathname= (a b)
(declare (type pathname a b))
(or (eq a b)
(and (compare-most-components)
(or (eq (%pathname-host a) *physical-host*)
(compare-component (pathname-version a)
(pathname-version b)))))))
(sb-kernel::assign-equalp-impl 'pathname #'pathname=)
(sb-kernel::assign-equalp-impl 'logical-pathname #'pathname=)
;;; A pathname key is a key to an entry in *PATHNAMES*, either a pathname
;;; or a pathname-directory.
(defun pathname-key-hash (x)
(flet ((hash-piece (piece)
(etypecase piece
(string (sxhash piece)) ; transformed
(symbol (sxhash piece)) ; transformed
(pattern (pattern-hash piece))
((cons (eql :home) (cons string null))
(sxhash (second piece))))))
(etypecase x
(pathname
(let* ((host (%pathname-host x))
;; NAME-HASH is based on SXHASH of a string
(hash (if (typep host 'logical-host) (logical-host-name-hash host) 0)))
(mixf hash (hash-piece (%pathname-device x))) ; surely stringlike, right?
(awhen (%pathname-dir+hash x) (mixf hash (cdr it)))
(mixf hash (hash-piece (%pathname-name x)))
(mixf hash (hash-piece (%pathname-type x)))
;; EQUAL might ignore the version, and it doesn't provide many bits
;; of randomness, so don't bother with it.
hash))
(list ;; a directory
(let ((hash 0))
(dolist (piece x hash)
(mixf hash (hash-piece piece))))))))
;;; Convert PATHNAME-DESIGNATOR (a pathname, or string, or
;;; stream), into a pathname in PATHNAME.
(defmacro with-pathname ((pathname pathname-designator) &body body)
(once-only ((pathname-designator pathname-designator))
`(let ((,pathname (etypecase ,pathname-designator
(pathname ,pathname-designator)
(string (parse-namestring ,pathname-designator))
((or file-stream synonym-stream)
(stream-file-name-or-lose ,pathname-designator)))))
,@body)))
(defmacro with-native-pathname ((pathname pathname-designator) &body body)
(once-only ((pathname-designator pathname-designator))
`(let ((,pathname (etypecase ,pathname-designator
(pathname ,pathname-designator)
(string (parse-native-namestring ,pathname-designator))
;; FIXME
#+nil
(file-stream (file-name ,pathname-designator)))))
,@body)))
(defmacro with-host ((host host-designator) &body body)
;; Generally, redundant specification of information in software,
;; whether in code or in comments, is bad. However, the ANSI spec
;; for this is messy enough that it's hard to hold in short-term
;; memory, so I've recorded these redundant notes on the
;; implications of the ANSI spec.
;;
;; According to the ANSI spec, HOST can be a valid pathname host, or
;; a logical host, or NIL.
;;
;; A valid pathname host can be a valid physical pathname host or a
;; valid logical pathname host.
;;
;; A valid physical pathname host is "any of a string, a list of
;; strings, or the symbol :UNSPECIFIC, that is recognized by the
;; implementation as the name of a host". In SBCL as of 0.6.9.8,
;; that means :UNSPECIFIC: though someday we might want to
;; generalize it to allow strings like "RTFM.MIT.EDU" or lists like
;; '("RTFM" "MIT" "EDU"), that's not supported now.
;;
;; A valid logical pathname host is a string which has been defined as
;; the name of a logical host, as with LOAD-LOGICAL-PATHNAME-TRANSLATIONS.
;;
;; A logical host is an object of implementation-dependent nature. In
;; SBCL, it's a member of the HOST class (a subclass of STRUCTURE-OBJECT).
(once-only ((host-designator host-designator))
`(let ((,host (etypecase ,host-designator
((string 0)
;; This is a special host. It's not valid as a
;; logical host, so it is a sensible thing to
;; designate the physical host object. So we do
;; that.
*physical-host*)
(string
;; In general ANSI-compliant Common Lisps, a
;; string might also be a physical pathname
;; host, but ANSI leaves this up to the
;; implementor, and in SBCL we don't do it, so
;; it must be a logical host.
(find-logical-host ,host-designator))
(absent-pathname-component
;; CLHS says that HOST=:UNSPECIFIC has
;; implementation-defined behavior. We
;; just turn it into NIL.
nil)
(list
;; ANSI also allows LISTs to designate hosts,
;; but leaves its interpretation
;; implementation-defined. Our interpretation
;; is that it's unsupported.:-|
(error "A LIST representing a pathname host is not ~
supported in this implementation:~% ~S"
,host-designator))
(host ,host-designator))))
,@body)))
(defun find-host (host-designator &optional (errorp t))
(with-host (host host-designator)
(when (and errorp (not host))
(error "Couldn't find host: ~S" host-designator))
host))
(defun pathname (pathspec)
"Convert PATHSPEC (a pathname designator) into a pathname."
(declare (type pathname-designator pathspec))
(with-pathname (pathname pathspec)
pathname))
(defun native-pathname (pathspec)
"Convert PATHSPEC (a pathname designator) into a pathname, assuming
the operating system native pathname conventions."
(with-native-pathname (pathname pathspec)
pathname))
;;; Recursively (e.g. for the directory component) change the case of
;;; the pathname component THING.
(declaim (type (sfunction ((or symbol integer string pattern list))
(or symbol integer string pattern list))
diddle-case))
(defun diddle-case (thing)
(labels ((check-for (pred in)
(typecase in
(pattern
(some (lambda (piece)
(typecase piece
(simple-string
(check-for pred piece))
((cons (eql :character-set))
(check-for pred (cdr piece)))))
(pattern-pieces in)))
(simple-string
(some pred in))))
(diddle-with (fun thing)
(typecase thing
(pattern
(make-pattern
(mapcar (lambda (piece)
(typecase piece
(simple-string
(funcall fun piece))
((cons (eql :character-set))
(funcall fun (cdr piece)))
(t
piece)))
(pattern-pieces thing))))
(simple-string
(funcall fun thing))
(t
thing)))
(maybe-diddle-part (thing)
(if (listp thing)
(mapcar #'maybe-diddle-part thing)
(let ((any-uppers (check-for #'upper-case-p thing))
(any-lowers (check-for #'lower-case-p thing)))
(cond ((and any-uppers any-lowers) ; mixed case, stays the same
thing)
(any-uppers ; all uppercase, becomes all lower case
(diddle-with 'string-downcase thing))
(any-lowers ; all lowercase, becomes all upper case
(diddle-with 'string-upcase thing))
(t ; no letters? I guess just leave it.
thing))))))
(if (not (or (symbolp thing) (integerp thing)))
(maybe-diddle-part thing)
thing)))
(declaim (inline maybe-diddle-case))
(defun maybe-diddle-case (thing diddle-p)
(if diddle-p
(diddle-case thing)
thing))
(defun merge-directories (dir1 dir2 diddle-case)
(if (or (eq (car dir1) :absolute)
(null dir2))
dir1
(let ((results nil))
(flet ((add (dir)
(if (and (eq dir :back)
results
(typep (car results) '(or string pattern
(member :wild :wild-inferiors))))
(pop results)
(push dir results))))
(dolist (dir (maybe-diddle-case dir2 diddle-case))
(add dir))
(dolist (dir (cdr dir1))
(add dir)))
(reverse results))))
(defun merge-pathnames (pathname
&optional
(defaults *default-pathname-defaults*)
(default-version :newest))
"Construct a filled in pathname by completing the unspecified components
from the defaults."
(declare (type pathname-designator pathname)
(type pathname-designator defaults)
(values pathname))
(with-pathname (defaults defaults)
(let* ((pathname (let ((*default-pathname-defaults* defaults))
(pathname pathname)))
(default-host (%pathname-host defaults))
(pathname-host (%pathname-host pathname))
(diddle-case
(and default-host pathname-host
(not (eq (host-customary-case default-host)
(host-customary-case pathname-host)))))
(directory (merge-directories (%pathname-directory pathname)
(%pathname-directory defaults)
diddle-case)))
(macrolet ((merged-component (component)
`(or (,component pathname)
(let ((default (,component defaults)))
(if diddle-case
(diddle-case default)
default)))))
(intern-pathname
(or pathname-host default-host)
;; The device of ~/ shouldn't be merged, because the
;; expansion may have a different device
(unless (typep directory '(cons (eql :absolute) (cons (eql :home))))
(merged-component %pathname-device))
directory
(merged-component %pathname-name)
(merged-component %pathname-type)
(or (%pathname-version pathname)
(and (not (%pathname-name pathname)) (%pathname-version defaults))
default-version))))))
(defun import-directory (directory diddle-case)
(etypecase directory
(null nil)
((member :wild) '(:absolute :wild-inferiors))
((member :unspecific) '(:relative))
(list
(let ((root (pop directory))
results)
(if (member root '(:relative :absolute))
(push root results)
(error "List of directory components must start with ~S or ~S."
:absolute :relative))
(when directory
(let ((next (car directory)))
(when (or (eq :home next)
(typep next '(cons (eql :home) (cons string null))))
(push (pop directory) results)))
(dolist (piece directory)
(typecase piece
((member :wild :wild-inferiors :up)
(push piece results))
((member :back)
(if (typep (car results) '(or string pattern
(member :wild :wild-inferiors)))
(pop results)
(push piece results)))
((or string pattern)
(when (typep piece '(and string (not simple-array)))
(setq piece (coerce piece 'simple-string)))
;; Unix namestrings allow embedded "//" within them. Consecutive
;; slashes are treated as one, which is weird but often convenient.
;; However, preserving empty directory components:
;; - is unaesthetic
;; - makes (NAMESTRING (MAKE-PATHNAME :DIRECTORY '(:RELATIVE "" "d")))
;; visually indistinguishable from the absolute pathname "/d/"
;; - can causes a pathname equality test to return NIL
;; on semantically equivalent pathnames. This can happen for
;; other reasons, but fewer false negatives is better.
(unless (and (stringp piece) (zerop (length piece)))
(push (maybe-diddle-case piece diddle-case) results)))
(t
(error "~S is not allowed as a directory component." piece)))))
(nreverse results)))
(string
(cond ((zerop (length directory)) `(:absolute))
(t
(when (typep directory '(not simple-array))
(setq directory (coerce directory 'simple-string)))
`(:absolute ,(maybe-diddle-case directory diddle-case)))))))
(defun make-pathname (&key host
(device nil devp)
(directory nil dirp)
(name nil namep)
(type nil typep)
(version nil versionp)
defaults
(case :local))
"Makes a new pathname from the component arguments. Note that host is
a host-structure or string."
(declare (type (or string host pathname-component-tokens) host)
(type (or string pathname-component-tokens) device)
(type (or list string pattern pathname-component-tokens) directory)
(type (or string pattern pathname-component-tokens) name type)
(type (or integer pathname-component-tokens (member :newest))
version)
(type (or pathname-designator null) defaults)
(type pathname-component-case case))
(let* ((defaults (when defaults
(with-pathname (defaults defaults) defaults)))
(default-host (if defaults
(%pathname-host defaults)
(pathname-host *default-pathname-defaults*)))
;; Raymond Toy writes: CLHS says make-pathname can take a
;; string (as a logical-host) for the host part. We map that
;; string into the corresponding logical host structure.
;;
;; Paul Werkowski writes:
;; HyperSpec says for the arg to MAKE-PATHNAME;
;; "host---a valid physical pathname host. ..."
;; where it probably means -- a valid pathname host.
;; "valid pathname host n. a valid physical pathname host or
;; a valid logical pathname host."
;; and defines
;; "valid physical pathname host n. any of a string,
;; a list of strings, or the symbol :unspecific,
;; that is recognized by the implementation as the name of a host."
;; "valid logical pathname host n. a string that has been defined
;; as the name of a logical host. ..."
;; HS is silent on what happens if the :HOST arg is NOT one of these.
;; It seems an error message is appropriate.
(host (or (find-host host nil) default-host))
(diddle-args (and (eq (host-customary-case host) :lower)
(eq case :common)))
(diddle-defaults
(not (eq (host-customary-case host)
(host-customary-case default-host))))
(dir (import-directory directory diddle-args))
(ver (cond
(versionp version)
(defaults (%pathname-version defaults))
(t nil))))
(when (and defaults (not dirp))
(setf dir
(merge-directories dir
(%pathname-directory defaults)
diddle-defaults)))
(macrolet ((pick (var varp field)
`(cond ((or (simple-string-p ,var)
(pattern-p ,var))
(maybe-diddle-case ,var diddle-args))
((stringp ,var)
(maybe-diddle-case (coerce ,var 'simple-string)
diddle-args))
(,varp
(maybe-diddle-case ,var diddle-args))
(defaults
(maybe-diddle-case (,field defaults)
diddle-defaults))
(t
nil))))
(intern-pathname
host
(pick device devp %pathname-device) ; forced to :UNSPECIFIC when logical
dir
(pick name namep %pathname-name)
(pick type typep %pathname-type)
ver))))
(defun pathname-host (pathname &key (case :local))
"Return PATHNAME's host."
(declare (ignore case))
(with-pathname (pathname pathname)
(%pathname-host pathname)))
(macrolet ((frob (name component docstring)
`(defun ,name (pathname &key (case :local))
,docstring
(with-pathname (pathname pathname)
(let ((effective-case (and (eq case :common)
(eq (host-customary-case
(%pathname-host pathname))
:lower))))
(maybe-diddle-case (,component pathname) effective-case))))))
(frob pathname-device %pathname-device "Return PATHNAME's device.")
(frob pathname-directory %pathname-directory "Return PATHNAME's directory.")
(frob pathname-name %pathname-name "Return PATHNAME's name.")
(frob pathname-type %pathname-type "Return PATHNAME's type."))
(defun pathname-version (pathname)
"Return PATHNAME's version."
(with-pathname (pathname pathname)
(%pathname-version pathname)))
;;;; namestrings
;;; Handle the case for PARSE-NAMESTRING parsing a potentially
;;; syntactically valid logical namestring with an explicit host.
;;;
;;; This then isn't fully general -- we are relying on the fact that
;;; we will only pass to parse-namestring namestring with an explicit
;;; logical host, so that we can pass the host return from
;;; parse-logical-namestring through to %PARSE-NAMESTRING as a truth
;;; value. Yeah, this is probably a KLUDGE - CSR, 2002-04-18
(defun parseable-logical-namestring-p (namestr start end)
(catch 'exit
(handler-bind
((namestring-parse-error (lambda (c)
(declare (ignore c))
(throw 'exit nil))))
(let ((colon (position #\: namestr :start start :end end)))
(when colon
(let ((potential-host
(logical-word-or-lose (subseq namestr start colon))))
;; depending on the outcome of CSR comp.lang.lisp post
;; "can PARSE-NAMESTRING create logical hosts", we may need
;; to do things with potential-host (create it
;; temporarily, parse the namestring and unintern the
;; logical host potential-host on failure.
(declare (ignore potential-host))
(let ((result
(handler-bind
((simple-type-error (lambda (c)
(declare (ignore c))
(throw 'exit nil))))
(parse-logical-namestring namestr start end))))
;; if we got this far, we should have an explicit host
;; (first return value of parse-logical-namestring)
(aver result)
result)))))))
;;; Handle the case where PARSE-NAMESTRING is actually parsing a
;;; namestring. We pick off the :JUNK-ALLOWED case then find a host to
;;; use for parsing, call the parser, then check whether the host matches.
(defun %parse-namestring (namestr host defaults start end junk-allowed)
(declare (type (or host null) host)
(type string namestr)
(type index start)
(type (or index null) end))
(cond
(junk-allowed
(handler-case
(%parse-namestring namestr host defaults start end nil)
(namestring-parse-error (condition)
(values nil (namestring-parse-error-offset condition)))))
(t
(let ((end (%check-vector-sequence-bounds namestr start end)))
(multiple-value-bind (new-host device directory file type version)
;; Comments below are quotes from the HyperSpec
;; PARSE-NAMESTRING entry, reproduced here to demonstrate
;; that we actually have to do things this way rather than
;; some possibly more logical way. - CSR, 2002-04-18
(cond
;; "If host is a logical host then thing is parsed as a
;; logical pathname namestring on the host."
(host (funcall (host-parse host) namestr start end))
;; "If host is nil and thing is a syntactically valid
;; logical pathname namestring containing an explicit
;; host, then it is parsed as a logical pathname
;; namestring."
((parseable-logical-namestring-p namestr start end)
(parse-logical-namestring namestr start end))
;; "If host is nil, default-pathname is a logical
;; pathname, and thing is a syntactically valid logical
;; pathname namestring without an explicit host, then it
;; is parsed as a logical pathname namestring on the
;; host that is the host component of default-pathname."
;;
;; "Otherwise, the parsing of thing is
;; implementation-defined."
;;
;; Both clauses are handled here, as the default
;; *DEFAULT-PATHNAME-DEFAULTS* has a SB-IMPL::UNIX-HOST
;; for a host.
((pathname-host defaults)
(funcall (host-parse (pathname-host defaults))
namestr
start
end))
;; I don't think we should ever get here, as the default
;; host will always have a non-null HOST, given that we
;; can't create a new pathname without going through
;; *DEFAULT-PATHNAME-DEFAULTS*, which has a non-null
;; host...
(t (bug "Fallen through COND in %PARSE-NAMESTRING")))
(when (and host new-host (not (eq new-host host)))
(error 'simple-type-error
:datum new-host
;; Note: ANSI requires that this be a TYPE-ERROR,
;; but there seems to be no completely correct
;; value to use for TYPE-ERROR-EXPECTED-TYPE.
;; Instead, we return a sort of "type error allowed
;; type", trying to say "it would be OK if you
;; passed NIL as the host value" but not mentioning
;; that a matching string would be OK too.
:expected-type 'null
:format-control
"The host in the namestring, ~S,~@
does not match the explicit HOST argument, ~S."
:format-arguments (list new-host host)))
(let ((pn-host (or new-host host (pathname-host defaults))))
(values (intern-pathname pn-host device directory file type version)
end)))))))
(defun parse-namestring (thing
&optional
host
(defaults *default-pathname-defaults*)
&key (start 0) end junk-allowed)
(declare (ftype (function * (values (or null pathname) (or null index)))
%parse-namestring))
(with-host (found-host host)
(let (;; According to ANSI defaults may be any valid pathname designator
(defaults (etypecase defaults
(pathname
defaults)
(string
(aver (pathnamep *default-pathname-defaults*))
(parse-namestring defaults))
(stream
(truename defaults)))))
(declare (type pathname defaults))
(etypecase thing
(string
(with-array-data ((thing thing) (start start) (end end)
:check-fill-pointer t)
(multiple-value-bind (pathname position)
(%parse-namestring thing found-host defaults start end junk-allowed)
(values pathname (- position start)))))
(pathname
(let ((defaulted-host (or found-host (%pathname-host defaults))))
(declare (type host defaulted-host))
(unless (eq defaulted-host (%pathname-host thing))
(error "The HOST argument doesn't match the pathname host:~% ~
~S and ~S."
defaulted-host (%pathname-host thing))))
(values thing start))
((or file-stream synonym-stream)
(values (stream-file-name-or-lose thing) nil))))))
(defun %parse-native-namestring (namestr host defaults start end junk-allowed
as-directory)
(declare (type (or host null) host)
(type string namestr)
(type index start)
(type (or index null) end))
(cond
(junk-allowed
(handler-case
(%parse-native-namestring namestr host defaults start end nil as-directory)
(namestring-parse-error (condition)
(values nil (namestring-parse-error-offset condition)))))
(t
(let* ((end (%check-vector-sequence-bounds namestr start end)))
(multiple-value-bind (new-host device directory file type version)
(cond
(host
(funcall (host-parse-native host) namestr start end as-directory))
((pathname-host defaults)
(funcall (host-parse-native (pathname-host defaults))
namestr
start
end
as-directory))
;; I don't think we should ever get here, as the default
;; host will always have a non-null HOST, given that we
;; can't create a new pathname without going through
;; *DEFAULT-PATHNAME-DEFAULTS*, which has a non-null
;; host...
(t (bug "Fallen through COND in %PARSE-NAMESTRING")))
(when (and host new-host (not (eq new-host host)))
(error 'simple-type-error
:datum new-host
:expected-type `(or null (eql ,host))
:format-control
"The host in the namestring, ~S,~@
does not match the explicit HOST argument, ~S."
:format-arguments (list new-host host)))
(let ((pn-host (or new-host host (pathname-host defaults))))
(values (intern-pathname pn-host device directory file type version)
end)))))))
(defun parse-native-namestring (thing
&optional
host
(defaults *default-pathname-defaults*)
&key (start 0) end junk-allowed
as-directory)
"Convert THING into a pathname, using the native conventions
appropriate for the pathname host HOST, or if not specified the
host of DEFAULTS. If THING is a string, the parse is bounded by
START and END, and error behaviour is controlled by JUNK-ALLOWED,
as with PARSE-NAMESTRING. For file systems whose native
conventions allow directories to be indicated as files, if
AS-DIRECTORY is true, return a pathname denoting THING as a
directory."
(declare (type pathname-designator thing defaults)
(type (or list host string (member :unspecific)) host)
(type index start)
(type (or index null) end)
(type (or t null) junk-allowed)
(values (or null pathname) (or null index)))
(declare (ftype (function * (values (or null pathname) (or null index)))
%parse-native-namestring))
(with-host (found-host host)
(let ((defaults (etypecase defaults
(pathname
defaults)
(string
(aver (pathnamep *default-pathname-defaults*))
(parse-native-namestring defaults))
(stream
(truename defaults)))))
(declare (type pathname defaults))
(etypecase thing
(string
(with-array-data ((thing thing) (start start) (end end)
:check-fill-pointer t)
(multiple-value-bind (pathname position)
(%parse-native-namestring thing
found-host defaults start end junk-allowed
as-directory)
(values pathname (- position start)))))
(pathname
(let ((defaulted-host (or found-host (%pathname-host defaults))))
(declare (type host defaulted-host))
(unless (eq defaulted-host (%pathname-host thing))
(error "The HOST argument doesn't match the pathname host:~% ~
~S and ~S."
defaulted-host (%pathname-host thing))))
(values thing start))
((or file-stream synonym-stream)
(values (stream-file-name-or-lose thing) nil))))))
(defun native-namestring (pathname &key as-file)
"Construct the full native (name)string form of PATHNAME. For
file systems whose native conventions allow directories to be
indicated as files, if AS-FILE is true and the name, type, and
version components of PATHNAME are all NIL or :UNSPECIFIC,
construct a string that names the directory according to the file
system's syntax for files."
(declare (type pathname-designator pathname))
(with-native-pathname (pathname pathname)
(when pathname
(let ((host (or (%pathname-host pathname)
(no-native-namestring-error
pathname "there is no ~S component." :host))))
(funcall (host-unparse-native host) pathname as-file)))))
(flet ((pathname-host-or-no-namestring (pathname)
(or (%pathname-host pathname)
(no-namestring-error
pathname "there is no ~S component." :host))))
(defun namestring (pathname)
"Construct the full (name)string form PATHNAME."
(with-pathname (pathname pathname)
(when pathname
(or (%pathname-namestring pathname)
(let ((host (pathname-host-or-no-namestring pathname)))
(setf (%pathname-namestring pathname)
(logically-readonlyize
(possibly-base-stringize
(funcall (host-unparse host) pathname)))))))))
(defun host-namestring (pathname)
"Return a string representation of the name of the host in PATHNAME."
(with-pathname (pathname pathname)
(let ((host (pathname-host-or-no-namestring pathname)))
(funcall (host-unparse-host host) pathname))))
(defun directory-namestring (pathname)
"Return a string representation of the directory in PATHNAME."
(with-pathname (pathname pathname)
(let ((host (pathname-host-or-no-namestring pathname)))
(funcall (host-unparse-directory host) pathname))))
(defun file-namestring (pathname)
"Return a string representation of the name in PATHNAME."
(with-pathname (pathname pathname)
(let ((host (pathname-host-or-no-namestring pathname)))
(funcall (host-unparse-file host) pathname))))
(defun enough-namestring (pathname
&optional
(defaults *default-pathname-defaults*))
"Return an abbreviated pathname sufficient to identify PATHNAME
relative to DEFAULTS."
(with-pathname (pathname pathname)
(let ((host (pathname-host-or-no-namestring pathname)))
(with-pathname (defaults defaults)
(funcall (host-unparse-enough host) pathname defaults))))))
;;;; wild pathnames
(defun wild-pathname-p (pathname &optional field-key)
"Predicate for determining whether pathname contains any wildcards."
(declare (type pathname-designator pathname)
(type (member nil :host :device :directory :name :type :version)
field-key))
(with-pathname (pathname pathname)
(flet ((frob (x)
(or (pattern-p x) (member x '(:wild :wild-inferiors)))))
(ecase field-key
((nil)
(or (wild-pathname-p pathname :host)
(wild-pathname-p pathname :device)
(wild-pathname-p pathname :directory)
(wild-pathname-p pathname :name)
(wild-pathname-p pathname :type)
(wild-pathname-p pathname :version)))
(:host (frob (%pathname-host pathname)))
(:device (frob (%pathname-host pathname)))
(:directory (some #'frob (%pathname-directory pathname)))
(:name (frob (%pathname-name pathname)))
(:type (frob (%pathname-type pathname)))
(:version (frob (%pathname-version pathname)))))))
(defun pathname-match-p (in-pathname in-wildname)
"Pathname matches the wildname template?"
(declare (type pathname-designator in-pathname))
(with-pathname (pathname in-pathname)
(with-pathname (wildname in-wildname)
(macrolet ((frob (field &optional (op 'components-match))
`(or (null (,field wildname))
(,op (,field pathname) (,field wildname)))))
(and (or (null (%pathname-host wildname))
(eq (%pathname-host wildname) (%pathname-host pathname)))
(frob %pathname-device)
(frob %pathname-directory directory-components-match)
(frob %pathname-name)
(frob %pathname-type)
(or (eq (%pathname-host wildname) *physical-host*)
(frob %pathname-version)))))))
;;; Place the substitutions into the pattern and return the string or pattern
;;; that results. If DIDDLE-CASE is true, we diddle the result case as well,
;;; in case we are translating between hosts with difference conventional case.
;;; The second value is the tail of subs with all of the values that we used up
;;; stripped off. Note that PATTERN-MATCHES matches all consecutive wildcards
;;; as a single string, so we ignore subsequent contiguous wildcards.
(defun substitute-into (pattern subs diddle-case)
(declare (type pattern pattern)
(type list subs)
(values (or simple-string pattern) list))
(let ((in-wildcard nil)
(pieces nil)
(strings nil))
(dolist (piece (pattern-pieces pattern))
(cond ((simple-string-p piece)
(push piece strings)
(setf in-wildcard nil))
(in-wildcard)
(t
(setf in-wildcard t)
(unless subs
(error "not enough wildcards in FROM pattern to match ~
TO pattern:~% ~S"
pattern))
(let ((sub (pop subs)))
(typecase sub
(pattern
(when strings
(push (apply #'concatenate 'simple-string
(nreverse strings))
pieces))
(dolist (piece (pattern-pieces sub))
(push piece pieces)))
(simple-string
(push sub strings))
(t
(error "can't substitute this into the middle of a word:~
~% ~S"
sub)))))))
(when strings
(push (apply #'concatenate 'simple-string (nreverse strings))
pieces))
(values
(maybe-diddle-case
(if (and pieces (simple-string-p (car pieces)) (null (cdr pieces)))
(car pieces)
(make-pattern (nreverse pieces)))
diddle-case)
subs)))
;;; Called when we can't see how source and from matched.
(defun didnt-match-error (source from)
(error "Pathname components from SOURCE and FROM args to TRANSLATE-PATHNAME~@
did not match:~% ~S ~S"
source from))
;;; Do TRANSLATE-COMPONENT for all components except host, directory
;;; and version.
(defun translate-component (source from to diddle-case)
(typecase to
(pattern
(typecase from
(pattern
(typecase source
(pattern
(if (pattern= from source)
source
(didnt-match-error source from)))
(simple-string
(multiple-value-bind (won subs) (pattern-matches from source)
(if won
(values (substitute-into to subs diddle-case))
(didnt-match-error source from))))
(t
(maybe-diddle-case source diddle-case))))
((member :wild)
(values (substitute-into to (list source) diddle-case)))
(t
(if (components-match source from)
(maybe-diddle-case source diddle-case)
(didnt-match-error source from)))))
((member nil :wild)
(maybe-diddle-case source diddle-case))
(t
(if (components-match source from)
to
(didnt-match-error source from)))))
;;; Return a list of all the things that we want to substitute into the TO
;;; pattern (the things matched by from on source.) When From contains
;;; :WILD-INFERIORS, the result contains a sublist of the matched source
;;; subdirectories.
(defun compute-directory-substitutions (orig-source orig-from)
(let ((source orig-source)
(from orig-from))
(collect ((subs))
(loop
(unless source
(unless (every (lambda (x) (eq x :wild-inferiors)) from)
(didnt-match-error orig-source orig-from))
(subs ())
(return))
(unless from (didnt-match-error orig-source orig-from))
(let ((from-part (pop from))
(source-part (pop source)))
(typecase from-part
(pattern
(typecase source-part
(pattern
(if (pattern= from-part source-part)
(subs source-part)
(didnt-match-error orig-source orig-from)))
(simple-string
(multiple-value-bind (won new-subs)
(pattern-matches from-part source-part)
(if won
(dolist (sub new-subs)
(subs sub))
(didnt-match-error orig-source orig-from))))
(t
(didnt-match-error orig-source orig-from))))
((member :wild)
(subs source-part))
((member :wild-inferiors)
(let ((remaining-source (cons source-part source)))
(collect ((res))
(loop
(when (directory-components-match remaining-source from)
(return))
(unless remaining-source
(didnt-match-error orig-source orig-from))
(res (pop remaining-source)))
(subs (res))
(setq source remaining-source))))
(simple-string
(unless (and (simple-string-p source-part)
(string= from-part source-part))
(didnt-match-error orig-source orig-from)))
(t
(didnt-match-error orig-source orig-from)))))
(subs))))
;;; This is called by TRANSLATE-PATHNAME on the directory components
;;; of its argument pathnames to produce the result directory
;;; component. If this leaves the directory NIL, we return the source
;;; directory. The :RELATIVE or :ABSOLUTE is taken from the source
;;; directory, except if TO is :ABSOLUTE, in which case the result
;;; will be :ABSOLUTE.
(defun translate-directories (source from to diddle-case)
(if (not (and source to from))
(or (and to (null source) (remove :wild-inferiors to))
(mapcar (lambda (x) (maybe-diddle-case x diddle-case)) source))
(collect ((res))
;; If TO is :ABSOLUTE, the result should still be :ABSOLUTE.
(res (if (eq (first to) :absolute)
:absolute
(first source)))
(let ((subs-left (compute-directory-substitutions (rest source)
(rest from))))
(dolist (to-part (rest to))
(typecase to-part
((member :wild)
(aver subs-left)
(let ((match (pop subs-left)))
(when (listp match)
(error ":WILD-INFERIORS is not paired in from and to ~
patterns:~% ~S ~S" from to))
(res (maybe-diddle-case match diddle-case))))
((member :wild-inferiors)
(aver subs-left)
(let ((match (pop subs-left)))
(unless (listp match)
(error ":WILD-INFERIORS not paired in from and to ~
patterns:~% ~S ~S" from to))
(dolist (x match)
(res (maybe-diddle-case x diddle-case)))))
(pattern
(multiple-value-bind
(new new-subs-left)
(substitute-into to-part subs-left diddle-case)
(setf subs-left new-subs-left)
(res new)))
(t (res to-part)))))
(res))))
(defun translate-pathname (source from-wildname to-wildname &key)
"Use the source pathname to translate the from-wildname's wild and
unspecified elements into a completed to-pathname based on the to-wildname."
(declare (type pathname-designator source from-wildname to-wildname))
(with-pathname (source source)
(with-pathname (from from-wildname)
(with-pathname (to to-wildname)
(let* ((source-host (%pathname-host source))
(from-host (%pathname-host from))
(to-host (%pathname-host to))
(diddle-case
(and source-host to-host
(not (eq (host-customary-case source-host)
(host-customary-case to-host))))))
(macrolet ((frob (field &optional (op 'translate-component))
`(let ((result (,op (,field source)
(,field from)
(,field to)
diddle-case)))
(if (eq result :error)
(error "~S doesn't match ~S." source from)
result))))
(intern-pathname
(or to-host source-host)
(frob %pathname-device)
(frob %pathname-directory translate-directories)
(frob %pathname-name)
(frob %pathname-type)
(if (eq from-host *physical-host*)
(if (or (eq (%pathname-version to) :wild)
(eq (%pathname-version to) nil))
(%pathname-version source)
(%pathname-version to))
(frob %pathname-version)))))))))
;;;; logical pathname support. ANSI 92-102 specification.
;;;;
;;;; As logical-pathname translations are loaded they are
;;;; canonicalized as patterns to enable rapid efficient translation
;;;; into physical pathnames.
;;;; utilities
;;; Access *DEFAULT-PATHNAME-DEFAULTS*, issuing a warning if its value
;;; is silly. (Unlike the vaguely-analogous SANE-PACKAGE, we don't
;;; actually need to reset the variable when it's silly, since even
;;; crazy values of *DEFAULT-PATHNAME-DEFAULTS* don't leave the system
;;; in a state where it's hard to recover interactively.)
(defun sane-default-pathname-defaults ()
(let* ((dfd *default-pathname-defaults*)
(dfd-dir (pathname-directory dfd)))
;; It's generally not good to use a relative pathname for
;; *DEFAULT-PATHNAME-DEFAULTS*, since relative pathnames
;; are defined by merging into a default pathname (which is,
;; by default, *DEFAULT-PATHNAME-DEFAULTS*).
(when (and (consp dfd-dir)
(eql (first dfd-dir) :relative))
(warn
"~@<~S is a relative pathname. (But we'll try using it anyway.)~@:>"
'*default-pathname-defaults*))
dfd))
(defun simplify-namestring (namestring &optional host)
(funcall (host-simplify-namestring
(or host
(pathname-host (sane-default-pathname-defaults))))
namestring))
;;; Canonicalize a logical pathname word by uppercasing it checking that it
;;; contains only legal characters.
(defun logical-word-or-lose (word)
(declare (string word))
(when (string= word "")
(error 'namestring-parse-error
:complaint "Attempted to treat invalid logical hostname ~
as a logical host:~% ~S"
:args (list word)
:namestring word :offset 0))
(let ((word (string-upcase word)))
(dotimes (i (length word))
(let ((ch (schar word i)))
(unless (and (typep ch 'standard-char)
(or (alpha-char-p ch) (digit-char-p ch) (char= ch #\-)))
(error 'namestring-parse-error
:complaint "logical namestring character which ~
is not alphanumeric or hyphen:~% ~S"
:args (list ch)
:namestring word :offset i))))
(coerce word 'string))) ; why not simple-string?
;;; Given a logical host or string, return a logical host. If ERROR-P
;;; is NIL, then return NIL when no such host exists.
(defun find-logical-host (thing &optional (errorp t))
(etypecase thing
(string
(let* ((name (logical-word-or-lose thing))
(hash (sxhash name))
;; Can do better here: binary search, since we maintain sorted order.
(found (dovector (x *logical-hosts*)
(when (and (eq (logical-host-name-hash x) hash)
(string= (logical-host-name x) name))
(return x)))))
(if (or found (not errorp))
found
;; This is the error signalled from e.g.
;; LOGICAL-PATHNAME-TRANSLATIONS when host is not a defined
;; host, and ANSI specifies that that's a TYPE-ERROR.
(error 'simple-type-error
:datum thing
;; God only knows what ANSI expects us to use for
;; the EXPECTED-TYPE here. Maybe this will be OK..
:expected-type
'(and string (satisfies logical-pathname-translations))
:format-control "logical host not yet defined: ~S"
:format-arguments (list thing)))))
(logical-host thing)))
;;; Given a logical host name or host, return a logical host, creating
;;; a new one if necessary.
(defun intern-logical-host (thing &aux name host)
(loop
(awhen (find-logical-host thing nil) (return it))
(unless name
(setq name (logical-word-or-lose thing)
host (make-logical-host :name name :name-hash (sxhash name))))
(let* ((old *logical-hosts*)
(new (merge 'vector old (list host) #'string< :key #'logical-host-name)))
(when (eq (cas *logical-hosts* old new) old)
(return host)))))
;;;; logical pathname parsing
;;; Deal with multi-char wildcards in a logical pathname token.
(defun maybe-make-logical-pattern (namestring chunks)
(let ((chunk (caar chunks)))
(collect ((pattern))
(let ((last-pos 0)
(len (length chunk)))
(declare (fixnum last-pos))
(loop
(when (= last-pos len) (return))
(let ((pos (or (position #\* chunk :start last-pos) len)))
(if (= pos last-pos)
(when (pattern)
(error 'namestring-parse-error
:complaint "double asterisk inside of logical ~
word: ~S"
:args (list chunk)
:namestring namestring
:offset (+ (cdar chunks) pos)))
(pattern (subseq chunk last-pos pos)))
(if (= pos len)
(return)
(pattern :multi-char-wild))
(setq last-pos (1+ pos)))))
(aver (pattern))
(if (cdr (pattern))
(make-pattern (pattern))
(let ((x (car (pattern))))
(if (eq x :multi-char-wild)
:wild
x))))))
;;; Return a list of conses where the CDR is the start position and
;;; the CAR is a string (token) or character (punctuation.)
(defun logical-chunkify (namestr start end)
(collect ((chunks))
(do ((i start (1+ i))
(prev start))
((= i end)
(when (> end prev)
(chunks (cons (nstring-upcase (subseq namestr prev end)) prev))))
(let ((ch (schar namestr i)))
(unless (or (alpha-char-p ch) (digit-char-p ch)
(member ch '(#\- #\*)))
(when (> i prev)
(chunks (cons (nstring-upcase (subseq namestr prev i)) prev)))
(setq prev (1+ i))
(unless (member ch '(#\; #\: #\.))
(error 'namestring-parse-error
:complaint "illegal character for logical pathname:~% ~S"
:args (list ch)
:namestring namestr
:offset i))
(chunks (cons ch i)))))
(chunks)))
;;; Break up a logical-namestring, always a string, into its
;;; constituent parts.
(defun parse-logical-namestring (namestr start end)
(declare (type simple-string namestr)
(type index start end))
(collect ((directory))
(let ((host nil)
(name nil)
(type nil)
(version nil))
(labels ((expecting (what chunks)
(unless (and chunks (simple-string-p (caar chunks)))
(error 'namestring-parse-error
:complaint "expecting ~A, got ~:[nothing~;~S~]."
:args (list what (caar chunks) (caar chunks))
:namestring namestr
:offset (if chunks (cdar chunks) end)))
(caar chunks))
(parse-host (chunks)
(case (caadr chunks)
(#\:
(setq host
(find-logical-host (expecting "a host name" chunks)))
(parse-relative (cddr chunks)))
(t
(parse-relative chunks))))
(parse-relative (chunks)
(case (caar chunks)
(#\;
(directory :relative)
(parse-directory (cdr chunks)))
(t
(directory :absolute) ; Assumption! Maybe revoked later.
(parse-directory chunks))))
(parse-directory (chunks)
(case (caadr chunks)
(#\;
(directory
(let ((res (expecting "a directory name" chunks)))
(cond ((string= res "..") :up)
((string= res "**") :wild-inferiors)
(t
(maybe-make-logical-pattern namestr chunks)))))
(parse-directory (cddr chunks)))
(t
(parse-name chunks))))
(parse-name (chunks)
(when chunks
(expecting "a file name" chunks)
(setq name (maybe-make-logical-pattern namestr chunks))
(expecting-dot (cdr chunks))))
(expecting-dot (chunks)
(when chunks
(unless (eql (caar chunks) #\.)
(error 'namestring-parse-error
:complaint "expecting a dot, got ~S."
:args (list (caar chunks))
:namestring namestr
:offset (cdar chunks)))
(if type
(parse-version (cdr chunks))
(parse-type (cdr chunks)))))
(parse-type (chunks)
(expecting "a file type" chunks)
(setq type (maybe-make-logical-pattern namestr chunks))
(expecting-dot (cdr chunks)))
(parse-version (chunks)
(let ((str (expecting "a positive integer, * or NEWEST"
chunks)))
(cond
((string= str "*") (setq version :wild))
((string= str "NEWEST") (setq version :newest))
(t
(multiple-value-bind (res pos)
(parse-integer str :junk-allowed t)
(unless (and res (plusp res))
(error 'namestring-parse-error
:complaint "expected a positive integer, ~
got ~S"
:args (list str)
:namestring namestr
:offset (+ pos (cdar chunks))))
(setq version res)))))
(when (cdr chunks)
(error 'namestring-parse-error
:complaint "extra stuff after end of file name"
:namestring namestr
:offset (cdadr chunks)))))
(parse-host (logical-chunkify namestr start end)))
(values host :unspecific (directory) name type version))))
(define-load-time-global *logical-pathname-defaults*
(intern-pathname (make-logical-host :name "") :unspecific nil nil nil nil))
(defun logical-namestring-p (x)
(and (stringp x)
(ignore-errors
(typep (pathname x) 'logical-pathname))))
(deftype logical-namestring ()
`(satisfies logical-namestring-p))
(defun logical-pathname (pathspec)
"Converts the pathspec argument to a logical-pathname and returns it."
(declare (type (or logical-pathname string stream) pathspec)
(values logical-pathname))
(if (typep pathspec 'logical-pathname)
pathspec
(flet ((oops (problem)
(error 'simple-type-error
:datum pathspec
:expected-type 'logical-namestring
:format-control "~S is not a valid logical namestring:~% ~A"
:format-arguments (list pathspec problem))))
(let ((res (handler-case
(parse-namestring pathspec nil *logical-pathname-defaults*)
(error (e) (oops e)))))
(when (eq (%pathname-host res)
(%pathname-host *logical-pathname-defaults*))
(oops "no host specified"))
res))))
;;;; logical pathname unparsing
(defun unparse-logical-directory (pathname)
(declare (type pathname pathname))
(collect ((pieces))
(let ((directory (%pathname-directory pathname)))
(when directory
(ecase (pop directory)
(:absolute) ; nothing special
(:relative (pieces ";")))
(dolist (dir directory)
(cond ((or (stringp dir) (pattern-p dir))
(pieces (unparse-logical-piece dir))
(pieces ";"))
((eq dir :wild)
(pieces "*;"))
((eq dir :wild-inferiors)
(pieces "**;"))
(t
(error "invalid directory component: ~S" dir))))))
(apply #'concatenate 'simple-string (pieces))))
(defun unparse-logical-piece (thing)
(etypecase thing
((member :wild) "*")
(simple-string thing)
(pattern
(collect ((strings))
(dolist (piece (pattern-pieces thing))
(etypecase piece
(simple-string (strings piece))
(keyword
(cond ((eq piece :wild-inferiors)
(strings "**"))
((eq piece :multi-char-wild)
(strings "*"))
(t (error "invalid keyword: ~S" piece))))))
(apply #'concatenate 'simple-string (strings))))))
(defun unparse-logical-file (pathname)
(declare (type pathname pathname))
(collect ((strings))
(let* ((name (%pathname-name pathname))
(type (%pathname-type pathname))
(version (%pathname-version pathname))
(type-supplied (pathname-component-present-p type))
(version-supplied (pathname-component-present-p version)))
(when name
(when (and (null type)
(typep name 'string)
(position #\. name :start 1))
(error "too many dots in the name: ~S" pathname))
(strings (unparse-logical-piece name)))
(when type-supplied
(unless name
(error "cannot specify the type without a file: ~S" pathname))
(when (typep type 'string)
(when (position #\. type)
(error "type component can't have a #\. inside: ~S" pathname)))
(strings ".")
(strings (unparse-logical-piece type)))
(when version-supplied
(unless type-supplied
(error "cannot specify the version without a type: ~S" pathname))
(etypecase version
((member :newest) (strings ".NEWEST")) ; really? not in LPNIFY-NAMESTRING
((member :wild) (strings ".*"))
(fixnum (strings ".") (strings (format nil "~D" version))))))
(apply #'concatenate 'simple-string (strings))))
;;; Unparse a logical pathname string.
(defun unparse-enough-namestring (pathname defaults)
(let* ((path-directory (pathname-directory pathname))
(def-directory (pathname-directory defaults))
(enough-directory
;; Go down the directory lists to see what matches. What's
;; left is what we want, more or less.
(cond ((and (eq (first path-directory) (first def-directory))
(eq (first path-directory) :absolute))
;; Both paths are :ABSOLUTE, so find where the
;; common parts end and return what's left
(do* ((p (rest path-directory) (rest p))
(d (rest def-directory) (rest d)))
((or (endp p) (endp d)
(not (equal (first p) (first d))))
`(:relative ,@p))))
(t
;; At least one path is :RELATIVE, so just return the
;; original path. If the original path is :RELATIVE,
;; then that's the right one. If PATH-DIRECTORY is
;; :ABSOLUTE, we want to return that except when
;; DEF-DIRECTORY is :ABSOLUTE, as handled above. so return
;; the original directory.
path-directory))))
(unparse-logical-namestring
(make-pathname :host (pathname-host pathname)
:directory enough-directory
:name (pathname-name pathname)
:type (pathname-type pathname)
:version (pathname-version pathname)))))
(defun unparse-logical-namestring (pathname)
(declare (type logical-pathname pathname))
(concatenate 'simple-string
(logical-host-name (%pathname-host pathname)) ":"
(unparse-logical-directory pathname)
(unparse-logical-file pathname)))
;;;; logical pathname translations
;;; Verify that the list of translations consists of lists and prepare
;;; canonical translations. (Parse pathnames and expand out wildcards
;;; into patterns.)
(defun canonicalize-logical-pathname-translations (translation-list host)
(declare (type list translation-list) (type host host)
(values list))
(mapcar (lambda (translation)
(destructuring-bind (from to) translation
(list (if (typep from 'logical-pathname)
from
(parse-namestring from host))
(pathname to))))
translation-list))
(defun logical-pathname-translations (host)
"Return the (logical) host object argument's list of translations."
(declare (type (or string logical-host) host)
(values list))
(logical-host-translations (find-logical-host host)))
(defun (setf logical-pathname-translations) (translations host)
"Set the translations list for the logical host argument."
(declare (type (or string logical-host) host)
(type list translations)
(values list))
(let ((host (intern-logical-host host)))
(setf (logical-host-canon-transls host)
(canonicalize-logical-pathname-translations translations host))
(setf (logical-host-translations host) translations)))
(defun translate-logical-pathname (pathname &key)
"Translate PATHNAME to a physical pathname, which is returned."
(declare (type pathname-designator pathname)
(values (or null pathname)))
(typecase pathname
(logical-pathname
(dolist (x (logical-host-canon-transls (%pathname-host pathname))
(error 'simple-file-error
:pathname pathname
:format-control "no translation for ~S"
:format-arguments (list pathname)))
(destructuring-bind (from to) x
(when (pathname-match-p pathname from)
(return (translate-logical-pathname
(translate-pathname pathname from to)))))))
(pathname pathname)
(t (translate-logical-pathname (pathname pathname)))))
;;; Given a pathname, return a corresponding physical pathname.
(defun physicalize-pathname (possibly-logical-pathname)
(if (typep possibly-logical-pathname 'logical-pathname)
(translate-logical-pathname possibly-logical-pathname)
possibly-logical-pathname))
(defun load-logical-pathname-translations (host)
"Reads logical pathname translations from SYS:SITE;HOST.TRANSLATIONS.NEWEST,
with HOST replaced by the supplied parameter. Returns T on success.
If HOST is already defined as logical pathname host, no file is loaded and NIL
is returned.
The file should contain a single form, suitable for use with
\(SETF LOGICAL-PATHNAME-TRANSLATIONS).
Note: behaviour of this function is highly implementation dependent, and
historically it used to be a no-op in SBCL -- the current approach is somewhat
experimental and subject to change."
(declare (type string host)
(values (member t nil)))
(if (find-logical-host host nil)
;; This host is already defined, all is well and good.
nil
;; ANSI: "The specific nature of the search is
;; implementation-defined."
(prog1 t
(setf (logical-pathname-translations host)
(with-open-file (lpt (make-pathname :host "SYS"
:directory '(:absolute "SITE")
:name host
:type "TRANSLATIONS"
:version :newest))
(read lpt))))))
(defun !pathname-cold-init ()
(let* ((sys *default-pathname-defaults*)
(src
(merge-pathnames
(make-pathname :directory '(:relative "src" :wild-inferiors)
:name :wild :type :wild)
sys))
(contrib
(merge-pathnames
(make-pathname :directory '(:relative "contrib" :wild-inferiors)
:name :wild :type :wild)
sys))
(output
(merge-pathnames
(make-pathname :directory '(:relative "output" :wild-inferiors)
:name :wild :type :wild)
sys)))
(setf (logical-pathname-translations "SYS")
`(("SYS:SRC;**;*.*.*" ,src)
("SYS:CONTRIB;**;*.*.*" ,contrib)
("SYS:OUTPUT;**;*.*.*" ,output)))))
(defun set-sbcl-source-location (pathname)
"Initialize the SYS logical host based on PATHNAME, which should be
the top-level directory of the SBCL sources. This will replace any
existing translations for \"SYS:SRC;\", \"SYS:CONTRIB;\", and
\"SYS:OUTPUT;\". Other \"SYS:\" translations are preserved."
(let ((truename (truename pathname))
(current-translations
(remove-if (lambda (translation)
(or (pathname-match-p "SYS:SRC;" translation)
(pathname-match-p "SYS:CONTRIB;" translation)
(pathname-match-p "SYS:OUTPUT;" translation)))
(logical-pathname-translations "SYS")
:key #'first)))
(flet ((physical-target (component)
(merge-pathnames
(make-pathname :directory (list :relative component
:wild-inferiors)
:name :wild
:type :wild)
truename)))
(setf (logical-pathname-translations "SYS")
`(("SYS:SRC;**;*.*.*" ,(physical-target "src"))
("SYS:CONTRIB;**;*.*.*" ,(physical-target "contrib"))
("SYS:OUTPUT;**;*.*.*" ,(physical-target "output"))
,@current-translations)))))
(defmethod make-load-form ((pn pathname) &optional env)
(declare (ignore env))
(labels ((reconstruct (component)
(cond ((pattern-p component) (patternify component))
((and (listp component) (some #'pattern-p component))
(cons 'list (mapcar #'patternify component)))
(t `',component)))
(patternify (subcomponent)
(if (pattern-p subcomponent)
`(make-pattern ',(pattern-pieces subcomponent))
`',subcomponent)))
(values `(intern-pathname
,(if (typep pn 'logical-pathname)
`(find-logical-host ',(logical-host-name (%pathname-host pn)))
'*physical-host*)
,(reconstruct (%pathname-device pn))
,(reconstruct (%pathname-directory pn))
,(reconstruct (%pathname-name pn))
,(reconstruct (%pathname-type pn))
,(reconstruct (%pathname-version pn))))))