From b672560b60bc440d097b4abeb56694ea658a74a2 Mon Sep 17 00:00:00 2001 From: phg <phg> Date: Thu, 15 Jul 1993 18:02:46 +0000 Subject: [PATCH] Logical pathnames for UNIX filesystems have been added. Note that logical- namestrings must consist of capital letters, numbers and hyphens, according to the ANSI specification, and not including lower case letters as listed in some of the examples in the specification. --- code/filesys.lisp | 4 +- code/pathname.lisp | 1494 +++++++++++++++++++++++++++----------------- 2 files changed, 932 insertions(+), 566 deletions(-) diff --git a/code/filesys.lisp b/code/filesys.lisp index 8d2ce8524..56afdcc2d 100644 --- a/code/filesys.lisp +++ b/code/filesys.lisp @@ -6,7 +6,7 @@ ;;; Scott Fahlman or slisp-group@cs.cmu.edu. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/filesys.lisp,v 1.29 1992/09/04 15:22:16 phg Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/filesys.lisp,v 1.30 1993/07/15 17:59:50 phg Exp $") ;;; ;;; ********************************************************************** ;;; @@ -717,11 +717,13 @@ ;;; ;;; Return Home:, which is set up for us at initialization time. ;;; +#| (defun user-homedir-pathname (&optional host) "Returns the home directory of the logged in user as a pathname. This is obtained from the logical name \"home:\"." (declare (ignore host)) #p"home:") +|# ;;; File-Write-Date -- Public ;;; diff --git a/code/pathname.lisp b/code/pathname.lisp index 6a24dbbc8..10afbff36 100644 --- a/code/pathname.lisp +++ b/code/pathname.lisp @@ -6,7 +6,7 @@ ;;; Scott Fahlman or slisp-group@cs.cmu.edu. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/pathname.lisp,v 1.15 1992/09/04 15:17:24 phg Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/pathname.lisp,v 1.16 1993/07/15 18:02:46 phg Exp $") ;;; ;;; ********************************************************************** ;;; @@ -36,9 +36,43 @@ (in-package "LISP") -;;;; Structures and types. +;;;; HOST structures -;;; Pathname structure holds the essential properties of the parsed path. +;;; The host structure holds the functions that both parse the pathname +;;; information into sturcture slot entries, and after translation the inverse +;;; (unparse) functions. +;;; +(defstruct (host + (:print-function %print-host)) + (parse (required-argument) :type function) + (unparse (required-argument) :type function) + (unparse-host (required-argument) :type function) + (unparse-directory (required-argument) :type function) + (unparse-file (required-argument) :type function) + (unparse-enough (required-argument) :type function) + (customary-case (required-argument) :type (member :upper :lower))) + +;;; %PRINT-HOST -- Internal +;;; +(defun %print-host (host stream depth) + (declare (ignore depth)) + (print-unreadable-object (host stream :type t :identity t))) + +(defstruct (logical-host + (:include host + (:parse #'parse-logical-namestring) + (:unparse #'unparse-logical-namestring) + (:unparse-host #'unparse-logical-host) + (:unparse-directory #'unparse-logical-directory) + (:unparse-file #'unparse-logical-file) + (:unparse-enough #'identity) + (:customary-case :upper))) + (name "" :type simple-base-string) + (translations nil :type list) + (canon-transls nil :type list)) + + +;;;; Pathname structures (defstruct (pathname (:conc-name %pathname-) @@ -50,13 +84,13 @@ ;; 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 (member nil :unspecific)) + (device nil :type (or null (member :unspecific))) ;; A list of strings that are the component subdirectory components. (directory nil :type list) ;; The filename. - (name nil :type (or simple-string pattern null)) + (name nil :type (or simple-string pattern null (member :wild))) ;; The type extension of the file. - (type nil :type (or simple-string pattern null (member :unspecific))) + (type nil :type (or simple-string pattern null (member :wild :unspecific))) ;; 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)))) @@ -97,27 +131,86 @@ (%pathname-type pathname) (%pathname-version pathname)))))) -;;;; HOST structure - -;;; The host structure holds the functions that both parse the pathname -;;; information into sturcture slot entries, and after translation the inverse -;;; (unparse) functions. +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; -(defstruct (host - (:print-function %print-host)) - (parse (required-argument) :type function) - (unparse (required-argument) :type function) - (unparse-host (required-argument) :type function) - (unparse-directory (required-argument) :type function) - (unparse-file (required-argument) :type function) - (unparse-enough (required-argument) :type function) - (customary-case (required-argument) :type (member :upper :lower))) +;;; 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. +;;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; %PRINT-HOST -- Internal +;; Logical pathnames are a subclass of pathname, their class relations are +;; mimiced using structures for efficency. + +(defstruct (logical-pathname + (: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) + (:make-load-form-fun :just-dump-it-normally))) + +;;; %PRINT-LOGICAL-PATHNAME -- Internal ;;; -(defun %print-host (host stream depth) +;;; The printed representation of the logical-pathname structure. +;;; The potential conflict with search-lists requires isolating the printed +;;; representation to use the i/o macro #.(logical-pathname <path-designator>). +;;; +(defun %print-logical-pathname (pathname stream depth) (declare (ignore depth)) - (print-unreadable-object (host stream :type t :identity t))) + (let ((namestring (handler-case (namestring pathname) + (error nil)))) + (cond (namestring + (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>") + stream + (%pathname-host pathname) + (%pathname-directory pathname) + (%pathname-name pathname) + (%pathname-type pathname) + (%pathname-version pathname)))))) + +;;; *LOGICAL-HOSTS* --internal. +;;; +;;; Hash table searching maps a logical-pathname's host to their physical +;;; pathname translation. + +(defvar *logical-hosts* (make-hash-table :test #'equal)) + +;;; PATHSPEC -- internal type +;;; +(deftype path-designator () + "A path specification, either a string, stream or pathname." + '(or simple-base-string stream pathname)) ;;;; Patterns @@ -164,6 +257,9 @@ ;;; PATTERN-MATCHES -- Internal ;;; +;;; If the string matches the pattern returns the multiple valuse T and a +;;; list of the matched strings. +;;; (defun pattern-matches (pattern string) (declare (type pattern pattern) (type simple-string string)) @@ -204,7 +300,7 @@ (and (< start len) (matches (cdr pieces) (1+ start) subs t (cons (schar string start) chars)))) - ((member :multi-char-wild) + ((member :wild :multi-char-wild) (multiple-value-bind (won new-subs) (matches (cdr pieces) start subs t chars) @@ -219,32 +315,138 @@ (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))))) + ;;; COMPONENTS-MATCH -- Internal ;;; -;;; Wilds in to are matched against from where both are either lists -;;; containing :wild and :wild-inferiors, patterns or strings. +;;; 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. +;;; component. Not communative. Result is a Boolean or a member result. ;;; (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 (simple-base-string + ;; Match can either be a identical pattern modulo wildcards or the + ;; same string. (typecase to - (pattern + (pattern (values (pattern-matches to from))) (simple-base-string (string-equal from to)))) (pattern + ;; Match is a identical pattern. (and (pattern-p to) (pattern= from to))) - ((member :wild) ; :WILD component matches any string, or pattern or NIL. + ((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) - (member to '(:wild))) - (cons ; Watch for wildcards. + ;; :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) @@ -276,9 +478,6 @@ (and (pattern-p from) (equal (pattern-pieces from) '(:multi-char-wild))))))) - -;;;; Utilities. - ;;; COMPARE-COMPONENT -- Internal ;;; ;;; A predicate for comparing two pathname slot component sub-entries. @@ -307,6 +506,8 @@ ;;; PATHNAME= -- Internal ;;; (defun pathname= (pathname1 pathname2) + (declare (type pathname pathname1) + (type pathname pathname2)) (and (eq (%pathname-host pathname1) (%pathname-host pathname2)) (compare-component (%pathname-device pathname1) @@ -321,7 +522,7 @@ (%pathname-version pathname2)))) ;;; WITH-PATHNAME -- Internal -;;; Converts the var, a pathname designator (a pathname, or string, or +;;; Converts the expr, a pathname designator (a pathname, or string, or ;;; stream), into a pathname. ;;; (defmacro with-pathname ((var expr) &body body) @@ -332,12 +533,24 @@ (stream (parse-namestring (file-name ,var))))))) ,@body)) +;;; WITH-HOST -- Internal +;;; +;;; Converts the var, a host or string name for a host, into a logical-host +;;; structure or nil if not defined. +;;; +(defmacro with-host ((var expr) &body body) + `(let ((,var (let ((,var ,expr)) + (typecase ,var + (logical-host ,var) + (string (gethash ,var *logical-hosts*)) + (t nil))))) + ,@body)) ;;; PATHNAME -- Interface ;;; (defun pathname (thing) "Convert thing (a pathname, string or stream) into a pathname." - (declare (type pathnamelike thing)) + (declare (type path-designator thing)) (with-pathname (pathname thing) pathname)) @@ -443,6 +656,9 @@ (default-version :newest)) "Construct a filled in pathname by completing the unspecified components from the defaults." + (declare (type path-designator pathname) + (type path-designator defaults) + (values pathname)) (with-pathname (defaults defaults) (let ((pathname (let ((*default-pathname-defaults* defaults)) (pathname pathname)))) @@ -507,13 +723,14 @@ ;;; MAKE-PATHNAME -- Interface ;;; -(defun make-pathname (&key (host nil hostp) +(defun make-pathname (&key host (device nil devp) (directory nil dirp) (name nil namep) (type nil typep) (version nil versionp) - defaults (case :local)) + defaults + (case :local)) "Makes a new pathname from the component arguments. Note that host is a host- structure." (declare (type (or host null) host) @@ -522,19 +739,31 @@ (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) - (type (or pathnamelike null) defaults) + (type (or path-designator null) defaults) (type (member :common :local) case)) - (let* ((defaults (if defaults - (with-pathname (defaults defaults) defaults))) + (let* ((defaults (when defaults + (with-pathname (defaults defaults) defaults))) (default-host (if defaults (%pathname-host defaults) (pathname-host *default-pathname-defaults*))) - (host (if hostp host default-host)) + (host (or host default-host)) (diddle-args (and (eq case :common) (eq (host-customary-case host) :lower))) (diddle-defaults (not (eq (host-customary-case host) - (host-customary-case default-host))))) + (host-customary-case default-host)))) + (dev (if devp device (if defaults (%pathname-device defaults)))) + (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 ((eq ,var :wild) (make-pattern (list :multi-char-wild))) @@ -551,28 +780,29 @@ diddle-defaults)) (t nil)))) - (%make-pathname - host - (if devp device (if defaults (%pathname-device defaults))) - (let ((dir (import-directory directory diddle-args))) - (if (and defaults (not dirp)) - (merge-directories dir - (%pathname-directory defaults) - diddle-defaults) - dir)) - (pick name namep %pathname-name) - (pick type typep %pathname-type) - (cond - (versionp version) - (defaults (%pathname-version defaults)) - (t nil)))))) + (if (logical-host-p host) + (%make-logical-pathname + host + nil + dir + (pick name namep %pathname-name) + (pick type typep %pathname-type) + ver) + (%make-pathname + host + dev + dir + (pick name namep %pathname-name) + (pick type typep %pathname-type) + ver))))) ;;; PATHNAME-HOST -- Interface ;;; (defun pathname-host (pathname &key (case :local)) "Accessor for the pathname's host." - (declare (type pathnamelike pathname) + (declare (type path-designator pathname) (type (member :local :common) case) + (values host) (ignore case)) (with-pathname (pathname pathname) (%pathname-host pathname))) @@ -581,7 +811,7 @@ ;;; (defun pathname-device (pathname &key (case :local)) "Accessor for pathname's device." - (declare (type pathnamelike pathname) + (declare (type path-designator pathname) (type (member :local :common) case)) (with-pathname (pathname pathname) (maybe-diddle-case (%pathname-device pathname) @@ -594,7 +824,7 @@ ;;; (defun pathname-directory (pathname &key (case :local)) "Accessor for the pathname's directory list." - (declare (type pathnamelike pathname) + (declare (type path-designator pathname) (type (member :local :common) case)) (with-pathname (pathname pathname) (maybe-diddle-case (%pathname-directory pathname) @@ -606,7 +836,7 @@ ;;; (defun pathname-name (pathname &key (case :local)) "Accessor for the pathname's name." - (declare (type pathnamelike pathname) + (declare (type path-designator pathname) (type (member :local :common) case)) (with-pathname (pathname pathname) (maybe-diddle-case (%pathname-name pathname) @@ -619,7 +849,7 @@ ;;; (defun pathname-type (pathname &key (case :local)) "Accessor for the pathname's name." - (declare (type pathnamelike pathname) + (declare (type path-designator pathname) (type (member :local :common) case)) (with-pathname (pathname pathname) (maybe-diddle-case (%pathname-type pathname) @@ -627,11 +857,12 @@ (eq (host-customary-case (%pathname-host pathname)) :lower))))) + ;;; PATHNAME-VERSION ;;; (defun pathname-version (pathname) "Accessor for the pathname's version." - (declare (type pathnamelike pathname)) + (declare (type path-designator pathname)) (with-pathname (pathname pathname) (%pathname-version pathname))) @@ -654,93 +885,154 @@ (offset :init-form (required-argument))) (:report %print-namestring-parse-error)) -;;; %PARSE-NAMESTRING -- Internal +;;; %PARSE-PHYSICAL-NAMESTRING -- Internal ;;; -(defun %parse-namestring (namestr start end host junk-allowed) - (declare (type string namestr) - (type index start end) - (type host host) - (values (or null pathname) index)) +(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-namestring namestr start end host nil) + (handler-case + (%parse-physical-namestring namestr things-host start end nil) (namestring-parse-error (condition) - (values nil (namestring-parse-error-offset 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 host) namestr start end) - (values (%make-pathname (or new-host host) - device - directory - file - type - version) - end))) + (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-namestring (coerce namestr 'simple-string) - start end host nil)))) + (%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) + (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))) ;;; PARSE-NAMESTRING -- Interface ;;; (defun parse-namestring (thing &optional host (defaults *default-pathname-defaults*) &key (start 0) end junk-allowed) - "Converts thing, a pathname designator, into a pathname structure, returns - the printed representation." - (declare (type (or simple-base-string stream pathname) thing) + "Converts pathname, a pathname designator, into a pathname structure, + for a physical pathname, returns the printed representation. Host may be + a physical host structure or host namestring." + (declare (type path-designator thing) (type (or null host) host) - (type pathnamelike defaults) + (type pathname defaults) (type index start) (type (or index null) end) - (type (or null (not null)) junk-allowed) - (values (or null pathname) index)) - (cond ((stringp thing) - (let* ((end1 (or end (length thing))) - (things-host nil) - (hosts-name (when host - (funcall (host-parse host) thing start end1)))) - (setf things-host - (maybe-extract-logical-host thing start end1)) - (when (and host things-host) ; A logical host and host are defined. - (unless (string= things-host hosts-name) - (error "Hosts do not match: ~S in ~S and ~S." - things-host thing host))) - (if things-host - (unless (gethash (string-downcase things-host) *search-lists*) - ;; Not a search-list name, make it a logical-host name. - (setf host (intern-logical-host things-host)))) - (%parse-namestring thing start end1 - (or host - (with-pathname (defaults defaults) - (%pathname-host defaults))) - junk-allowed))) - ((pathnamep thing) - (when host - (unless (eq host (%pathname-host thing)) - (error "Hosts do not match: ~S and ~S." - host - (%pathname-host thing)))) - (values thing start)) - ((streamp thing) - (let ((host-name (funcall (host-unparse-host host) host)) - (stream-type (type-of thing)) - (stream-host-name (host-namestring thing))) - (unless (or (eq stream-type 'fd-stream) - ;;********Change fd-stream to file-stream in sources too. - (eq stream-type 'synonym-stream)) - (error "Stream ~S was created with other than OPEN, WITH-OPEN-FILE~ - or MAKE-SYNONYM-FILE." thing)) - (unless (string-equal stream-host-name host-name) - (error "Hosts do not match: ~S and ~S." - host - host-name))) - (values thing start)))) + (type (or t null) junk-allowed) + (values (or null pathname) (or null index))) + (let* ((end1 (or end (length thing))) + (things-host nil) + (colon-pos nil) + (lpathp nil)) + (typecase thing + (simple-base-string + (multiple-value-setq + (things-host colon-pos lpathp) + (extract-path-prefix thing start end1 host defaults)) + (if lpathp + (%parse-logical-namestring thing + things-host + colon-pos + end1 + junk-allowed) + (%parse-physical-namestring thing + things-host + start + end1 + junk-allowed))) + (pathname ; structure type + (let* ((host (if host host (%pathname-host defaults))) + (hosts-name (funcall (host-unparse-host host) host))) + (unless (eq hosts-name (%pathname-host thing)) + (error "Hosts do not match: ~S and ~S." + hosts-name (%pathname-host thing)))) + (values thing start)) + (stream + (let* ((stream-type (type-of thing)) + (things-host-name (host-namestring thing)) + (host (if host host (%pathname-host defaults))) + (hosts-name (funcall (host-unparse-host host) host))) + (unless (or (eq stream-type 'fd-stream) + ;;######Change fd-stream to file-stream in sources too. + (eq stream-type 'synonym-stream)) + (error "Stream ~S was created with other than OPEN, WITH-OPEN-FILE~ + or MAKE-SYNONYM-FILE." thing)) + (unless (string-equal hosts-name things-host-name) + (error "Hosts do not match: ~S and ~S." + hosts-name things-host-name))) + (values (file-name thing) start))))) ;;; NAMESTRING -- Interface ;;; (defun namestring (pathname) "Construct the full (name)string form of the pathname." - (declare (type pathnamelike pathname)) + (declare (type path-designator pathname) + (values (or null simple-base-string))) (with-pathname (pathname pathname) (let ((host (%pathname-host pathname))) (cond ((logical-host-p host) @@ -756,7 +1048,8 @@ ;;; (defun host-namestring (pathname) "Returns a string representation of the name of the host in the pathname." - (declare (type pathnamelike pathname)) + (declare (type path-designator pathname) + (values (or null simple-base-string))) (with-pathname (pathname pathname) (let ((host (%pathname-host pathname))) (if host @@ -769,7 +1062,8 @@ ;;; (defun directory-namestring (pathname) "Returns a string representation of the directories used in the pathname." - (declare (type pathnamelike pathname)) + (declare (type path-designator pathname) + (values (or null simple-base-string))) (with-pathname (pathname pathname) (let ((host (%pathname-host pathname))) (if host @@ -782,7 +1076,8 @@ ;;; (defun file-namestring (pathname) "Returns a string representation of the name used in the pathname." - (declare (type pathnamelike pathname)) + (declare (type path-designator pathname) + (values (or null simple-base-string))) (with-pathname (pathname pathname) (let ((host (%pathname-host pathname))) (if host @@ -797,7 +1092,7 @@ &optional (defaults *default-pathname-defaults*)) "Returns an abbreviated pathname sufficent to identify the pathname relative to the defaults." - (declare (type pathnamelike pathname)) + (declare (type path-designator pathname)) (with-pathname (pathname pathname) (let ((host (%pathname-host pathname))) (if host @@ -814,7 +1109,7 @@ ;;; (defun wild-pathname-p (pathname &optional field-key) "Predicate for determining whether pathname contains any wildcards." - (declare (type pathnamelike pathname) + (declare (type path-designator pathname) (type (member nil :host :device :directory :name :type :version) field-key)) (with-pathname (pathname pathname) @@ -826,30 +1121,29 @@ (wild-pathname-p pathname :name) (wild-pathname-p pathname :type) (wild-pathname-p pathname :version))) - (:host - (pattern-p (%pathname-host pathname))) - (:device - (pattern-p (%pathname-host pathname))) - (:directory - (some #'pattern-p (%pathname-directory pathname))) - (:name - (pattern-p (%pathname-name pathname))) - (:type - (pattern-p (%pathname-type pathname))) - (:version - (eq (%pathname-version pathname) :wild))))) + (:host (pattern-p (%pathname-host pathname))) + (:device (pattern-p (%pathname-host pathname))) + (:directory (some #'pattern-p (%pathname-directory pathname))) + (:name (pattern-p (%pathname-name pathname))) + (:type (pattern-p (%pathname-type pathname))) + (:version (eq (%pathname-version pathname) :wild))))) ;;; PATHNAME-MATCH -- Interface ;;; -(defun pathname-match-p (pathname wildname) +(defun pathname-match-p (in-pathname in-wildname) "Pathname matches the wildname template?" - (with-pathname (pathname pathname) - (with-pathname (wildname wildname) + (declare (type path-designator in-pathname)) + (with-pathname (pathname in-pathname) + (with-pathname (wildname in-wildname) (macrolet ((frob (field) `(or (null (,field wildname)) (components-match (,field wildname) (,field pathname))))) - (and (frob %pathname-host) + (and (or (null (%pathname-host wildname)) + (components-match (logical-host-name + (%pathname-host wildname)) + (logical-host-name + (%pathname-host pathname)))) (frob %pathname-device) (frob %pathname-directory) (frob %pathname-name) @@ -861,15 +1155,23 @@ ;;; SUBSTITUTE-INTO -- Internal ;;; -(defun substitute-into (pattern subs) +;;; Place the substitutions into the pattern and return the string or +;;; pattern that results. The case argument allows for the use of a :lower +;;; case to enable a UNIX and implementation specific translation of uppercase +;;; characters in logical-namestrings into lower case physical namestrings. +;;; +(defun substitute-into (pattern subs &key (case :common)) (declare (type pattern pattern) - (type list subs)) + (type list subs) + (values (or simple-base-string pattern))) (let ((in-wildcard nil) (pieces nil) (strings nil)) (dolist (piece (pattern-pieces pattern)) (cond ((simple-string-p piece) - (push piece strings) + (if (eq case 'lower) + (push (string-downcase piece) strings) + (push piece strings)) (setf in-wildcard nil)) (in-wildcard) ((null subs)) @@ -882,17 +1184,18 @@ (nreverse strings)) pieces)) (dolist (piece (pattern-pieces sub)) - (push piece pieces))) + (if (and (stringp piece) (eq case 'lower)) + (push (string-downcase piece) pieces) + (push piece pieces)))) (simple-string - (push sub strings)))) + (if (eq case 'lower) + (push (string-downcase sub) strings) + (push sub strings))))) (setf in-wildcard t)))) (when strings - (push (apply #'concatenate 'simple-string - (nreverse strings)) + (push (apply #'concatenate 'simple-string (nreverse strings)) pieces)) - (if (and pieces - (simple-string-p (car pieces)) - (null (cdr pieces))) + (if (and pieces (simple-string-p (car pieces)) (null (cdr pieces))) (car pieces) (make-pattern (nreverse pieces))))) @@ -977,7 +1280,7 @@ (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 pathnamelike source from-wildname to-wildname)) + (declare (type path-designator source from-wildname to-wildname)) (with-pathname (source source) (with-pathname (from from-wildname) (with-pathname (to to-wildname) @@ -1111,10 +1414,10 @@ "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." + 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))) + (host (pathname-host pathname))) (if (search-list-defined search-list) (mapcar #'(lambda (directory) (make-pathname :host host @@ -1212,60 +1515,8 @@ ;;;; Logical pathname support. ANSI 92-102 specification. - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; -;;; 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 -;;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -;; Logical pathnames are a subclass of pathnames and can use the same -;; data structures with the device slot necessarily nil. The current lack of -;; an integrated efficient CLOS means that the classes are mimiced using -;; structures. They follow the pattern set by search-lists, a CMUCL specific -;; extension. - -(defstruct (logical-host - (:include host - (:parse #'parse-logical-namestring) - (:unparse #'unparse-logical-namestring) - (:unparse-host #'unparse-logical-host) - (:unparse-directory #'unparse-logical-directory) - (:unparse-file #'unparse-logical-file) - (:unparse-enough #'identity) - (:customary-case :upper))) - (name "" :type simple-string) - (translations nil :type list) - (canon-transls nil :type list)) - -(deftype logical-pathname () - '(satisfies logical-pathname-p)) - -;;; LOGICAL-PATHNAME-P -- Public -;;; -(defun logical-pathname-p (thing) - "Return T if THING is a LOGICAL-PATHNAME object." - (and (pathnamep thing) - (logical-host-p (%pathname-host thing)))) - -;;; *LOGICAL-PATHNAMES* --internal. -;;; -;;; Hash table searching maps a logical-pathname's host to their physical -;;; pathname translation. - -(defvar *logical-pathnames* (make-hash-table :test #'equal)) +;;;; As logical-pathname translations are loaded they are canonicalized as +;;;; patterns to enable rapid efficent translation into physical pathnames. (define-condition logical-namestring-parse-error (error) ((complaint :init-form (required-argument)) @@ -1276,10 +1527,12 @@ ;;; MAYBE-MAKE-LOGICAL-PATTERN -- Internal ;;; +;;; Take the ; reduced strings and break them into words and wildcard-words. +;;; (defun maybe-make-logical-pattern (namestr start end) - "Take the ; reduced strings and break them into words and wildcard-words." - (declare (type simple-base-string namestr) - (type index start end)) + (declare (type (or symbol simple-base-string) namestr) + (type index start end) + (values (or null symbol pattern simple-base-string))) (collect ((pattern)) (let ((last-regular-char nil) (look-ahead+1 nil) @@ -1295,8 +1548,7 @@ (setf char (schar namestr index)) (cond ((or (char= #\. char) (char= #\; char)) ; End of pattern piece. (flush-pending-regulars)) - ((or (char= #\- char) ; Hyphen is a legal word character. - (alphanumericp char)) ; Building a word. + ((verify-word-char-p char) ; Building a word. (unless last-regular-char (setf last-regular-char index))) ((char= #\* char) ; Wildcard word, :wild or wildcard-inferior. @@ -1335,18 +1587,25 @@ (t (make-pattern (pattern))))))) -;;; INTERN-LOGICAL-HOST +;;; INTERN-LOGICAL-HOST -- Internal +;;; +;;; The name is a string. Put it in the hash table, return the logical-host. ;;; (defun intern-logical-host (name) (declare (simple-string name) (values logical-host)) - (let ((name (string-upcase name))) - (or (gethash name *logical-pathnames*) - (let ((new (make-logical-host :name name))) - (setf (gethash name *logical-pathnames*) new) - new)))) + (unless (logical-word-p name) + (error "Hostname ~S is not a legitimate logical word ~% + (consisting of uppercase letters, digits and hyphens)." name)) + (or (gethash name *logical-hosts*) + (let ((new (make-logical-host :name name))) + (setf (gethash name *logical-hosts*) new) + new))) -;;; EXTRACT-LOGICAL-NAME-TYPE-AND-VERSION +;;; EXTRACT-LOGICAL-NAME-TYPE-AND-VERSION -- Internal +;;; +;;; Return a set of three elements that can be any of patterns, strings, +;;; keywords, and integers. ;;; (defun extract-logical-name-type-and-version (namestr start end) (declare (type simple-base-string namestr) @@ -1394,18 +1653,18 @@ ;;; (defun logical-word-p (word) (declare (type simple-base-string word) - (values boolean)) + (values (or t null))) (let ((ch nil)) (dotimes (i (length word)) (setf ch (schar word i)) - (unless (or (alphanumericp ch) (eq ch #\-)) + (unless (or (upper-case-p ch) (digit-char-p ch) (eq ch #\-)) (return-from logical-word-p nil)))) t) ;;; MAYBE-EXTRACT-LOGICAL-HOST -- Internal -;;; Verify whether there is a logical host prefix in the namestr. If one is -;;; found return its name and the index of the remainder of the namestring. -;;; If not return nil. +;;; Verify whether there is a logical host or search-list prefix in the +;;; namestr. If one is found return its name and the index of the remainder of +;;; the namestring. If not return nil. ;;; (defun maybe-extract-logical-host (namestr start end) (declare (type simple-base-string namestr) @@ -1417,73 +1676,96 @@ (let ((host (subseq namestr start colon-pos))) (cond ((logical-word-p host) (return-from maybe-extract-logical-host - (values (string-upcase host) (1+ colon-pos)))) + (values host (1+ colon-pos)))) ((string= host "*") (return-from maybe-extract-logical-host - (values :wild (1+ colon-pos)))))) + (values :wild (1+ colon-pos)))) + (t (error "Host component ~S in namestring ~S is neither a ~ + wildcard (*),~%or a word formed from capital ~ + letters, digits and hyphens." host namestr)))) ;; Implied host (values nil 0)))) +;;; DECIDE-LOGICAL-HOST -- Internal +;;; +(defun decide-logical-host (host path-host defaults-host) + (declare (type (or null host simple-base-string stream) + host path-host defaults-host) + (values (or null logical-host))) + (with-host (host-struc host) + (with-host (path-host-struc path-host) + (with-host (defaults-host-struc defaults-host) + (if host-struc + host-struc + (if path-host-struc + path-host-struc + (if defaults-host-struc + defaults-host-struc + (error "None of ~S, ~S, or ~S is a logical-host" + host path-host defaults-host)))))))) + ;;; PARSE-LOGICAL-NAMESTRING -- Internal ;;; -;;; Break up a logical-namestring into its constituent parts. +;;; Break up a logical-namestring, always a string, into its constituent +;;; parts. ;;; -(defun parse-logical-namestring (namestr start end) - +(defun parse-logical-namestring (namestr + &key + host + (defaults *default-pathname-defaults*) + (start 0) + (end (length namestr))) (declare (type simple-base-string namestr) (type index start end) - (values (or logical-host null) - (or (member nil :unspecific) simple-base-string) - list - (or simple-base-string list pattern (member :wild)) - (or simple-string pattern null (member :unspecific :wild)) - (or integer null (member :newest :wild)))) - (multiple-value-bind ; Parse for : - (host place) - (maybe-extract-logical-host namestr start end) - (typecase host - (keyword t) ; :wild for example. - (simple-string ; Already a search-list element? - (unless (gethash (string-downcase host) *search-lists*) - (setf host (intern-logical-host host)))) - (null nil)) - (multiple-value-bind - (absolute pieces) - (split-at-slashes namestr place end #\;) - ;; Logical paths follow opposite convention of physical pathnames. - (setf absolute (not absolute)) - (multiple-value-bind (name type version) - (let* ((tail (car (last pieces))) - (tail-start (car tail)) - (tail-end (cdr tail))) - (unless (= tail-start tail-end) - (setf pieces (butlast pieces)) - (extract-logical-name-type-and-version - namestr tail-start tail-end))) - ;; Now we have everything we want. So return it. - (values host - :unspecific - (collect ((dirs)) - (dolist (piece pieces) - (let ((piece-start (car piece)) - (piece-end (cdr piece))) - (unless (= piece-start piece-end) - (let ((dir (maybe-make-logical-pattern namestr - piece-start - piece-end))) - (if (and (simple-string-p dir) - (string= dir "..")) - (dirs :up) - (dirs dir)))))) - (cond (absolute - (cons :absolute (dirs))) - ((dirs) - (cons :relative (dirs))) - (t - nil))) - name - type - version))))) + (type (or null simple-base-string logical-host stream) host) + (type pathname defaults) + (values (or null logical-pathname) (or null index))) + (let ((namestring (string-upcase namestr)) + (default-host (pathname-host defaults))) + ;; Parse for : prefixed hostname if present in namestr. + (multiple-value-bind (namestr-host place) + (maybe-extract-logical-host namestring start end) + ;; The explicit host argument is a logical host, or the host's name + ;; or the defaults provide the host, in that order. + (setf host (decide-logical-host host namestr-host default-host)) + (multiple-value-bind (absolute pieces) + (split-at-slashes namestring place end #\;) + ;; Logical paths follow opposite convention of physical pathnames. + (setf absolute (not absolute)) + (multiple-value-bind (name type version) + (let* ((tail (car (last pieces))) + (tail-start (car tail)) + (tail-end (cdr tail))) + (unless (= tail-start tail-end) + (setf pieces (butlast pieces)) + (extract-logical-name-type-and-version + namestring tail-start tail-end))) + ;; Now we have everything we want. Construct a logical pathname. + (%make-logical-pathname + host + nil + (collect ((dirs)) + (dolist (piece pieces) + (let ((piece-start (car piece)) + (piece-end (cdr piece))) + (unless (= piece-start piece-end) + (let ((dir + (maybe-make-logical-pattern namestring + piece-start + piece-end))) + (if (and (simple-string-p dir) + (string= dir "..")) + (dirs :up) + (dirs dir)))))) + (cond (absolute + (cons :absolute (dirs))) + ((dirs) + (cons :relative (dirs))) + (t + nil))) + name + type + version)))))) ;;; UNPARSE-LOGICAL-DIRECTORY-LIST -- Internal ;;; @@ -1513,8 +1795,8 @@ ;;; UNPARSE-LOGICAL-DIRECTORY -- Internal ;;; (defun unparse-logical-directory (pathname) - (declare (type pathname pathname)) - (unparse-logical-directory-list (%pathname-directory pathname))) + (declare (type logical-pathname pathname)) + (unparse-logical-directory-list (%logical-pathname-directory pathname))) ;;; UNPARSE-LOGICAL-PIECE -- Internal ;;; @@ -1559,7 +1841,6 @@ ;;; UNPARSE-LOGICAL-FILE -- Internal ;;; (defun unparse-logical-file (pathname) - (declare (type pathname pathname)) (declare (type pathname pathname)) (unparse-unix-file pathname)) @@ -1567,7 +1848,7 @@ ;;; (defun unparse-logical-host (pathname) (declare (type logical-pathname pathname)) - (logical-host-name (%pathname-host pathname))) + (logical-host-name (%logical-pathname-host pathname))) ;;; UNPARSE-LOGICAL-NAMESTRING -- Internal ;;; @@ -1580,46 +1861,52 @@ ;;; LOGICAL-PATHNAME -- Public ;;; -;;; Logical-pathname must signal a type error of type type-error. +;;; Logical-pathname must signal an error of type type-error. ;;; (defun logical-pathname (pathspec) "Converts the pathspec argument to a logical-pathname and returns it." - (declare (type (or logical-pathname string stream) pathspec) + (declare (type (or logical-pathname simple-base-string stream) pathspec) (values logical-pathname)) ;; Decide whether to typedef logical-pathname, logical-pathname-string, ;; or streams for which the pathname function returns a logical-pathname. - (cond ((logical-pathname-p pathspec) pathspec) - ((stringp pathspec) - (if (maybe-extract-logical-host pathspec 0 (length pathspec)) - (pathname pathspec) - (error "Pathspec is not a logical pathname prefaced by <host>:."))) - ((streamp pathspec) - (if (logical-pathname-p pathspec) - (pathname pathspec) - (error "Stream ~S is not a logical-pathname." pathspec))) - (t - (error "~S is not either ~% - a logical-pathname object, or~% - a logical pathname namestring, or~% - a stream named by a logical pathname." pathspec)))) - -;;; TRANSLATIONS-TEST-P + (etypecase pathspec + (logical-pathname pathspec) + (simple-base-string + (let* ((l-pathspec (length pathspec)) + (pathspec-host + (maybe-extract-logical-host pathspec 0 l-pathspec))) + (if pathspec-host + (parse-logical-namestring pathspec :host pathspec-host + :start 0 :end l-pathspec) + (error "Path specification ~S is not a logical pathname ~ + prefaced by <host>:." pathspec)))) + (stream + (let ((stream-type (type-of pathspec)) + (path-file (file-name pathspec))) + (unless (or (eq stream-type 'fd-stream) + (eq stream-type 'synonym-stream)) + (error "Stream ~S was created with other than OPEN, WITH-OPEN-FILE~ + or MAKE-SYNONYM-FILE." pathspec)) + (parse-logical-namestring path-file + :start 0 :end (length path-file)))))) + +;;; TRANSLATIONS-TEST-P -- Internal ;;; ;;; Verify that the list of translations consists of lists and prepare -;;; canonical translations from the pathnames. +;;; canonical translations (parse pathnames and expand out wildcards into +;;; patterns). ;;; (defun translations-test-p (transl-list host) (declare (type logical-host host) (type list transl-list) - (values boolean)) - (let ((can-transls nil)) - (setf can-transls (make-list (length transl-list)) - (logical-host-canon-transls host) can-transls) + (values (or t null))) + (let ((can-transls (make-list (length transl-list))); Canonical translations. + (c-tr nil)) + (setf (logical-host-canon-transls host) can-transls) (do* ((i 0 (1+ i)) (tr (nth i transl-list) (nth i transl-list)) (from-path (first tr) (first tr)) - (to-path (second tr) (second tr)) - (c-tr (nth i can-transls) (nth i can-transls))) + (to-path (second tr) (second tr))) ((<= (length transl-list) i)) (setf c-tr (make-list 2)) (if (logical-pathname-p from-path) @@ -1629,8 +1916,7 @@ (setf (second c-tr) to-path) (setf (second c-tr) (parse-namestring to-path))) ;; Verify form of translations. - (unless (and (or (logical-pathname-p from-path) - (first c-tr)) + (unless (and (or (logical-pathname-p from-path) (first c-tr)) (second c-tr)) (return-from translations-test-p nil)) (setf (nth i can-transls) c-tr))) @@ -1645,8 +1931,7 @@ (values list)) (etypecase host (simple-string - (setf host (string-upcase host)) - (let ((host-struc (gethash host *logical-pathnames*))) + (let ((host-struc (gethash (string-upcase host) *logical-hosts*))) (if host-struc (logical-host-translations host-struc) (error "HOST ~S is not defined." host)))) @@ -1661,22 +1946,25 @@ (declare (type (or simple-base-string logical-host) host) (type list translations) (values list)) + (setf host (string-upcase host)) (typecase host (simple-base-string - (setf host (string-upcase host)) + (unless (logical-word-p host) + (error "Hostname ~S is not a legitimate logical word ~% + (consisting of uppercase letters, digits and hyphens)." host)) (multiple-value-bind (hash-host xst?) - (gethash host *logical-pathnames*) + (gethash host *logical-hosts*) (unless xst? - (intern-logical-host host) - (setf hash-host (gethash host *logical-pathnames*))) + (setf hash-host (intern-logical-host host))) (unless (translations-test-p translations hash-host) (error "Translations ~S is not a list of pairs of from-, ~ to-pathnames." translations))) translations) (t + (format t "TRANSLATIONS-TEST-P args = ~S, ~S~%" translations host) (unless (translations-test-p translations host) - (error "Translations ~S is not a list of pairs of from-, ~ + (error "Translations ~S is not a list of pairs of from- and ~ to-pathnames." translations)) translations))) @@ -1698,7 +1986,7 @@ :name host :type "translations" :version :newest)) - (new-stuff (gethash host *logical-pathnames*)) + (new-stuff (gethash host *logical-hosts*)) (new-transl (logical-host-translations new-stuff))) (with-open-file (out-str p-name :direction :output @@ -1711,16 +1999,16 @@ ~S~% ~ for the host:~% ~ ~S.~%" p-name new-transl host)))) - +#| ;;; Define a SYS area for system dependent logical translations, should we -;;; ever want to use them. ########### Decision still need to made whether -;;; to take advantage of this area. +;;; ever want to use them. Not currently used in CMUCL. -#| (progn (intern-logical-host "SYS") (save-logical-pathname-translations "SYS" "library:")) + |# + ;;; LOAD-LOGICAL-PATHNAME-TRANSLATIONS -- Public ;;; (defun load-logical-pathname-translations (host) @@ -1729,13 +2017,13 @@ returned. If host is not already defined, but definition is found and loaded successfully, T is returned, else error." (declare (type simple-base-string host) - (values boolean)) + (values (or t null))) (setf host (string-upcase host)) (let ((p-name nil) (p-trans nil)) (multiple-value-bind (log-host xst?) - (gethash host *logical-pathnames*) + (gethash host *logical-hosts*) (if xst? ;; host already has a set of defined translations. (return-from load-logical-pathname-translations nil) @@ -1762,245 +2050,321 @@ ;;; COMPILE-FILE-PATHNAME -- Public ;;; (defun compile-file-pathname (file-path &key output-file) - (declare (type (or string stream pathname logical-pathname) file-path) - (type (or string stream pathname logical-pathname) output-file) - (values pathname)) - (with-pathname (path file-path) - (cond ((and (logical-pathname-p path) (not output-file)) - (make-pathname :host (%pathname-host path) - :directory (%pathname-directory path) - :device (%pathname-device path) - :name (%pathname-name path) - :type (c:backend-fasl-file-type c:*backend*))) - ((logical-pathname-p path) - (translate-logical-pathname path)) - (t file-path)))) - -;;; TRANSLATE-WILD-P -- Internal -;;; -(defmacro translate-wild-p (to-obj) - "Translate :wild?" - (declare (type keyword to-obj)) - `(etypecase ,to-obj - ((or (member :wild :unspecific nil :up :back) - string - pattern) - t))) + (declare (type path-designator file-path) + (type (or null pathname) output-file) + (values (or null pathname))) + (if (logical-pathname-p file-path) + (if output-file + (translate-logical-pathname file-path) + (%make-logical-pathname + (or (%logical-pathname-host file-path) + (%pathname-host *default-pathname-defaults*)) + nil + (or (%logical-pathname-directory file-path) + (%pathname-directory *default-pathname-defaults*)) + (or (%logical-pathname-name file-path) + (%pathname-name *default-pathname-defaults*)) + (c:backend-fasl-file-type c:*backend*) + (%pathname-version *default-pathname-defaults*))) + (with-pathname (path file-path) + path))) + +;;; TRANSLATE-LOGICAL-HOST -- Internal +;;; +(defun translate-logical-host (path-host from-host to-host) + "Pathname must contain a logical host or wild cards." + (declare (type (or logical-host host) path-host from-host to-host)) + (cond ((or (eq path-host from-host) (eq from-host :wild)) to-host) + (t (throw 'next-translation nil)))) + +(defmacro translate-absolute-relative (src from to) + "Translate :ABSOLUTE and RELATIVE keywords." + `(if (eq ,src ,from) + ,to + (throw 'next-translation nil))) + +(defmacro cleanup-to (from-context to-context result) + `(unless ,from-context + (setf ,result (append (reverse ,to-context) ,result)))) + +;;; TRANSLATE-DIR-ELEMENTS -- Internal +;;; +;;; The translation of pathnames occurs in two stages, the first produces an +;;; intermediate result upon which the second is repeated. +;;; The pathname result is a copy of the to element with each missing or +;;; wildcard field filled in by a portion of from and placed in result. +;;; If the to field is a :wild or :wild-inferiors, it is copied without any +;;; further action. Wildcard-inferiors in the from field set the wild-inf-flag +;;; and push the to field element onto the result, continuing until a match is +;;; found. +;;; +(defun translate-dir-elements (from from-context to to-context result + &optional wild-inf-flag) + "Translations are based on the element types of from and to, which can + recursively effect their repective contexts when they are :wild-inferiors." + (declare (type + (or null (member :wild :wild-inferiors) pattern + simple-base-string) + from to) + (type list from-context to-context) + (type (or null t) wild-inf-flag) + (values list list list)) + (let ((match-p nil) + (matches nil)) + (typecase from + (simple-base-string + (typecase to + (simple-base-string + (cond (wild-inf-flag + (push (string-downcase to) result) + (multiple-value-setq (from-context to-context result) + (translate-dir-elements from from-context + (pop to-context) to-context t))) + (t ; Clean up, include any untranslated to leftovers. + (push (string-downcase to) result) + (cleanup-to from-context to-context result)))) + (pattern + (multiple-value-setq (match-p matches) + (pattern-matches to from)) + (cond (match-p + (push (string-downcase from) result)) + (wild-inf-flag + (push (string-downcase from) result) + (multiple-value-setq (from-context to-context result) + (translate-dir-elements from from-context + (pop to-context) to-context t))) + (t + (throw 'next-translation nil)))) + ((member :wild :wild-inferiors) + ;; Clean up, include any untranslated to leftovers. + (push (string-downcase from) result) + (cleanup-to from-context to-context result)))) + (pattern + (typecase to + (simple-base-string + (multiple-value-setq (match-p matches) + (pattern-matches from to)) + (cond (match-p + (push (string-downcase to) result) + (cleanup-to from-context to-context result)) + (wild-inf-flag + (push (string-downcase to) result) + (multiple-value-setq (from-context to-context result) + (translate-dir-elements (pop from-context) from-context + to to-context t))) + (t + (throw 'next-translation nil)))) + (pattern + (cond ((and (pattern= from to) wild-inf-flag) + (push to result) + (multiple-value-setq (from-context to-context result) + (translate-dir-elements (pop from-context) from-context + to to-context t))) + ((pattern= from to) + ;; Clean up, include any untranslated to leftovers. + (push to result) + (cleanup-to from-context to-context result)) + (t + (throw 'next-translation nil)))) + ((member :wild :wild-inferiors) + (push to result) + ;; Clean up, include any untranslated to leftovers. + (cleanup-to from-context to-context result)))) + ((member :wild) + ;; Clean up, include any untranslated to leftovers. + (push to result) + (cleanup-to from-context to-context result)) + ((member :wild-inferiors) + (push to result) + (multiple-value-setq (from-context to-context result) + (translate-dir-elements (pop from-context) from-context + to to-context t)))) + (values from-context to-context result))) + +;;; TRANSLATE-DIRECTORY-LISTS -- Internal +;;; +;;; Translate through the lists of strings of subdirectories. +;;; +(defun translate-directory-lists (from to result) + (declare (type list from to result)) + (let ((from-el (pop from)) + (to-el (pop to))) + (cond (from-el + ;; There remains an untranslated element, translate it and the rest. + (multiple-value-setq (from to result) + (translate-dir-elements from-el from to-el to result)) + (translate-directory-lists from to result)) + (t ; Done. + (setf result (reverse result)))))) -;;; INTERMEDIATE-REP -- Internal +;;; TRANSLATE-LOGICAL-DIRECTORY -- Internal ;;; -(defun intermediate-rep (from to) - "A logical component transition function that translates from one argument - to the other. This function is specific to the CMUCL implementation." - (declare (type (or logical-host host simple-base-string pattern symbol list) - from) - (type (or logical-host host simple-base-string pattern symbol list) - to) - (values - (or logical-host host simple-base-string pattern list symbol))) - (etypecase from - (logical-host - (if (or (host-p to) (logical-host-p to)) - to)) - (host - (if (host-p to) - to)) - (simple-base-string - (etypecase to - (pattern - (multiple-value-bind - (won subs) - (pattern-matches to from) - (if won - (values (substitute-into to subs)) - (error "String ~S failed to match pattern ~S" from to)))) - (simple-base-string to) - ((member nil :wild :wild-inferiors) from))) - (pattern - (etypecase to - (pattern - (if (pattern= to from) - to - (error "Patterns ~S and ~S do not match."))))) - ((member :absolute :relative) - (if (eq to from) - to - (error "The directory bases (FROM = ~S, TO = ~S) for the logical ~%~ - pathname translation are not consistently relative or absolute." from to))) - ((member :wild) - (etypecase to - ((or string - pattern - (member nil :unspecific :newest :wild :wild-inferiors)) - to))) - ((member :wild-inferiors) ; Only when single directory component. - (etypecase to - ((or string pattern cons (member nil :unspecific :wild :wild-inferiors)) - to))) - ((member :unspecific nil) - from) - ((member :newest) - (case to - (:wild from) - (:unspecific :unspecific) - (:newest to) - ((member nil) from))))) - -(proclaim '(inline translate-logical-component)) - -;;; TRANSLATE-LOGICAL-COMPONENT -- Internal +;;; Translate logical directories within the UNIX hierarchical file system, +;;; which does not directly support :wildcard-inferiors. Here :wild-inferiors +;;; are allowed in a restricted form. The translation table is based on matching +;;; first the source (src) directory component with the from directory +;;; components, and if successful constructing result directory components. +;;; If this is successful, then the result is matched relative to the the to-dir +;;; and a possible translated result is generated. ;;; -(defun translate-logical-component (source from to) - (intermediate-rep (intermediate-rep source from) to)) +(defun translate-logical-directory (src-dirs from-dirs to-dirs) + (declare (type list src-dirs from-dirs to-dirs) + (values list)) + (let ((result-dirs nil) + (transl-dirs nil)) + ;; Cope with possible null directory lists. + (cond ((and (null src-dirs) (null from-dirs)) + (return-from translate-logical-directory to-dirs)) + ((or (null src-dirs) (null from-dirs)) + (throw 'next-translation nil))) + ;; Compute the intermediate result by matching the source-dirs + ;; components with the from-dirs and placing the result in the result-dirs + ;; if the match is successful, otherwise throw to the next translation. + (setf result-dirs + (translate-directory-lists (rest src-dirs) (rest from-dirs) + result-dirs) + transl-dirs + (translate-directory-lists result-dirs (rest to-dirs) + transl-dirs)) + (setf result-dirs (translate-absolute-relative + (first src-dirs) (first from-dirs) transl-dirs)) + (if result-dirs + (push (translate-absolute-relative + (first src-dirs) (first from-dirs) (first to-dirs)) + transl-dirs)) + transl-dirs)) + +;;; TRANSLATE-LOGICAL-COMP-ELEMENT -- Internal +;;; +(defun translate-logical-comp-element (from to) + (declare (type (or pattern simple-base-string fixnum symbol null) from to)) + (let ((match-p nil) + (matches nil)) + (typecase from + (simple-base-string + (typecase to + (simple-base-string + (string-downcase to)) + (fixnum + (throw 'next-translation nil)) + ((member :newest :wild nil) + (string-downcase from)) + (pattern + (multiple-value-setq (match-p matches) + (pattern-matches to from)) + (if match-p + (substitute-into to matches :case :lower) + (throw 'next-translation nil))))) + (fixnum + (typecase to + (fixnum + (if (<= from to) + to + from)) + ((member :newest :wild nil) + to) + (pattern + (case (first (pattern-pieces to)) + ((or :wild :newest) to) + (t (throw 'next-translation nil)))))) + ((member :wild :newest nil) + to) + (pattern + (typecase to + (simple-base-string + (multiple-value-setq (match-p matches) + (pattern-matches from to)) + (if match-p + (substitute-into from matches :case :lower) + (throw 'next-translation nil))) + (fixnum + (case (first (pattern-pieces from)) + ((or :wild :newest) to) + (t (throw 'next-translation nil)))) + ((member :newest :wild nil) + to) + (pattern + (if (pattern= from to) + to + (throw 'next-translation nil)))))))) -;;; TRANSLATE-LOGICAL-DIRECTORY -- Internal +;;; TRANSLATE-LOGICAL-COMPONENT -- Internal ;;; -;;; Translate logical directories within the UNIX heirarchical file system. -;;; -(defun translate-logical-directory (source from to) - ;; Handle unfilled components. - (if (or (eql source :UNSPECIFIC) - (eql from :UNSPECIFIC) - (eql to :UNSPECIFIC)) - (return-from translate-logical-directory :UNSPECIFIC)) - (if (or (not source) (not from) (not to)) - (return-from translate-logical-directory nil)) - ;; Handle directory component abbreviated as a wildcard. - (if (member source '(:WILD :WILD-INFERIORS)) - (setf source '(:ABSOLUTE :WILD-INFERIORS))) - (if (member source '(:WILD :WILD-INFERIORS)) - (setf source '(:ABSOLUTE :WILD-INFERIORS))) - (if (member source '(:WILD :WILD-INFERIORS)) - (setf to '(:ABSOLUTE :WILD-INFERIORS))) - ;; Make two stage translation, storing the intermediate results in ires - ;; and finally returned in the list rres. - (let ((ires nil) - (rres nil) - (dummy nil) - (slen (length source)) - (flen (length from)) - (tlen (length to))) - (do* ((i 0 (1+ i)) - (j 0 (1+ j)) - (k 0) - (s-el (nth i source) (nth i source)) - (s-next-el nil) - (f-el (nth j from) (nth j from))) - ((<= slen i)) - (cond ((eq s-el :wild-inferiors) - (setf s-next-el (nth (+ 1 i) source)) ; NIL if beyond end. - (cond ((setf k (position s-next-el from :start (1+ j))) - ;; Found it, splice this portion into ires. - (setf ires - (append ires - (subseq from j (1- k))) - j (1- k))) - (t - ;; Either did not find next source element in from, - ;; or was nil. - (setf ires - (append ires - (subseq from j flen))) - (unless (= i (1- slen)) - (error "Source ~S inconsistent with from translation ~ - ~S~%." source from))))) - (t - (setf ires (append ires (list (intermediate-rep s-el f-el))))))) - ;; Remember to add leftover elements of from. - (if (< slen flen) - (setf ires (append ires (last from (- flen slen))))) - (do* ((i 0 (1+ i)) - (j 0 (1+ j)) - (k 0) - (irlen (length ires)) - (ir-el (nth i ires) (nth i ires)) - (ir-next-el nil) - (t-el (nth j to) (nth j to))) - ((<= tlen i)) - ;; Remember to add leftover elements of to. - (cond ((eq ir-el :wild-inferiors) - (setf ir-next-el (nth (+ 1 i) ires)) ; NIL if beyond end. - (cond ((setf k (position ir-next-el from :start (1+ j))) - ;; Found it, splice this portion into rres. - (setf rres - (append rres - (subseq from j (1- k))) - j (1- k))) - (t - ;; Either did not find next source element in from, - ;; or was nil. - (setf rres - (append rres - (subseq from j tlen))) - (unless (= i (1- irlen)) - (error "Intermediate path ~S inconsistent with to~ - translation ~S~%." ires to))))) - (t (if (setf dummy (intermediate-rep ir-el t-el)) - (setf rres (append rres (list dummy))))))) - (if (< flen tlen) - (setf rres (append rres (last to (- tlen flen))))) - rres)) - -;;; A physical-pathname is a pathname that does not contain any wildcards, -;;; but is not a logical-pathname. - -(deftype physical-pathname () - '(and (satisfies pathnamep) - (not (or (satisfies wild-pathname-p) - (satisfies logical-pathname-p))))) +(defun translate-logical-component (src from to) + (declare (type (or pattern simple-base-string fixnum symbol null) from to)) + (translate-logical-comp-element (translate-logical-comp-element src from) to)) ;;; TRANSLATE-LOGICAL-PATHNAME -- Public ;;; (defun translate-logical-pathname (pathname &key) "Translates pathname to a physical pathname, which is returned." - (declare (type logical-pathname pathname)) - (with-pathname (source pathname) - (etypecase source - (physical-pathname source) - (logical-pathname - (let ((source-host (%pathname-host source)) - (result-path nil)) - (unless (gethash - (funcall (logical-host-unparse-host source-host) source) - *logical-pathnames*) + (declare (type path-designator pathname) + (values (or null pathname))) + (with-pathname (source pathname) + (when (logical-pathname-p source) + (let ((p-host (%pathname-host source)) + (from nil) + (to nil) + (tr-host nil) + (tr-dir nil) + (tr-name nil) + (tr-type nil) + (tr-version nil) + (result-path nil) + (src-transl nil) + (i 0)) + (declare (type fixnum i) + (type (or pathname null) result-path)) + ;; Verify that the logical-host is defined. + (unless (gethash (funcall (logical-host-unparse-host p-host) source) + *logical-hosts*) (error "The logical host ~S is not defined.~%" - (logical-host-name source-host))) - (dolist (src-transl (logical-host-canon-transls source-host) - (error "~S has no matching translation for ~ - logical host ~S.~%" - pathname (logical-host-name source-host))) - (when (pathname-match-p source (first src-transl)) - (macrolet ((frob (field) - `(let* ((from (first src-transl)) - (to (second src-transl)) - (result (translate-logical-component - (,field source) - (,field from) - (,field to)))) - result))) - (setf result-path - (%make-pathname (frob %pathname-host) - :unspecific - (let* ((from (first src-transl)) - (to (second src-transl)) - (result - (translate-logical-directory - (%pathname-directory source) - (%pathname-directory from) - (%pathname-directory to)))) - (if (eq result :error) - (error "~S doesn't match ~S" - source from) - result)) - (frob %pathname-name) - (frob %pathname-type) - (frob %pathname-version)))) - (etypecase result-path - (logical-pathname - (translate-logical-pathname result-path)) - (physical-pathname - (return-from translate-logical-pathname result-path)))))))))) - + (logical-host-name p-host))) + ;; Scan the pathname translations, and if none is found signal error. + (loop + (catch 'next-translation + (setf src-transl (nth i (logical-host-canon-transls p-host))) + (incf i) + (unless src-transl + (error "~S has no matching translation for logical host ~S.~%" + pathname (logical-host-name p-host))) + (setf from (first src-transl) + to (second src-transl)) + (when (pathname-match-p pathname from) + (setf tr-host (translate-logical-host + p-host + (%pathname-host from) + (%pathname-host to)) + tr-dir (translate-logical-directory + (%pathname-directory source) + (%pathname-directory from) + (%pathname-directory to)) + tr-name (translate-logical-component + (%pathname-name source) + (%pathname-name from) + (%pathname-name to)) + tr-type (translate-logical-component + (%pathname-type source) + (%pathname-type from) + (%pathname-type to)) + tr-version (translate-logical-component + (%pathname-version source) + (%pathname-version from) + (%pathname-version to)) + result-path (%make-pathname tr-host + :unspecific + tr-dir + tr-name + tr-type + tr-version)) + (etypecase result-path + (logical-pathname + (translate-logical-pathname result-path)) + (pathname + (return-from translate-logical-pathname result-path)) + (null + (error "The logical path ~S could not be translated." + pathname)))))))))) -- GitLab