Commit 21bdedc6 authored by ram's avatar ram
Browse files

Improved integration of logical pathname support with the rest of pathnames.

Generalized TRANSLATE-PATHNAME to work on logical pathnames and
:WILD-INFERIORS, and used this to implement TRANSLATE-LOGICAL-PATHNAME.
Generalized PARSE-NAMESTRING to be able to parse logical namestrings, and use
it to implement LOGICAL-PATHNAME.  Fixed some type declarations that didn't
allow :UNSPECIFIC or :WILD when they should.  Fixed PATH-DESIGNATOR type to
allow complex strings.  Added utilities for canonicalizing logical hosts.
Fixed pattern matching code to consistently accept :WILD and :WILD-INFERIORS.
Changed namestring-parse-error to inherit from PARSE-ERROR, and made logical
namestring parsing use it so that :JUNK-ALLOWED T works.  Mostly rewrote
logical namestring parsing.  Fixed some erroneous simple-string assumptions.
Changed namestring parsing in general to give preference to parsing as a
physical pathname with a search-list, since we can (and must be able to) parse
undefined search-lists, but we can't parse logical pathnames with undefined
hosts.  Reinterpreted the spec for logical pathname parsing somewhat more
liberally.  Changed WILD-PATHNAME-P to recognize :WILD and :WILD-INFERIORS.
Fixed argument order to COMPONENTS-MATCH in PATHNAME-MATCH-P.  Generalized
xxxCOMPONENTxxx matching operations to handle integer and keyword versions,
replacing inline special-casing of versions.  Signal an error if the TO pattern
has more wildcards than the FROM pattern.  Fixed out-of-bounds errors in
MAYBE-MAKE-LOGICAL-PATTERN.  Deleted SAVE-LOGICAL-PATHNAME-TRANSLATIONS.
Simplified search-list hackery in LOAD-LOGICAL-PATHNAME-TRANSLATIONS.
Moved COMPILE-FILE-PATHNAME to compiler/main.
parent 0c046afa
......@@ -6,14 +6,13 @@
;;; Scott Fahlman or slisp-group@cs.cmu.edu.
;;;
(ext:file-comment
"$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/pathname.lisp,v 1.16 1993/07/15 18:02:46 phg Exp $")
"$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/pathname.lisp,v 1.17 1993/07/31 01:40:26 ram Exp $")
;;;
;;; **********************************************************************
;;;
;;; Machine/filesystem independent pathname functions for CMU Common Lisp.
;;;
;;; Written by William Lott, enhancements for logical-pathnames
;;; written by Paul Gleichauf.
;;; Written by William Lott, Paul Gleichauf and Rob MacLachlan.
;;; Earlier version written by Jim Large and Rob MacLachlan
;;;
;;; **********************************************************************
......@@ -62,16 +61,22 @@
(:include host
(:parse #'parse-logical-namestring)
(:unparse #'unparse-logical-namestring)
(:unparse-host #'unparse-logical-host)
(:unparse-host
#'(lambda (x) (logical-host-name (%pathname-host x))))
(:unparse-directory #'unparse-logical-directory)
(:unparse-file #'unparse-logical-file)
(:unparse-file #'unparse-unix-file)
(:unparse-enough #'identity)
(:customary-case :upper)))
(name "" :type simple-base-string)
(translations nil :type list)
(canon-transls nil :type list))
;;; The various magic tokens that are allowed to appear in pretty much all
;;; pathname components.
;;;
(deftype component-tokens ()
'(member nil :unspecific :wild))
;;;; Pathname structures
(defstruct (pathname
......@@ -84,16 +89,16 @@
;; Slot holds the host, at present either a UNIX or logical host.
(host nil :type (or host null))
;; Device is the name of a logical or physical device holding files.
(device nil :type (or null (member :unspecific)))
(device nil :type component-tokens)
;; A list of strings that are the component subdirectory components.
(directory nil :type list)
;; The filename.
(name nil :type (or simple-string pattern null (member :wild)))
(name nil :type (or simple-string pattern component-tokens))
;; The type extension of the file.
(type nil :type (or simple-string pattern null (member :wild :unspecific)))
(type nil :type (or simple-string pattern component-tokens))
;; The version number of the file, a positive integer, but not supported
;; on standard UNIX filesystems.
(version nil :type (or integer null (member :newest :wild))))
(version nil :type (or integer component-tokens (member :newest))))
;;; %PRINT-PATHNAME -- Internal
;;;
......@@ -107,19 +112,6 @@
(format stream "#p~S" namestring))
(*print-readably*
(error "~S Cannot be printed readably." pathname))
(*print-pretty*
(pprint-logical-block (stream nil :prefix "#<" :suffix ">")
(funcall (formatter
"~2IUnprintable pathname: ~_Host=~S, ~_Device=~S, ~_~
Directory=~:/LISP:PPRINT-FILL/, ~_Name=~S, ~_~
Type=~S, ~_Version=~S")
stream
(%pathname-host pathname)
(%pathname-device pathname)
(%pathname-directory pathname)
(%pathname-name pathname)
(%pathname-type pathname)
(%pathname-version pathname))))
(t
(funcall (formatter "#<Unprintable pathname, Host=~S, Device=~S, ~
Directory=~S, File=~S, Name=~S, Version=~S>")
......@@ -158,9 +150,8 @@
(:conc-name %logical-pathname-)
(:print-function %print-logical-pathname)
(:include pathname)
(:constructor
%make-logical-pathname (host device directory name type version))
(:predicate logical-pathname-p)
(:constructor %make-logical-pathname
(host device directory name type version))
(:make-load-form-fun :just-dump-it-normally)))
;;; %PRINT-LOGICAL-PATHNAME -- Internal
......@@ -177,18 +168,6 @@
(format stream "#.(logical-pathname ~S)" namestring))
(*print-readably*
(error "~S Cannot be printed readably." pathname))
(*print-pretty*
(pprint-logical-block (stream nil :prefix "#<" :suffix ">")
(funcall (formatter
"~2IUnprintable pathname: ~_Host=~S, ~_~
Directory=~:/LISP:PPRINT-FILL/, ~_Name=~S, ~_~
Type=~S, ~_Version=~S")
stream
(%pathname-host pathname)
(%pathname-directory pathname)
(%pathname-name pathname)
(%pathname-type pathname)
(%pathname-version pathname))))
(t
(funcall (formatter "#<Unprintable pathname, Host=~S, ~
Directory=~S, File=~S, Name=~S, Version=~S>")
......@@ -206,11 +185,11 @@
(defvar *logical-hosts* (make-hash-table :test #'equal))
;;; PATHSPEC -- internal type
;;; PATH-DESIGNATOR -- internal type
;;;
(deftype path-designator ()
"A path specification, either a string, stream or pathname."
'(or simple-base-string stream pathname))
'(or string stream pathname))
;;;; Patterns
......@@ -300,7 +279,7 @@
(and (< start len)
(matches (cdr pieces) (1+ start) subs t
(cons (schar string start) chars))))
((member :wild :multi-char-wild)
((member :multi-char-wild)
(multiple-value-bind
(won new-subs)
(matches (cdr pieces) start subs t chars)
......@@ -315,168 +294,56 @@
(matches (pattern-pieces pattern) 0 nil nil nil)
(values won (reverse subs))))))
;;; VERIFY-WORD-CHAR-P -- Internal
;;;
(defun verify-word-char-p (ch)
(if (or (eq ch #\-)
(and (char<= #\A ch) (char<= ch #\Z))
(and (char<= #\0 ch) (char<= ch #\9)))
t
nil))
(defun verify-wild-word-char-p (ch)
(if (or (and (char<= #\A ch) (char<= ch #\Z))
(and (char<= #\0 ch) (char<= ch #\9)))
t
nil))
;;; VERIFY-WORD-P -- Internal
;;;
(defun verify-word-p (wd)
(declare (type simple-base-string wd))
(let ((ch nil))
(dotimes (j (length wd))
(setf ch (schar wd j))
(unless (verify-word-char-p ch)
(error "~S is not a wildcard word, it contains an illegal character ~
~S" wd ch))))
t)
;;; HOSTS-MATCH-P -- Internal
;;;
;;; Predicate for host matching. No :wild hosts permitted.
;;;
(defun hosts-match-p (from-host to-host)
(declare (type (or host simple-base-string) from-host to-host))
(typecase from-host
(logical-host ; Subclass on logical-host first.
(typecase to-host
(logical-host
(eq from-host to-host))
(host
nil)
(simple-base-string
(eq from-host (gethash (string-upcase to-host) *logical-hosts*)))))
(host
(typecase to-host
(logical-host
nil)
(host
(eq from-host to-host))
(simple-base-string
(eq from-host (gethash (string-upcase to-host) *logical-hosts*)))))
(simple-base-string
(verify-word-p from-host)
(typecase to-host
(logical-host
(eq to-host (gethash (string-upcase from-host) *logical-hosts*)))
(simple-base-string
(verify-word-p to-host)
(string-equal from-host to-host))))))
;;; WILDCARD-WORD-PARSE -- Internal
;;;
;;; Parse a potential wildcard-word for its subcomponents as a pattern,
;;; and return an error if the syntax is inconsistent.
;;;
(defun wildcard-word-parse (wd)
(declare (type simple-base-string wd)
(values (or simple-base-string pattern)))
(let* ((c nil)
(*-p (position #\* wd))
(start 0)
(end (length wd))
(end-1 (1- end))
(piece nil)
(pat nil))
(when (and (not *-p) (verify-word-p wd))
(return-from wildcard-word-parse wd))
(dotimes (j end)
(setf c (schar wd j))
(when (eq c #\*)
;; Finish the preceeding word, place in pattern.
(setf piece (subseq wd start j))
(when (< 0 (length piece))
(push piece pat))
(push :wild pat)
(setf *-p t
start (1+ j))
(when (and (< j end-1) (eq (schar wd (1+ j)) #\*))
(error "~S is not a wildcard word, it contains a **." wd)))
;; Verify c is a legitimate wildcard character.
(unless (verify-wild-word-char-p c)
(error "~S is not a wildcard word, it contains an illegal character: ~
~S" wd c))
(when (= j end-1)
(setf piece (subseq wd start (1+ j)))
(when (< 0 (length piece))
(push piece pat))))
(values (make-pattern (nreverse pat)))))
;;; DIRECTORY-COMPONENTS-MATCH -- Internal
;;;
;;; Pathname-match-p for directory components.
;;;
(defun directory-components-match (thing wild)
(or (eq thing wild)
(eq wild :wild)
(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))))))))
;;; COMPONENTS-MATCH -- Internal
;;;
;;; Wilds in "to" are matched against "from" where both are strings,
;;; patterns or lists containing :wild and :wild-inferiors.
;;; FROM = :WILD-INFERIORS or :WILD handled separately for directory
;;; component. Not communative. Result is a Boolean or a member result.
;;; Return true if pathname component Thing is matched by Wild. Not
;;; commutative.
;;;
(defun components-match (from to)
(declare (type (or simple-base-string symbol pattern cons fixnum) from)
(type (or simple-base-string symbol pattern cons fixnum) to))
(or (eq from to)
(typecase from
(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-base-string
;; Match can either be a identical pattern modulo wildcards or the
;; same string.
(typecase to
;; String is matched by itself, a matching pattern or :WILD.
(typecase wild
(pattern
(values (pattern-matches to from)))
(values (pattern-matches wild thing)))
(simple-base-string
(string-equal from to))))
(string= thing wild))))
(pattern
;; Match is a identical pattern.
(and (pattern-p to) (pattern= from to)))
((member :wild)
;; :WILD component matches any string, or pattern or NIL.
(or (stringp to)
(logical-host-p to)
(pattern-p to)
(member to '(nil :unspecific :newest :wild :wild-inferiors))))
((member :newest)
;; :newest matches itself, a wildcard or a positive integer version
;; number.
(or (member to '(:wild :newest)) (and (integerp to) (plusp to))))
(cons ;; A list that may include wildcards.
(and (consp from)
(let ((from1 (first from))
(from2 nil)
(to1 (first to)))
(typecase from1
((member :wild)
(or (stringp to1)
(pattern-p to1)
(not to1)
(eq to1 :unspecific)))
((member :wild-inferiors)
(setf from2 (second from))
(cond ((not from2)
;; Nothing left of from, hence anything else in to
;; matches :wild-inferiors.
t)
((components-match
(rest (rest from))
(rest (member from2 to :test #'equal))))))
(keyword ; :unspecific, :up, :back
(and (keywordp to1)
(eq from1 to1)
(components-match (rest from) (rest to))))
(string
(and (stringp to1)
(string-equal from1 to1)
(components-match (rest from) (rest to))))))))
((member :back :up :unspecific nil)
(and (pattern-p from)
(equal (pattern-pieces from) '(:multi-char-wild)))))))
;; 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 is the
;; version is a fixnum.
(eql thing wild)))))
;;; COMPARE-COMPONENT -- Internal
;;;
......@@ -542,7 +409,7 @@
`(let ((,var (let ((,var ,expr))
(typecase ,var
(logical-host ,var)
(string (gethash ,var *logical-hosts*))
(string (find-host ,var))
(t nil)))))
,@body))
......@@ -559,12 +426,9 @@
;;; Change the case of thing if diddle-p T.
;;;
(defun maybe-diddle-case (thing diddle-p)
(declare (type (or list pattern simple-base-string (member :unspecific))
thing)
(values (or list pattern simple-base-string (member :unspecific))))
(if diddle-p
(if (and diddle-p (not (or (symbolp thing) (integerp thing))))
(labels ((check-for (pred in)
(etypecase in
(typecase in
(pattern
(dolist (piece (pattern-pieces in))
(when (typecase piece
......@@ -583,10 +447,9 @@
(dotimes (i (length in))
(when (funcall pred (schar in i))
(return t))))
((member :unspecific :up :absolute :relative)
nil)))
(t nil)))
(diddle-with (fun thing)
(etypecase thing
(typecase thing
(pattern
(make-pattern
(mapcar #'(lambda (piece)
......@@ -607,7 +470,7 @@
(mapcar fun thing))
(simple-base-string
(funcall fun thing))
((member :unspecific :up :absolute :relative)
(t
thing))))
(let ((any-uppers (check-for #'upper-case-p thing))
(any-lowers (check-for #'lower-case-p thing)))
......@@ -629,6 +492,7 @@
thing))))
thing))
;;; MERGE-DIRECTORIES -- Internal
;;;
(defun merge-directories (dir1 dir2 diddle-case)
......@@ -689,6 +553,8 @@
(defun import-directory (directory diddle-case)
(etypecase directory
(null nil)
((member :wild) '(:absolute :wild-inferiors))
((member :unspecific) '(:relative))
(list
(collect ((results))
(ecase (pop directory)
......@@ -699,11 +565,7 @@
(:relative
(results :relative)))
(dolist (piece directory)
(cond ((eq piece :wild)
(results (make-pattern (list :multi-char-wild))))
((eq piece :wild-inferiors)
(results piece))
((member piece '(:up :back))
(cond ((member piece '(:wild :wild-inferiors :up :back))
(results piece))
((or (simple-string-p piece) (pattern-p piece))
(results (maybe-diddle-case piece diddle-case)))
......@@ -733,12 +595,11 @@
(case :local))
"Makes a new pathname from the component arguments. Note that host is a host-
structure."
(declare (type (or host null) host)
(type (member nil :unspecific) device)
(type (or list string pattern (member :wild)) directory)
(type (or null string pattern (member :wild)) name)
(type (or null string pattern (member :unspecific :wild)) type)
(type (or null integer (member :unspecific :wild :newest)) version)
(declare (type (or host component-tokens) host)
(type component-tokens device)
(type (or list string pattern component-tokens) directory)
(type (or string pattern component-tokens) name type)
(type (or integer component-tokens (member :newest)) version)
(type (or path-designator null) defaults)
(type (member :common :local) case))
(let* ((defaults (when defaults
......@@ -747,8 +608,9 @@
(%pathname-host defaults)
(pathname-host *default-pathname-defaults*)))
(host (or host default-host))
(diddle-args (and (eq case :common)
(eq (host-customary-case host) :lower)))
(diddle-args (ecase (host-customary-case host)
(:lower (eq case :common))
(:upper (eq case :local))))
(diddle-defaults
(not (eq (host-customary-case host)
(host-customary-case default-host))))
......@@ -765,9 +627,7 @@
diddle-defaults)))
(macrolet ((pick (var varp field)
`(cond ((eq ,var :wild)
(make-pattern (list :multi-char-wild)))
((or (simple-string-p ,var)
`(cond ((or (simple-string-p ,var)
(pattern-p ,var))
(maybe-diddle-case ,var diddle-args))
((stringp ,var)
......@@ -783,7 +643,7 @@
(if (logical-host-p host)
(%make-logical-pathname
host
nil
:unspecific
dir
(pick name namep %pathname-name)
(pick type typep %pathname-type)
......@@ -878,97 +738,66 @@
(namestring-parse-error-namestring condition)
(namestring-parse-error-offset condition)))
(define-condition namestring-parse-error (error)
(define-condition namestring-parse-error (parse-error)
((complaint :init-form (required-argument))
(arguments :init-form nil)
(namestring :init-form (required-argument))
(offset :init-form (required-argument)))
(:report %print-namestring-parse-error))
;;; %PARSE-PHYSICAL-NAMESTRING -- Internal
;;;
(defun %parse-physical-namestring (namestr things-host start end junk-allowed)
(declare (type host things-host)
(type string namestr)
(type index start end))
(cond (junk-allowed
(handler-case
(%parse-physical-namestring namestr things-host start end nil)
(namestring-parse-error (condition)
(values nil (namestring-parse-error-offset condition)))))
((simple-string-p namestr)
(multiple-value-bind
(new-host device directory file type version)
(funcall (host-parse things-host) namestr start end)
(declare (ignore new-host))
(values
(%make-pathname things-host device directory file type version)
end)))
(t
(%parse-physical-namestring (coerce namestr 'simple-base-string)
things-host
start end nil))))
;;; %PARSE-LOGICAL-NAMESTRING -- Internal
;;;
(defun %parse-logical-namestring (namestr things-host start end junk-allowed)
(declare (type logical-host things-host)
(type string namestr)
(type index start end))
(cond (junk-allowed
(handler-case
(%parse-logical-namestring namestr things-host start end nil)
(namestring-parse-error
(condition)
(values nil (namestring-parse-error-offset condition)))))
((simple-string-p namestr)
(multiple-value-bind
(lpath end)
(parse-logical-namestring namestr :host things-host
:start start :end end)
(values lpath end)))
(t
(%parse-logical-namestring (coerce namestr 'simple-base-string)
things-host
start end nil))))
;;; EXTRACT-PATH-PREFIX -- Internal
;;;
;;; Extract the host or search-list prefix from the beginning of the
;;; namestring, use it to return the host structure, the colon-position
;;; in the namestring for further search, and whether the namestring specifies
;;; a logical namestring.
;;;
(defun extract-path-prefix (namestr start end host defaults)
;;; %PARSE-NAMESTRING -- Internal
;;;
;;; 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 if 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))
(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 Host arg is not supplied, Defaults arg 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 "Host in namestring: ~S~@
does not match explicit host argument: ~S"
host))
(let ((pn-host (or new-host parse-host)))
(values (funcall (if (typep pn-host 'logical-host)
#'%make-logical-pathname
#'%make-pathname)
pn-host device directory file type version)
end))))))
;;; EXTRACT-LOGICAL-HOST-PREFIX -- Internal
;;;
;;; If namestr begins with a colon-terminated, defined, logical host, then
;;; return that host, otherwise return NIL.
;;;
(defun extract-logical-host-prefix (namestr start end)
(declare (type simple-base-string namestr)
(type index start end)
(type (or null host) host)
(type pathname defaults)
(values host index (or t null)))
(let* ((colon-pos (position #\: namestr :start start :end end))
(host (if host host (%pathname-host defaults)))
(host-temp nil)
(lpathp nil)
(prefix-str nil))
(cond ((logical-host-p host)
(setf lpathp t)
(logical-host-name host))
(t
(funcall (host-unparse-host host) host)))
(unless colon-pos ; No logical host or search-list prefix to namestr.
(return-from extract-path-prefix (values host 0 lpathp)))
(setf prefix-str (subseq namestr start colon-pos)
lpathp (logical-word-p prefix-str))
(cond (lpathp ; If a legitimate logical host name prefix exists, use it.
(setf host-temp (gethash prefix-str *logical-hosts*))
(unless (and prefix-str host-temp)
(error "The logical-host ~S is not defined." prefix-str))
(setf host host-temp))
(t
(unless (gethash prefix-str *search-lists*)
(error "The prefix ~S to the pathname string ~S is not a ~
registered search-list." prefix-str namestr))))
(values host colon-pos lpathp)))
(values (or logical-host null)))
(let ((colon-pos (position #\: namestr :start start :end end)))
(if colon-pos
(values (gethash (nstring-upcase (subseq namestr start colon-pos))
*logical-hosts*))
nil)))
;;; PARSE-NAMESTRING -- Interface
;;;
......@@ -985,27 +814,13 @@
(type (or index null) end)
(type (or t null) junk-allowed)