#!-sb-fluid (declaim (freeze-type logical-pathname logical-host))
\f
-;;; host methods
-
-(def!method print-object ((host host) stream)
- (print-unreadable-object (host stream :type t :identity t)))
+;;;; UNIX-HOST stuff
+
+(def!struct (unix-host
+ (:make-load-form-fun make-unix-host-load-form)
+ (:include host
+ (parse #'parse-unix-namestring)
+ (unparse #'unparse-unix-namestring)
+ (unparse-host #'unparse-unix-host)
+ (unparse-directory #'unparse-unix-directory)
+ (unparse-file #'unparse-unix-file)
+ (unparse-enough #'unparse-unix-enough)
+ (customary-case :lower))))
+
+(defvar *unix-host* (make-unix-host))
+
+(defun make-unix-host-load-form (host)
+ (declare (ignore host))
+ '*unix-host*)
+
+;;; 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 ()
+ (%make-pathname *unix-host* nil nil nil nil :newest))
\f
;;; pathname methods
(error nil))))
(if namestring
(format stream "#P~S" namestring)
- ;; FIXME: This code was rewritten and should be tested. (How does
- ;; control get to this case anyhow? Perhaps we could just punt it?)
(print-unreadable-object (pathname stream :type t)
(format stream
- "(with no namestring) :HOST ~S :DEVICE ~S :DIRECTORY ~S ~
- :NAME ~S :TYPE ~S :VERSION ~S"
+ "~@<(with no namestring) ~_:HOST ~S ~_:DEVICE ~S ~_:DIRECTORY ~S ~
+ ~_:NAME ~S ~_:TYPE ~S ~_:VERSION ~S~:>"
(%pathname-host pathname)
(%pathname-device pathname)
(%pathname-directory pathname)
(def!method make-load-form ((pathname pathname) &optional environment)
(make-load-form-saving-slots pathname :environment environment))
-
-;;; The potential conflict with search lists requires isolating the
-;;; printed representation to use the i/o macro #.(logical-pathname
-;;; <path-designator>).
-;;;
-;;; FIXME: We don't use search lists any more, so that comment is
-;;; stale, right?
-(def!method print-object ((pathname logical-pathname) stream)
- (let ((namestring (handler-case (namestring pathname)
- (error nil))))
- (if namestring
- (format stream "#.(CL:LOGICAL-PATHNAME ~S)" namestring)
- (print-unreadable-object (pathname stream :type t)
- (format
- stream
- "~_:HOST ~S ~_:DIRECTORY ~S ~_:FILE ~S ~_:NAME ~S ~_:VERSION ~S"
- (%pathname-host pathname)
- (%pathname-directory pathname)
- (%pathname-name pathname)
- (%pathname-type pathname)
- (%pathname-version pathname))))))
\f
;;; A pathname is logical if the host component is a logical host.
;;; This constructor is used to make an instance of the correct type
(upcase-maybe name)
(upcase-maybe type)
version)
- (%make-pathname host device directory name type version))))
+ (progn
+ (aver (eq host *unix-host*))
+ (%make-pathname host device directory name type version)))))
;;; Hash table searching maps a logical pathname's host to its
;;; physical pathname translation.
(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))))
+ (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.
+;;; 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))
(%pathname-name pathname2))
(compare-component (%pathname-type pathname1)
(%pathname-type pathname2))
- (compare-component (%pathname-version pathname1)
- (%pathname-version pathname2))))
+ (or (eq (%pathname-host pathname1) *unix-host*)
+ (compare-component (%pathname-version pathname1)
+ (%pathname-version pathname2)))))
;;; Convert PATHNAME-DESIGNATOR (a pathname, or string, or
;;; stream), into a pathname in pathname.
(,pathname (etypecase ,pd0
(pathname ,pd0)
(string (parse-namestring ,pd0))
- (stream (file-name ,pd0)))))
+ (file-stream (file-name ,pd0)))))
,@body)))
;;; Convert the var, a host or string name for a host, into a
(simple-string
(check-for pred piece))
(cons
- (case (car in)
+ (case (car piece)
(:character-set
- (check-for pred (cdr in))))))
+ (check-for pred (cdr piece))))))
(return t))))
(list
(dolist (x in)
(typecase thing
(pattern
(make-pattern
- (mapcar #'(lambda (piece)
- (typecase piece
- (simple-base-string
- (funcall fun piece))
- (cons
- (case (car piece)
- (:character-set
- (cons :character-set
- (funcall fun (cdr piece))))
- (t
- piece)))
- (t
- piece)))
+ (mapcar (lambda (piece)
+ (typecase piece
+ (simple-base-string
+ (funcall fun piece))
+ (cons
+ (case (car piece)
+ (:character-set
+ (cons :character-set
+ (funcall fun (cdr piece))))
+ (t
+ piece)))
+ (t
+ piece)))
(pattern-pieces thing))))
(list
(mapcar fun 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.
+ ;; mixed case, stays the same
thing)
(any-uppers
- ;; All uppercase, becomes all lower case.
- (diddle-with #'(lambda (x) (if (stringp x)
- (string-downcase x)
- x)) thing))
+ ;; all uppercase, becomes all lower case
+ (diddle-with (lambda (x) (if (stringp x)
+ (string-downcase x)
+ x)) thing))
(any-lowers
- ;; All lowercase, becomes all upper case.
- (diddle-with #'(lambda (x) (if (stringp x)
- (string-upcase x)
- x)) thing))
+ ;; all lowercase, becomes all upper case
+ (diddle-with (lambda (x) (if (stringp x)
+ (string-upcase x)
+ x)) thing))
(t
- ;; No letters? I guess just leave it.
+ ;; no letters? I guess just leave it.
thing))))
thing))
(flet ((add (dir)
(if (and (eq dir :back)
results
- (not (eq (car results) :back)))
+ (not (member (car results)
+ '(:back :wild-inferiors))))
(pop results)
(push dir results))))
(dolist (dir (maybe-diddle-case dir2 diddle-case))
(maybe-diddle-case (%pathname-type defaults)
diddle-case))
(or (%pathname-version pathname)
+ (and (not (%pathname-name pathname)) (%pathname-version defaults))
default-version))))))
(defun import-directory (directory diddle-case)
((member :unspecific) '(:relative))
(list
(collect ((results))
- (ecase (pop directory)
- (:absolute
- (results :absolute)
- (when (search-list-p (car directory))
- (results (pop directory))))
- (:relative
- (results :relative)))
+ (results (pop directory))
(dolist (piece directory)
(cond ((member piece '(:wild :wild-inferiors :up :back))
(results piece))
(default-host (if defaults
(%pathname-host defaults)
(pathname-host *default-pathname-defaults*)))
- ;; toy@rtp.ericsson.se: CLHS says make-pathname can take a
+ ;; 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.
;;
- ;; pw@snoopy.mv.com:
+ ;; 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.
;; It seems an error message is appropriate.
(host (typecase host
(host host) ; A valid host, use it.
+ ((string 0) *unix-host*) ; "" cannot be a logical host
(string (find-logical-host host t)) ; logical-host or lose.
(t default-host))) ; unix-host
(diddle-args (and (eq (host-customary-case host) :lower)
\f
;;;; 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.
(type string namestr)
(type index start)
(type (or index null) end))
- (if junk-allowed
- (handler-case
- (%parse-namestring namestr host defaults start end nil)
- (namestring-parse-error (condition)
- (values nil (namestring-parse-error-offset condition))))
- (let* ((end (or end (length namestr)))
- (parse-host (or host
- (extract-logical-host-prefix namestr start end)
- (pathname-host defaults))))
- (unless parse-host
- (error "When no HOST argument is supplied, the DEFAULTS argument ~
- must have a non-null PATHNAME-HOST."))
-
- (multiple-value-bind (new-host device directory file type version)
- (funcall (host-parse parse-host) namestr start end)
- (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 parse-host)))
- (values (%make-maybe-logical-pathname
- pn-host device directory file type version)
- 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 (%make-maybe-logical-pathname
+ pn-host device directory file type version)
+ end)))))))
;;; If NAMESTR begins with a colon-terminated, defined, logical host,
;;; then return that host, otherwise return NIL.
host
(defaults *default-pathname-defaults*)
&key (start 0) end junk-allowed)
- (declare (type pathname-designator thing)
+ (declare (type pathname-designator thing defaults)
(type (or list host string (member :unspecific)) host)
- (type pathname defaults)
(type index start)
(type (or index null) end)
(type (or t null) junk-allowed)
;; 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).
(let ((found-host (etypecase host
+ ((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 Unix host object. So
+ ;; we do that.
+ *unix-host*)
(string
;; In general ANSI-compliant Common Lisps, a
;; string might also be a physical pathname host,
supported in this implementation:~% ~S"
host))
(host
- host))))
- (declare (type (or null host) found-host))
+ host)))
+ ;; 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 (or null host) found-host)
+ (type pathname defaults))
(etypecase thing
(simple-string
(%parse-namestring thing found-host defaults start end junk-allowed))
(defun namestring (pathname)
#!+sb-doc
"Construct the full (name)string form of the pathname."
- (declare (type pathname-designator pathname)
- (values (or null simple-base-string)))
+ (declare (type pathname-designator pathname))
(with-pathname (pathname pathname)
(when pathname
(let ((host (%pathname-host pathname)))
(unless host
(error "can't determine the namestring for pathnames with no ~
- host:~% ~S" pathname))
+ host:~% ~S" pathname))
(funcall (host-unparse host) pathname)))))
(defun host-namestring (pathname)
#!+sb-doc
- "Returns a string representation of the name of the host in the pathname."
- (declare (type pathname-designator pathname)
- (values (or null simple-base-string)))
+ "Return a string representation of the name of the host in the pathname."
+ (declare (type pathname-designator pathname))
(with-pathname (pathname pathname)
(let ((host (%pathname-host pathname)))
(if host
(defun directory-namestring (pathname)
#!+sb-doc
- "Returns a string representation of the directories used in the pathname."
- (declare (type pathname-designator pathname)
- (values (or null simple-base-string)))
+ "Return a string representation of the directories used in the pathname."
+ (declare (type pathname-designator pathname))
(with-pathname (pathname pathname)
(let ((host (%pathname-host pathname)))
(if host
(defun file-namestring (pathname)
#!+sb-doc
- "Returns a string representation of the name used in the pathname."
- (declare (type pathname-designator pathname)
- (values (or null simple-base-string)))
+ "Return a string representation of the name used in the pathname."
+ (declare (type pathname-designator pathname))
(with-pathname (pathname pathname)
(let ((host (%pathname-host pathname)))
(if host
&optional
(defaults *default-pathname-defaults*))
#!+sb-doc
- "Returns an abbreviated pathname sufficent to identify the pathname relative
+ "Return an abbreviated pathname sufficent to identify the pathname relative
to the defaults."
(declare (type pathname-designator pathname))
(with-pathname (pathname pathname)
(declare (type pathname-designator in-pathname))
(with-pathname (pathname in-pathname)
(with-pathname (wildname in-wildname)
- (macrolet ((frob (field &optional (op 'components-match ))
+ (macrolet ((frob (field &optional (op 'components-match))
`(or (null (,field wildname))
(,op (,field pathname) (,field wildname)))))
(and (or (null (%pathname-host wildname))
(frob %pathname-directory directory-components-match)
(frob %pathname-name)
(frob %pathname-type)
- (frob %pathname-version))))))
+ (or (eq (%pathname-host wildname) *unix-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,
(setf in-wildcard t)
(unless subs
(error "not enough wildcards in FROM pattern to match ~
- TO pattern:~% ~S"
+ TO pattern:~% ~S"
pattern))
(let ((sub (pop subs)))
(typecase sub
(push sub strings))
(t
(error "can't substitute this into the middle of a word:~
- ~% ~S"
+ ~% ~S"
sub)))))))
(when strings
;;; 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"
+ did not match:~% ~S ~S"
source from))
-;;; Do TRANSLATE-COMPONENT for all components except host and directory.
+;;; Do TRANSLATE-COMPONENT for all components except host, directory
+;;; and version.
(defun translate-component (source from to diddle-case)
(typecase to
(pattern
(collect ((subs))
(loop
(unless source
- (unless (every #'(lambda (x) (eq x :wild-inferiors)) from)
+ (unless (every (lambda (x) (eq x :wild-inferiors)) from)
(didnt-match-error orig-source orig-from))
(subs ())
(return))
(let ((match (pop subs-left)))
(when (listp match)
(error ":WILD-INFERIORS is not paired in from and to ~
- patterns:~% ~S ~S" from 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))
+ patterns:~% ~S ~S" from to))
(dolist (x match)
(res (maybe-diddle-case x diddle-case)))))
(pattern
(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
(frob %pathname-directory translate-directories)
(frob %pathname-name)
(frob %pathname-type)
- (frob %pathname-version))))))))
-\f
-;;;; search lists
-
-(def!struct (search-list (:make-load-form-fun
- (lambda (s)
- (values `(intern-search-list
- ',(search-list-name s))
- nil))))
- ;; The name of this search-list. Always stored in lowercase.
- (name (required-argument) :type simple-string)
- ;; T if this search-list has been defined. Otherwise NIL.
- (defined nil :type (member t nil))
- ;; the list of expansions for this search-list. Each expansion is
- ;; the list of directory components to use in place of this
- ;; search-list.
- (expansions nil :type list))
-(def!method print-object ((sl search-list) stream)
- (print-unreadable-object (sl stream :type t)
- (write-string (search-list-name sl) stream)))
-
-;;; a hash table mapping search-list names to search-list structures
-(defvar *search-lists* (make-hash-table :test 'equal))
-
-;;; When search-lists are encountered in namestrings, they are
-;;; converted to search-list structures right then, instead of waiting
-;;; until the search list used. This allows us to verify ahead of time
-;;; that there are no circularities and makes expansion much quicker.
-(defun intern-search-list (name)
- (let ((name (string-downcase name)))
- (or (gethash name *search-lists*)
- (let ((new (make-search-list :name name)))
- (setf (gethash name *search-lists*) new)
- new))))
-
-;;; Clear the definition. Note: we can't remove it from the hash-table
-;;; because there may be pathnames still refering to it. So we just
-;;; clear out the expansions and ste defined to NIL.
-(defun clear-search-list (name)
- #!+sb-doc
- "Clear the current definition for the search-list NAME. Returns T if such
- a definition existed, and NIL if not."
- (let* ((name (string-downcase name))
- (search-list (gethash name *search-lists*)))
- (when (and search-list (search-list-defined search-list))
- (setf (search-list-defined search-list) nil)
- (setf (search-list-expansions search-list) nil)
- t)))
-
-;;; As in CLEAR-SEARCH-LIST, we can't actually remove the entries from
-;;; the hash-table, so we just mark them as being undefined.
-(defun clear-all-search-lists ()
- #!+sb-doc
- "Clear the definition for all search-lists. Only use this if you know
- what you are doing."
- (maphash #'(lambda (name search-list)
- (declare (ignore name))
- (setf (search-list-defined search-list) nil)
- (setf (search-list-expansions search-list) nil))
- *search-lists*)
- nil)
-
-;;; Extract the search-list from PATHNAME and return it. If PATHNAME
-;;; doesn't start with a search-list, then either error (if
-;;; FLAME-IF-NONE is true) or return NIL (if FLAME-IF-NONE is false).
-(defun extract-search-list (pathname flame-if-none)
- (with-pathname (pathname pathname)
- (let* ((directory (%pathname-directory pathname))
- (search-list (cadr directory)))
- (cond ((search-list-p search-list)
- search-list)
- (flame-if-none
- (error "~S doesn't start with a search-list." pathname))
- (t
- nil)))))
-
-;;; We have to convert the internal form of the search-list back into
-;;; a bunch of pathnames.
-(defun search-list (pathname)
- #!+sb-doc
- "Return the expansions for the search-list starting PATHNAME. If PATHNAME
- does not start with a search-list, then an error is signaled. If
- the search-list has not been defined yet, then an error is signaled.
- The expansion for a search-list can be set with SETF."
- (with-pathname (pathname pathname)
- (let ((search-list (extract-search-list pathname t))
- (host (pathname-host pathname)))
- (if (search-list-defined search-list)
- (mapcar #'(lambda (directory)
- (make-pathname :host host
- :directory (cons :absolute directory)))
- (search-list-expansions search-list))
- (error "Search list ~S has not been defined yet." pathname)))))
-
-(defun search-list-defined-p (pathname)
- #!+sb-doc
- "Returns T if the search-list starting PATHNAME is currently defined, and
- NIL otherwise. An error is signaled if PATHNAME does not start with a
- search-list."
- (with-pathname (pathname pathname)
- (search-list-defined (extract-search-list pathname t))))
-
-;;; Set the expansion for the search list in PATHNAME. If this would
-;;; result in any circularities, we flame out. If anything goes wrong,
-;;; we leave the old definition intact.
-(defun %set-search-list (pathname values)
- (let ((search-list (extract-search-list pathname t)))
- (labels
- ((check (target-list path)
- (when (eq search-list target-list)
- (error "That would result in a circularity:~% ~
- ~A~{ -> ~A~} -> ~A"
- (search-list-name search-list)
- (reverse path)
- (search-list-name target-list)))
- (when (search-list-p target-list)
- (push (search-list-name target-list) path)
- (dolist (expansion (search-list-expansions target-list))
- (check (car expansion) path))))
- (convert (pathname)
- (with-pathname (pathname pathname)
- (when (or (pathname-name pathname)
- (pathname-type pathname)
- (pathname-version pathname))
- (error "Search-lists cannot expand into pathnames that have ~
- a name, type, or ~%version specified:~% ~S"
- pathname))
- (let ((directory (pathname-directory pathname)))
- (let ((expansion
- (if directory
- (ecase (car directory)
- (:absolute (cdr directory))
- (:relative (cons (intern-search-list "default")
- (cdr directory))))
- (list (intern-search-list "default")))))
- (check (car expansion) nil)
- expansion)))))
- (setf (search-list-expansions search-list)
- (if (listp values)
- (mapcar #'convert values)
- (list (convert values)))))
- (setf (search-list-defined search-list) t))
- values)
-
-(defun %enumerate-search-list (pathname function)
- (let* ((pathname (physicalize-pathname pathname))
- (search-list (extract-search-list pathname nil)))
- (cond
- ((not search-list)
- (funcall function pathname))
- ((not (search-list-defined search-list))
- (error "undefined search list: ~A"
- (search-list-name search-list)))
- (t
- (let ((tail (cddr (pathname-directory pathname))))
- (dolist (expansion
- (search-list-expansions search-list))
- (%enumerate-search-list (make-pathname :defaults pathname
- :directory
- (cons :absolute
- (append expansion
- tail)))
- function)))))))
+ (if (eq from-host *unix-host*)
+ (if (eq (%pathname-version to) :wild)
+ (%pathname-version from)
+ (%pathname-version to))
+ (frob %pathname-version)))))))))
\f
;;;; logical pathname support. ANSI 92-102 specification.
;;;;
;;;; As logical-pathname translations are loaded they are
-;;;; canonicalized as patterns to enable rapid efficent translation
+;;;; canonicalized as patterns to enable rapid efficient translation
;;;; into physical pathnames.
;;;; utilities
;;; 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 (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"
- :arguments (list ch)
+ is not alphanumeric or hyphen:~% ~S"
+ :args (list ch)
:namestring word :offset i))))
word))
(when (pattern)
(error 'namestring-parse-error
:complaint "double asterisk inside of logical ~
- word: ~S"
- :arguments (list chunk)
+ word: ~S"
+ :args (list chunk)
:namestring namestring
:offset (+ (cdar chunks) pos)))
(pattern (subseq chunk last-pos pos)))
(unless (member ch '(#\; #\: #\.))
(error 'namestring-parse-error
:complaint "illegal character for logical pathname:~% ~S"
- :arguments (list ch)
+ :args (list ch)
:namestring namestr
:offset i))
(chunks (cons ch i)))))
(unless (and chunks (simple-string-p (caar chunks)))
(error 'namestring-parse-error
:complaint "expecting ~A, got ~:[nothing~;~S~]."
- :arguments (list what (caar chunks) (caar chunks))
+ :args (list what (caar chunks) (caar chunks))
:namestring namestr
:offset (if chunks (cdar chunks) end)))
(caar chunks))
(unless (eql (caar chunks) #\.)
(error 'namestring-parse-error
:complaint "expecting a dot, got ~S."
- :arguments (list (caar chunks))
+ :args (list (caar chunks))
:namestring namestr
:offset (cdar chunks)))
(if type
(unless (and res (plusp res))
(error 'namestring-parse-error
:complaint "expected a positive integer, ~
- got ~S"
- :arguments (list str)
+ got ~S"
+ :args (list str)
:namestring namestr
:offset (+ pos (cdar chunks))))
(setq version res)))))
:namestring namestr
:offset (cdadr chunks)))))
(parse-host (logical-chunkify namestr start end)))
- (values host :unspecific
- (and (not (equal (directory)'(:absolute)))
- (directory))
- name type version))))
+ (values host :unspecific (directory) name type version))))
-;;; We can't initialize this yet because not all host methods are loaded yet.
+;;; We can't initialize this yet because not all host methods are
+;;; loaded yet.
(defvar *logical-pathname-defaults*)
(defun logical-pathname (pathspec)
(defun unparse-logical-piece (thing)
(etypecase thing
+ ((member :wild) "*")
(simple-string thing)
(pattern
(collect ((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 (not (or (null type) (eq type :unspecific))))
+ (version-supplied (not (or (null version)
+ (eq version :unspecific)))))
+ (when name
+ (when (and (null type) (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 'simple-base-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"))
+ ((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 is :ABSOLUTE, as handled above. so return
;; the original directory.
path-directory))))
- (make-pathname :host (pathname-host pathname)
- :directory enough-directory
- :name (pathname-name pathname)
- :type (pathname-type pathname)
- :version (pathname-version pathname))))
+ (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-unix-file pathname)))
+ (unparse-logical-file pathname)))
\f
;;;; logical pathname translations
(defun (setf logical-pathname-translations) (translations host)
#!+sb-doc
- "Set the translations list for the logical host argument.
- Return translations."
+ "Set the translations list for the logical host argument."
(declare (type (or string logical-host) host)
(type list translations)
(values list))
(return (translate-logical-pathname
(translate-pathname pathname from to)))))))
(pathname pathname)
- (stream (translate-logical-pathname (pathname pathname)))
- (t (translate-logical-pathname (logical-pathname pathname)))))
+ (t (translate-logical-pathname (pathname pathname)))))
(defvar *logical-pathname-defaults*
(%make-logical-pathname (make-logical-host :name "BOGUS")
(values (member t nil)))
(if (find-logical-host host nil)
;; This host is already defined, all is well and good.
- t
+ nil
;; ANSI: "The specific nature of the search is
;; implementation-defined." SBCL: doesn't search at all
+ ;;
+ ;; FIXME: now that we have a SYS host that the system uses, it
+ ;; might be cute to search in "SYS:TRANSLATIONS;<name>.LISP"
(error "logical host ~S not found" host)))
projects / sbcl.git / blobdiff