X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Ftarget-pathname.lisp;h=ff023ee7cc604f7862979d41d70af838483964df;hb=71bc8b09fc75083ea4bb2aee954abca1f1e1f214;hp=7089003a9a103a382eaef7d14782c3bf2500fde5;hpb=1b64697e4e8a85ff8f11f5c05de71687dc5ad2e2;p=sbcl.git diff --git a/src/code/target-pathname.lisp b/src/code/target-pathname.lisp index 7089003..ff023ee 100644 --- a/src/code/target-pathname.lisp +++ b/src/code/target-pathname.lisp @@ -13,72 +13,80 @@ #!-sb-fluid (declaim (freeze-type logical-pathname logical-host)) -;;;; UNIX-HOST stuff +;;;; PHYSICAL-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)))) - + (:make-load-form-fun make-unix-host-load-form) + (:include host + (parse #'parse-unix-namestring) + (parse-native #'parse-native-unix-namestring) + (unparse #'unparse-unix-namestring) + (unparse-native #'unparse-native-unix-namestring) + (unparse-host #'unparse-unix-host) + (unparse-directory #'unparse-physical-directory) + (unparse-file #'unparse-unix-file) + (unparse-enough #'unparse-unix-enough) + (unparse-directory-separator "/") + (simplify-namestring #'simplify-unix-namestring) + (customary-case :lower)))) (defvar *unix-host* (make-unix-host)) - (defun make-unix-host-load-form (host) (declare (ignore host)) '*unix-host*) +(def!struct (win32-host + (:make-load-form-fun make-win32-host-load-form) + (:include host + (parse #'parse-win32-namestring) + (parse-native #'parse-native-win32-namestring) + (unparse #'unparse-win32-namestring) + (unparse-native #'unparse-native-win32-namestring) + (unparse-host #'unparse-win32-host) + (unparse-directory #'unparse-physical-directory) + (unparse-file #'unparse-win32-file) + (unparse-enough #'unparse-win32-enough) + (unparse-directory-separator "\\") + (simplify-namestring #'simplify-win32-namestring) + (customary-case :upper)))) +(defparameter *win32-host* (make-win32-host)) +(defun make-win32-host-load-form (host) + (declare (ignore host)) + '*win32-host*) + +(defvar *physical-host* + #!-win32 *unix-host* + #!+win32 *win32-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)) + (%make-pathname *physical-host* nil nil nil nil :newest)) ;;; pathname methods (def!method print-object ((pathname pathname) stream) (let ((namestring (handler-case (namestring pathname) - (error nil)))) + (error nil)))) (if namestring - (format stream "#P~S" namestring) - (print-unreadable-object (pathname stream :type t) - (format stream - "~@<(with no namestring) ~_:HOST ~S ~_:DEVICE ~S ~_:DIRECTORY ~S ~ - ~_:NAME ~S ~_:TYPE ~S ~_:VERSION ~S~:>" - (%pathname-host pathname) - (%pathname-device pathname) - (%pathname-directory pathname) - (%pathname-name pathname) - (%pathname-type pathname) - (%pathname-version pathname)))))) + (format stream + (if (or *print-readably* *print-escape*) + "#P~S" + "~A") + (coerce namestring '(simple-array character (*)))) + (print-unreadable-object (pathname stream :type t) + (format stream + "~@<(with no namestring) ~_:HOST ~S ~_:DEVICE ~S ~_:DIRECTORY ~S ~ + ~_:NAME ~S ~_:TYPE ~S ~_:VERSION ~S~:>" + (%pathname-host pathname) + (%pathname-device pathname) + (%pathname-directory pathname) + (%pathname-name pathname) + (%pathname-type pathname) + (%pathname-version pathname)))))) (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 -;;; ). -;;; -;;; 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)))))) ;;; A pathname is logical if the host component is a logical host. ;;; This constructor is used to make an instance of the correct type @@ -91,17 +99,19 @@ ;; case, and uppercase is the ordinary way to do that. (flet ((upcase-maybe (x) (typecase x (string (logical-word-or-lose x)) (t x)))) (if (typep host 'logical-host) - (%make-logical-pathname host - :unspecific - (mapcar #'upcase-maybe directory) - (upcase-maybe name) - (upcase-maybe type) - version) - (%make-pathname host device directory name type version)))) + (%make-logical-pathname host + :unspecific + (mapcar #'upcase-maybe directory) + (upcase-maybe name) + (upcase-maybe type) + version) + (progn + (aver (eq host *physical-host*)) + (%make-pathname host device directory name type version))))) ;;; Hash table searching maps a logical pathname's host to its ;;; physical pathname translation. -(defvar *logical-hosts* (make-hash-table :test 'equal)) +(defvar *logical-hosts* (make-hash-table :test 'equal :synchronized t)) ;;;; patterns @@ -111,83 +121,83 @@ (def!method print-object ((pattern pattern) stream) (print-unreadable-object (pattern stream :type t) (if *print-pretty* - (let ((*print-escape* t)) - (pprint-fill stream (pattern-pieces pattern) nil)) - (prin1 (pattern-pieces pattern) stream)))) + (let ((*print-escape* t)) + (pprint-fill stream (pattern-pieces pattern) nil)) + (prin1 (pattern-pieces pattern) stream)))) (defun pattern= (pattern1 pattern2) (declare (type pattern pattern1 pattern2)) (let ((pieces1 (pattern-pieces pattern1)) - (pieces2 (pattern-pieces pattern2))) + (pieces2 (pattern-pieces pattern2))) (and (= (length pieces1) (length pieces2)) - (every (lambda (piece1 piece2) - (typecase piece1 - (simple-string - (and (simple-string-p piece2) - (string= piece1 piece2))) - (cons - (and (consp piece2) - (eq (car piece1) (car piece2)) - (string= (cdr piece1) (cdr piece2)))) - (t - (eq piece1 piece2)))) - pieces1 - pieces2)))) + (every (lambda (piece1 piece2) + (typecase piece1 + (simple-string + (and (simple-string-p piece2) + (string= piece1 piece2))) + (cons + (and (consp piece2) + (eq (car piece1) (car piece2)) + (string= (cdr piece1) (cdr piece2)))) + (t + (eq piece1 piece2)))) + pieces1 + pieces2)))) ;;; If the string matches the pattern returns the multiple values T ;;; and a list of the matched strings. (defun pattern-matches (pattern string) (declare (type pattern pattern) - (type simple-string string)) + (type simple-string string)) (let ((len (length string))) (labels ((maybe-prepend (subs cur-sub chars) - (if cur-sub - (let* ((len (length chars)) - (new (make-string len)) - (index len)) - (dolist (char chars) - (setf (schar new (decf index)) char)) - (cons new subs)) - subs)) - (matches (pieces start subs cur-sub chars) - (if (null pieces) - (if (= start len) - (values t (maybe-prepend subs cur-sub chars)) - (values nil nil)) - (let ((piece (car pieces))) - (etypecase piece - (simple-string - (let ((end (+ start (length piece)))) - (and (<= end len) - (string= piece string - :start2 start :end2 end) - (matches (cdr pieces) end - (maybe-prepend subs cur-sub chars) - nil nil)))) - (list - (ecase (car piece) - (:character-set - (and (< start len) - (let ((char (schar string start))) - (if (find char (cdr piece) :test #'char=) - (matches (cdr pieces) (1+ start) subs t - (cons char chars)))))))) - ((member :single-char-wild) - (and (< start len) - (matches (cdr pieces) (1+ start) subs t - (cons (schar string start) chars)))) - ((member :multi-char-wild) - (multiple-value-bind (won new-subs) - (matches (cdr pieces) start subs t chars) - (if won - (values t new-subs) - (and (< start len) - (matches pieces (1+ start) subs t - (cons (schar string start) - chars))))))))))) + (if cur-sub + (let* ((len (length chars)) + (new (make-string len)) + (index len)) + (dolist (char chars) + (setf (schar new (decf index)) char)) + (cons new subs)) + subs)) + (matches (pieces start subs cur-sub chars) + (if (null pieces) + (if (= start len) + (values t (maybe-prepend subs cur-sub chars)) + (values nil nil)) + (let ((piece (car pieces))) + (etypecase piece + (simple-string + (let ((end (+ start (length piece)))) + (and (<= end len) + (string= piece string + :start2 start :end2 end) + (matches (cdr pieces) end + (maybe-prepend subs cur-sub chars) + nil nil)))) + (list + (ecase (car piece) + (:character-set + (and (< start len) + (let ((char (schar string start))) + (if (find char (cdr piece) :test #'char=) + (matches (cdr pieces) (1+ start) subs t + (cons char chars)))))))) + ((member :single-char-wild) + (and (< start len) + (matches (cdr pieces) (1+ start) subs t + (cons (schar string start) chars)))) + ((member :multi-char-wild) + (multiple-value-bind (won new-subs) + (matches (cdr pieces) start subs t chars) + (if won + (values t new-subs) + (and (< start len) + (matches pieces (1+ start) subs t + (cons (schar string start) + chars))))))))))) (multiple-value-bind (won subs) - (matches (pattern-pieces pattern) 0 nil nil nil) - (values won (reverse subs)))))) + (matches (pattern-pieces pattern) 0 nil nil nil) + (values won (reverse subs)))))) ;;; PATHNAME-MATCH-P for directory components (defun directory-components-match (thing wild) @@ -196,23 +206,23 @@ ;; If THING has a null directory, assume that it matches ;; (:ABSOLUTE :WILD-INFERIORS) or (:RELATIVE :WILD-INFERIORS). (and (consp wild) - (null thing) - (member (first wild) '(:absolute :relative)) - (eq (second wild) :wild-inferiors)) + (null thing) + (member (first wild) '(:absolute :relative)) + (eq (second wild) :wild-inferiors)) (and (consp wild) - (let ((wild1 (first wild))) - (if (eq wild1 :wild-inferiors) - (let ((wild-subdirs (rest wild))) - (or (null wild-subdirs) - (loop - (when (directory-components-match thing wild-subdirs) - (return t)) - (pop thing) - (unless thing (return nil))))) - (and (consp thing) - (components-match (first thing) wild1) - (directory-components-match (rest thing) - (rest wild)))))))) + (let ((wild1 (first wild))) + (if (eq wild1 :wild-inferiors) + (let ((wild-subdirs (rest wild))) + (or (null wild-subdirs) + (loop + (when (directory-components-match thing wild-subdirs) + (return t)) + (pop thing) + (unless thing (return nil))))) + (and (consp thing) + (components-match (first thing) wild1) + (directory-components-match (rest thing) + (rest wild)))))))) ;;; Return true if pathname component THING is matched by WILD. (not ;;; commutative) @@ -221,212 +231,282 @@ (or (eq thing wild) (eq wild :wild) (typecase thing - (simple-base-string - ;; String is matched by itself, a matching pattern or :WILD. - (typecase wild - (pattern - (values (pattern-matches wild thing))) - (simple-base-string - (string= thing wild)))) - (pattern - ;; A pattern is only matched by an identical pattern. - (and (pattern-p wild) (pattern= thing wild))) - (integer - ;; An integer (version number) is matched by :WILD or the - ;; same integer. This branch will actually always be NIL as - ;; long as the version is a fixnum. - (eql thing wild))))) + (simple-string + ;; String is matched by itself, a matching pattern or :WILD. + (typecase wild + (pattern + (values (pattern-matches wild thing))) + (simple-string + (string= thing wild)))) + (pattern + ;; A pattern is only matched by an identical pattern. + (and (pattern-p wild) (pattern= thing wild))) + (integer + ;; An integer (version number) is matched by :WILD or the + ;; same integer. This branch will actually always be NIL as + ;; long as the version is a fixnum. + (eql thing wild))))) ;;; a predicate for comparing two pathname slot component sub-entries (defun compare-component (this that) (or (eql this that) (typecase this - (simple-string - (and (simple-string-p that) - (string= this that))) - (pattern - (and (pattern-p that) - (pattern= this that))) - (cons - (and (consp that) - (compare-component (car this) (car that)) - (compare-component (cdr this) (cdr that))))))) + (simple-string + (and (simple-string-p that) + (string= this that))) + (pattern + (and (pattern-p that) + (pattern= this that))) + (cons + (and (consp that) + (compare-component (car this) (car that)) + (compare-component (cdr this) (cdr that))))))) ;;;; pathname functions (defun pathname= (pathname1 pathname2) (declare (type pathname pathname1) - (type pathname pathname2)) + (type pathname pathname2)) (and (eq (%pathname-host pathname1) - (%pathname-host pathname2)) + (%pathname-host pathname2)) (compare-component (%pathname-device pathname1) - (%pathname-device pathname2)) + (%pathname-device pathname2)) (compare-component (%pathname-directory pathname1) - (%pathname-directory pathname2)) + (%pathname-directory pathname2)) (compare-component (%pathname-name pathname1) - (%pathname-name pathname2)) + (%pathname-name pathname2)) (compare-component (%pathname-type pathname1) - (%pathname-type pathname2)) - (compare-component (%pathname-version pathname1) - (%pathname-version pathname2)))) + (%pathname-type 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. ;;; ;;; FIXME: was rewritten, should be tested (or rewritten again, this ;;; time using ONCE-ONLY, *then* tested) -;;; FIXME: become SB!XC:DEFMACRO inside EVAL-WHEN (COMPILE EVAL)? -(defmacro with-pathname ((pathname pathname-designator) &body body) +(eval-when (:compile-toplevel :execute) +(sb!xc:defmacro with-pathname ((pathname pathname-designator) &body body) (let ((pd0 (gensym))) `(let* ((,pd0 ,pathname-designator) - (,pathname (etypecase ,pd0 - (pathname ,pd0) - (string (parse-namestring ,pd0)) - (file-stream (file-name ,pd0))))) + (,pathname (etypecase ,pd0 + (pathname ,pd0) + (string (parse-namestring ,pd0)) + (file-stream (file-name ,pd0))))) ,@body))) -;;; Convert the var, a host or string name for a host, into a -;;; LOGICAL-HOST structure or nil if not defined. -;;; -;;; pw notes 1/12/97 this potentially useful macro is not used anywhere -;;; and 'find-host' is not defined. 'find-logical-host' seems to be needed. -#| -(defmacro with-host ((var expr) &body body) - `(let ((,var (let ((,var ,expr)) - (typecase ,var - (logical-host ,var) - (string (find-logical-host ,var nil)) - (t nil))))) - ,@body)) -|# - -(defun pathname (thing) +(sb!xc:defmacro with-native-pathname ((pathname pathname-designator) &body body) + (let ((pd0 (gensym))) + `(let* ((,pd0 ,pathname-designator) + (,pathname (etypecase ,pd0 + (pathname ,pd0) + (string (parse-native-namestring ,pd0)) + ;; FIXME + #+nil + (file-stream (file-name ,pd0))))) + ,@body))) + +(sb!xc:defmacro with-host ((host host-designator) &body body) + ;; Generally, redundant specification of information in software, + ;; whether in code or in comments, is bad. However, the ANSI spec + ;; for this is messy enough that it's hard to hold in short-term + ;; memory, so I've recorded these redundant notes on the + ;; implications of the ANSI spec. + ;; + ;; According to the ANSI spec, HOST can be a valid pathname host, or + ;; a logical host, or NIL. + ;; + ;; A valid pathname host can be a valid physical pathname host or a + ;; valid logical pathname host. + ;; + ;; A valid physical pathname host is "any of a string, a list of + ;; strings, or the symbol :UNSPECIFIC, that is recognized by the + ;; implementation as the name of a host". In SBCL as of 0.6.9.8, + ;; that means :UNSPECIFIC: though someday we might want to + ;; generalize it to allow strings like "RTFM.MIT.EDU" or lists like + ;; '("RTFM" "MIT" "EDU"), that's not supported now. + ;; + ;; A valid logical pathname host is a string which has been defined as + ;; the name of a logical host, as with LOAD-LOGICAL-PATHNAME-TRANSLATIONS. + ;; + ;; A logical host is an object of implementation-dependent nature. In + ;; SBCL, it's a member of the HOST class (a subclass of STRUCTURE-OBJECT). + (let ((hd0 (gensym))) + `(let* ((,hd0 ,host-designator) + (,host (etypecase ,hd0 + ((string 0) + ;; This is a special host. It's not valid as a + ;; logical host, so it is a sensible thing to + ;; designate the physical host object. So we do + ;; that. + *physical-host*) + (string + ;; In general ANSI-compliant Common Lisps, a + ;; string might also be a physical pathname + ;; host, but ANSI leaves this up to the + ;; implementor, and in SBCL we don't do it, so + ;; it must be a logical host. + (find-logical-host ,hd0)) + ((or null (member :unspecific)) + ;; CLHS says that HOST=:UNSPECIFIC has + ;; implementation-defined behavior. We + ;; just turn it into NIL. + nil) + (list + ;; ANSI also allows LISTs to designate hosts, + ;; but leaves its interpretation + ;; implementation-defined. Our interpretation + ;; is that it's unsupported.:-| + (error "A LIST representing a pathname host is not ~ + supported in this implementation:~% ~S" + ,hd0)) + (host ,hd0)))) + ,@body))) +) ; EVAL-WHEN + +(defun find-host (host-designator &optional (errorp t)) + (with-host (host host-designator) + (when (and errorp (not host)) + (error "Couldn't find host: ~S" host-designator)) + host)) + +(defun pathname (pathspec) + #!+sb-doc + "Convert PATHSPEC (a pathname designator) into a pathname." + (declare (type pathname-designator pathspec)) + (with-pathname (pathname pathspec) + pathname)) + +(defun native-pathname (pathspec) #!+sb-doc - "Convert thing (a pathname, string or stream) into a pathname." - (declare (type pathname-designator thing)) - (with-pathname (pathname thing) + "Convert PATHSPEC (a pathname designator) into a pathname, assuming +the operating system native pathname conventions." + (with-native-pathname (pathname pathspec) pathname)) ;;; Change the case of thing if DIDDLE-P. (defun maybe-diddle-case (thing diddle-p) (if (and diddle-p (not (or (symbolp thing) (integerp thing)))) (labels ((check-for (pred in) - (typecase in - (pattern - (dolist (piece (pattern-pieces in)) - (when (typecase piece - (simple-string - (check-for pred piece)) - (cons - (case (car in) - (:character-set - (check-for pred (cdr in)))))) - (return t)))) - (list - (dolist (x in) - (when (check-for pred x) - (return t)))) - (simple-base-string - (dotimes (i (length in)) - (when (funcall pred (schar in i)) - (return t)))) - (t nil))) - (diddle-with (fun thing) - (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))) - (pattern-pieces thing)))) - (list - (mapcar fun thing)) - (simple-base-string - (funcall fun thing)) - (t - thing)))) - (let ((any-uppers (check-for #'upper-case-p thing)) - (any-lowers (check-for #'lower-case-p thing))) - (cond ((and any-uppers any-lowers) - ;; mixed case, stays the same - thing) - (any-uppers - ;; all uppercase, becomes all lower case - (diddle-with (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)) - (t - ;; no letters? I guess just leave it. - thing)))) + (typecase in + (pattern + (dolist (piece (pattern-pieces in)) + (when (typecase piece + (simple-string + (check-for pred piece)) + (cons + (case (car piece) + (:character-set + (check-for pred (cdr piece)))))) + (return t)))) + (list + (dolist (x in) + (when (check-for pred x) + (return t)))) + (simple-string + (dotimes (i (length in)) + (when (funcall pred (schar in i)) + (return t)))) + (t nil))) + (diddle-with (fun thing) + (typecase thing + (pattern + (make-pattern + (mapcar (lambda (piece) + (typecase piece + (simple-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)) + (simple-string + (funcall fun thing)) + (t + thing)))) + (let ((any-uppers (check-for #'upper-case-p thing)) + (any-lowers (check-for #'lower-case-p thing))) + (cond ((and any-uppers any-lowers) + ;; mixed case, stays the same + thing) + (any-uppers + ;; all uppercase, becomes all lower case + (diddle-with (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)) + (t + ;; no letters? I guess just leave it. + thing)))) thing)) (defun merge-directories (dir1 dir2 diddle-case) (if (or (eq (car dir1) :absolute) - (null dir2)) + (null dir2)) dir1 (let ((results nil)) - (flet ((add (dir) - (if (and (eq dir :back) - results - (not (eq (car results) :back))) - (pop results) - (push dir results)))) - (dolist (dir (maybe-diddle-case dir2 diddle-case)) - (add dir)) - (dolist (dir (cdr dir1)) - (add dir))) - (reverse results)))) + (flet ((add (dir) + (if (and (eq dir :back) + results + (not (member (car results) + '(:back :wild-inferiors :relative :absolute)))) + (pop results) + (push dir results)))) + (dolist (dir (maybe-diddle-case dir2 diddle-case)) + (add dir)) + (dolist (dir (cdr dir1)) + (add dir))) + (reverse results)))) (defun merge-pathnames (pathname - &optional - (defaults *default-pathname-defaults*) - (default-version :newest)) + &optional + (defaults *default-pathname-defaults*) + (default-version :newest)) #!+sb-doc "Construct a filled in pathname by completing the unspecified components from the defaults." (declare (type pathname-designator pathname) - (type pathname-designator defaults) - (values pathname)) + (type pathname-designator defaults) + (values pathname)) (with-pathname (defaults defaults) (let ((pathname (let ((*default-pathname-defaults* defaults)) - (pathname pathname)))) + (pathname pathname)))) (let* ((default-host (%pathname-host defaults)) - (pathname-host (%pathname-host pathname)) - (diddle-case - (and default-host pathname-host - (not (eq (host-customary-case default-host) - (host-customary-case pathname-host)))))) - (%make-maybe-logical-pathname - (or pathname-host default-host) - (or (%pathname-device pathname) - (maybe-diddle-case (%pathname-device defaults) - diddle-case)) - (merge-directories (%pathname-directory pathname) - (%pathname-directory defaults) - diddle-case) - (or (%pathname-name pathname) - (maybe-diddle-case (%pathname-name defaults) - diddle-case)) - (or (%pathname-type pathname) - (maybe-diddle-case (%pathname-type defaults) - diddle-case)) - (or (%pathname-version pathname) - default-version)))))) + (pathname-host (%pathname-host pathname)) + (diddle-case + (and default-host pathname-host + (not (eq (host-customary-case default-host) + (host-customary-case pathname-host)))))) + (%make-maybe-logical-pathname + (or pathname-host default-host) + (or (%pathname-device pathname) + (maybe-diddle-case (%pathname-device defaults) + diddle-case)) + (merge-directories (%pathname-directory pathname) + (%pathname-directory defaults) + diddle-case) + (or (%pathname-name pathname) + (maybe-diddle-case (%pathname-name defaults) + diddle-case)) + (or (%pathname-type pathname) + (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) (etypecase directory @@ -435,118 +515,122 @@ ((member :unspecific) '(:relative)) (list (collect ((results)) - (results (pop directory)) - (dolist (piece directory) - (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))) - ((stringp piece) - (results (maybe-diddle-case (coerce piece 'simple-string) - diddle-case))) - (t - (error "~S is not allowed as a directory component." piece)))) + (let ((root (pop directory))) + (if (member root '(:relative :absolute)) + (results root) + (error "List of directory components must start with ~S or ~S." + :absolute :relative))) + (when directory + (let ((next (pop directory))) + (if (or (eq :home next) + (typep next '(cons (eql :home) (cons string null)))) + (results next) + (push next directory))) + (dolist (piece directory) + (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))) + ((stringp piece) + (results (maybe-diddle-case (coerce piece 'simple-string) + diddle-case))) + (t + (error "~S is not allowed as a directory component." piece))))) (results))) (simple-string - `(:absolute - ,(maybe-diddle-case directory diddle-case))) + `(:absolute ,(maybe-diddle-case directory diddle-case))) (string `(:absolute - ,(maybe-diddle-case (coerce directory 'simple-string) - diddle-case))))) + ,(maybe-diddle-case (coerce directory 'simple-string) diddle-case))))) (defun make-pathname (&key host - (device nil devp) - (directory nil dirp) - (name nil namep) - (type nil typep) - (version nil versionp) - defaults - (case :local)) + (device nil devp) + (directory nil dirp) + (name nil namep) + (type nil typep) + (version nil versionp) + defaults + (case :local)) #!+sb-doc "Makes a new pathname from the component arguments. Note that host is a host-structure or string." (declare (type (or string host pathname-component-tokens) host) - (type (or string pathname-component-tokens) device) - (type (or list string pattern pathname-component-tokens) directory) - (type (or string pattern pathname-component-tokens) name type) - (type (or integer pathname-component-tokens (member :newest)) - version) - (type (or pathname-designator null) defaults) - (type (member :common :local) case)) + (type (or string pathname-component-tokens) device) + (type (or list string pattern pathname-component-tokens) directory) + (type (or string pattern pathname-component-tokens) name type) + (type (or integer pathname-component-tokens (member :newest)) + version) + (type (or pathname-designator null) defaults) + (type (member :common :local) case)) (let* ((defaults (when defaults - (with-pathname (defaults defaults) defaults))) - (default-host (if defaults - (%pathname-host defaults) - (pathname-host *default-pathname-defaults*))) - ;; Raymond Toy writes: CLHS says make-pathname can take a - ;; string (as a logical-host) for the host part. We map that - ;; string into the corresponding logical host structure. - ;; - ;; Paul Werkowski writes: - ;; HyperSpec says for the arg to MAKE-PATHNAME; - ;; "host---a valid physical pathname host. ..." - ;; where it probably means -- a valid pathname host. - ;; "valid pathname host n. a valid physical pathname host or - ;; a valid logical pathname host." - ;; and defines - ;; "valid physical pathname host n. any of a string, - ;; a list of strings, or the symbol :unspecific, - ;; that is recognized by the implementation as the name of a host." - ;; "valid logical pathname host n. a string that has been defined - ;; as the name of a logical host. ..." - ;; HS is silent on what happens if the :HOST arg is NOT one of these. - ;; It seems an error message is appropriate. - (host (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) - (eq case :common))) - (diddle-defaults - (not (eq (host-customary-case 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)))) + (with-pathname (defaults defaults) defaults))) + (default-host (if defaults + (%pathname-host defaults) + (pathname-host *default-pathname-defaults*))) + ;; Raymond Toy writes: CLHS says make-pathname can take a + ;; string (as a logical-host) for the host part. We map that + ;; string into the corresponding logical host structure. + ;; + ;; Paul Werkowski writes: + ;; HyperSpec says for the arg to MAKE-PATHNAME; + ;; "host---a valid physical pathname host. ..." + ;; where it probably means -- a valid pathname host. + ;; "valid pathname host n. a valid physical pathname host or + ;; a valid logical pathname host." + ;; and defines + ;; "valid physical pathname host n. any of a string, + ;; a list of strings, or the symbol :unspecific, + ;; that is recognized by the implementation as the name of a host." + ;; "valid logical pathname host n. a string that has been defined + ;; as the name of a logical host. ..." + ;; HS is silent on what happens if the :HOST arg is NOT one of these. + ;; It seems an error message is appropriate. + (host (or (find-host host nil) default-host)) + (diddle-args (and (eq (host-customary-case host) :lower) + (eq case :common))) + (diddle-defaults + (not (eq (host-customary-case host) + (host-customary-case default-host)))) + (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))) + (merge-directories dir + (%pathname-directory defaults) + diddle-defaults))) (macrolet ((pick (var varp field) - `(cond ((or (simple-string-p ,var) - (pattern-p ,var)) - (maybe-diddle-case ,var diddle-args)) - ((stringp ,var) - (maybe-diddle-case (coerce ,var 'simple-string) - diddle-args)) - (,varp - (maybe-diddle-case ,var diddle-args)) - (defaults - (maybe-diddle-case (,field defaults) - diddle-defaults)) - (t - nil)))) + `(cond ((or (simple-string-p ,var) + (pattern-p ,var)) + (maybe-diddle-case ,var diddle-args)) + ((stringp ,var) + (maybe-diddle-case (coerce ,var 'simple-string) + diddle-args)) + (,varp + (maybe-diddle-case ,var diddle-args)) + (defaults + (maybe-diddle-case (,field defaults) + diddle-defaults)) + (t + nil)))) (%make-maybe-logical-pathname host - dev ; forced to :UNSPECIFIC when logical - dir - (pick name namep %pathname-name) - (pick type typep %pathname-type) - ver)))) + dev ; forced to :UNSPECIFIC when logical + dir + (pick name namep %pathname-name) + (pick type typep %pathname-type) + ver)))) (defun pathname-host (pathname &key (case :local)) #!+sb-doc "Return PATHNAME's host." (declare (type pathname-designator pathname) - (type (member :local :common) case) - (values host) - (ignore case)) + (type (member :local :common) case) + (values host) + (ignore case)) (with-pathname (pathname pathname) (%pathname-host pathname))) @@ -554,48 +638,48 @@ a host-structure or string." #!+sb-doc "Return PATHNAME's device." (declare (type pathname-designator pathname) - (type (member :local :common) case)) + (type (member :local :common) case)) (with-pathname (pathname pathname) (maybe-diddle-case (%pathname-device pathname) - (and (eq case :common) - (eq (host-customary-case - (%pathname-host pathname)) - :lower))))) + (and (eq case :common) + (eq (host-customary-case + (%pathname-host pathname)) + :lower))))) (defun pathname-directory (pathname &key (case :local)) #!+sb-doc "Return PATHNAME's directory." (declare (type pathname-designator pathname) - (type (member :local :common) case)) + (type (member :local :common) case)) (with-pathname (pathname pathname) (maybe-diddle-case (%pathname-directory pathname) - (and (eq case :common) - (eq (host-customary-case - (%pathname-host pathname)) - :lower))))) + (and (eq case :common) + (eq (host-customary-case + (%pathname-host pathname)) + :lower))))) (defun pathname-name (pathname &key (case :local)) #!+sb-doc "Return PATHNAME's name." (declare (type pathname-designator pathname) - (type (member :local :common) case)) + (type (member :local :common) case)) (with-pathname (pathname pathname) (maybe-diddle-case (%pathname-name pathname) - (and (eq case :common) - (eq (host-customary-case - (%pathname-host pathname)) - :lower))))) + (and (eq case :common) + (eq (host-customary-case + (%pathname-host pathname)) + :lower))))) (defun pathname-type (pathname &key (case :local)) #!+sb-doc "Return PATHNAME's type." (declare (type pathname-designator pathname) - (type (member :local :common) case)) + (type (member :local :common) case)) (with-pathname (pathname pathname) (maybe-diddle-case (%pathname-type pathname) - (and (eq case :common) - (eq (host-customary-case - (%pathname-host pathname)) - :lower))))) + (and (eq case :common) + (eq (host-customary-case + (%pathname-host pathname)) + :lower))))) (defun pathname-version (pathname) #!+sb-doc @@ -617,253 +701,325 @@ a host-structure or string." (defun parseable-logical-namestring-p (namestr start end) (catch 'exit (handler-bind - ((namestring-parse-error (lambda (c) - (declare (ignore c)) - (throw 'exit nil)))) + ((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))))))) + (when colon + (let ((potential-host + (logical-word-or-lose (subseq namestr start colon)))) + ;; depending on the outcome of CSR comp.lang.lisp post + ;; "can PARSE-NAMESTRING create logical hosts", we may need + ;; to do things with potential-host (create it + ;; temporarily, parse the namestring and unintern the + ;; logical host potential-host on failure. + (declare (ignore potential-host)) + (let ((result + (handler-bind + ((simple-type-error (lambda (c) + (declare (ignore c)) + (throw 'exit nil)))) + (parse-logical-namestring namestr start end)))) + ;; if we got this far, we should have an explicit host + ;; (first return value of parse-logical-namestring) + (aver result) + result))))))) ;;; Handle the case where PARSE-NAMESTRING is actually parsing a ;;; namestring. We pick off the :JUNK-ALLOWED case then find a host to ;;; use for parsing, call the parser, then check whether the host matches. (defun %parse-namestring (namestr host defaults start end junk-allowed) (declare (type (or host null) host) - (type string namestr) - (type index start) - (type (or index null) end)) - (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)))) - (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)))))) + (type string namestr) + (type index start) + (type (or index null) end)) + (cond + (junk-allowed + (handler-case + (%parse-namestring namestr host defaults start end nil) + (namestring-parse-error (condition) + (values nil (namestring-parse-error-offset condition))))) + (t + (let* ((end (%check-vector-sequence-bounds namestr start end))) + (multiple-value-bind (new-host device directory file type version) + ;; Comments below are quotes from the HyperSpec + ;; PARSE-NAMESTRING entry, reproduced here to demonstrate + ;; that we actually have to do things this way rather than + ;; some possibly more logical way. - CSR, 2002-04-18 + (cond + ;; "If host is a logical host then thing is parsed as a + ;; logical pathname namestring on the host." + (host (funcall (host-parse host) namestr start end)) + ;; "If host is nil and thing is a syntactically valid + ;; logical pathname namestring containing an explicit + ;; host, then it is parsed as a logical pathname + ;; namestring." + ((parseable-logical-namestring-p namestr start end) + (parse-logical-namestring namestr start end)) + ;; "If host is nil, default-pathname is a logical + ;; pathname, and thing is a syntactically valid logical + ;; pathname namestring without an explicit host, then it + ;; is parsed as a logical pathname namestring on the + ;; host that is the host component of default-pathname." + ;; + ;; "Otherwise, the parsing of thing is + ;; implementation-defined." + ;; + ;; Both clauses are handled here, as the default + ;; *DEFAULT-PATHNAME-DEFAULTS* has a SB-IMPL::UNIX-HOST + ;; for a host. + ((pathname-host defaults) + (funcall (host-parse (pathname-host defaults)) + namestr + start + end)) + ;; I don't think we should ever get here, as the default + ;; host will always have a non-null HOST, given that we + ;; can't create a new pathname without going through + ;; *DEFAULT-PATHNAME-DEFAULTS*, which has a non-null + ;; host... + (t (bug "Fallen through COND in %PARSE-NAMESTRING"))) + (when (and host new-host (not (eq new-host host))) + (error 'simple-type-error + :datum new-host + ;; Note: ANSI requires that this be a TYPE-ERROR, + ;; but there seems to be no completely correct + ;; value to use for TYPE-ERROR-EXPECTED-TYPE. + ;; Instead, we return a sort of "type error allowed + ;; type", trying to say "it would be OK if you + ;; passed NIL as the host value" but not mentioning + ;; that a matching string would be OK too. + :expected-type 'null + :format-control + "The host in the namestring, ~S,~@ + does not match the explicit HOST argument, ~S." + :format-arguments (list new-host host))) + (let ((pn-host (or new-host host (pathname-host defaults)))) + (values (%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. (defun extract-logical-host-prefix (namestr start end) - (declare (type simple-base-string namestr) - (type index start end) - (values (or logical-host null))) + (declare (type simple-string namestr) + (type index start end) + (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))) + (values (gethash (nstring-upcase (subseq namestr start colon-pos)) + *logical-hosts*)) + nil))) (defun parse-namestring (thing - &optional - host - (defaults *default-pathname-defaults*) - &key (start 0) end junk-allowed) - (declare (type pathname-designator thing) - (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) - (values (or null pathname) (or null index))) - ;; Generally, redundant specification of information in software, - ;; whether in code or in comments, is bad. However, the ANSI spec - ;; for this is messy enough that it's hard to hold in short-term - ;; memory, so I've recorded these redundant notes on the - ;; implications of the ANSI spec. - ;; - ;; According to the ANSI spec, HOST can be a valid pathname host, or - ;; a logical host, or NIL. - ;; - ;; A valid pathname host can be a valid physical pathname host or a - ;; valid logical pathname host. - ;; - ;; A valid physical pathname host is "any of a string, a list of - ;; strings, or the symbol :UNSPECIFIC, that is recognized by the - ;; implementation as the name of a host". In SBCL as of 0.6.9.8, - ;; that means :UNSPECIFIC: though someday we might want to - ;; generalize it to allow strings like "RTFM.MIT.EDU" or lists like - ;; '("RTFM" "MIT" "EDU"), that's not supported now. - ;; - ;; A valid logical pathname host is a string which has been defined as - ;; the name of a logical host, as with LOAD-LOGICAL-PATHNAME-TRANSLATIONS. - ;; - ;; A logical host is an object of implementation-dependent nature. In - ;; SBCL, it's a member of the HOST class (a subclass of STRUCTURE-OBJECT). - (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, - ;; but ANSI leaves this up to the implementor, - ;; and in SBCL we don't do it, so it must be a - ;; logical host. - (find-logical-host host)) - ((or null (member :unspecific)) - ;; CLHS says that HOST=:UNSPECIFIC has - ;; implementation-defined behavior. We - ;; just turn it into NIL. - nil) - (list - ;; ANSI also allows LISTs to designate hosts, - ;; but leaves its interpretation - ;; implementation-defined. Our interpretation - ;; is that it's unsupported.:-| - (error "A LIST representing a pathname host is not ~ - supported in this implementation:~% ~S" - host)) - (host - host)))) - (declare (type (or null host) found-host)) - (etypecase thing - (simple-string - (%parse-namestring thing found-host defaults start end junk-allowed)) - (string - (%parse-namestring (coerce thing 'simple-string) - found-host defaults start end junk-allowed)) - (pathname - (let ((defaulted-host (or found-host (%pathname-host defaults)))) - (declare (type host defaulted-host)) - (unless (eq defaulted-host (%pathname-host thing)) - (error "The HOST argument doesn't match the pathname host:~% ~ - ~S and ~S." - defaulted-host (%pathname-host thing)))) - (values thing start)) - (stream - (let ((name (file-name thing))) - (unless name - (error "can't figure out the file associated with stream:~% ~S" - thing)) - (values name nil)))))) + &optional + host + (defaults *default-pathname-defaults*) + &key (start 0) end junk-allowed) + (declare (type pathname-designator thing defaults) + (type (or list host string (member :unspecific)) host) + (type index start) + (type (or index null) end) + (type (or t null) junk-allowed) + (values (or null pathname) (or null index))) + (with-host (found-host host) + (let (;; According to ANSI defaults may be any valid pathname designator + (defaults (etypecase defaults + (pathname + defaults) + (string + (aver (pathnamep *default-pathname-defaults*)) + (parse-namestring defaults)) + (stream + (truename defaults))))) + (declare (type pathname defaults)) + (etypecase thing + (simple-string + (%parse-namestring thing found-host defaults start end junk-allowed)) + (string + (%parse-namestring (coerce thing 'simple-string) + found-host defaults start end junk-allowed)) + (pathname + (let ((defaulted-host (or found-host (%pathname-host defaults)))) + (declare (type host defaulted-host)) + (unless (eq defaulted-host (%pathname-host thing)) + (error "The HOST argument doesn't match the pathname host:~% ~ + ~S and ~S." + defaulted-host (%pathname-host thing)))) + (values thing start)) + (stream + (let ((name (file-name thing))) + (unless name + (error "can't figure out the file associated with stream:~% ~S" + thing)) + (values name nil))))))) + +(defun %parse-native-namestring (namestr host defaults start end junk-allowed + as-directory) + (declare (type (or host null) host) + (type string namestr) + (type index start) + (type (or index null) end)) + (cond + (junk-allowed + (handler-case + (%parse-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) + (cond + (host + (funcall (host-parse-native host) namestr start end as-directory)) + ((pathname-host defaults) + (funcall (host-parse-native (pathname-host defaults)) + namestr + start + end + as-directory)) + ;; I don't think we should ever get here, as the default + ;; host will always have a non-null HOST, given that we + ;; can't create a new pathname without going through + ;; *DEFAULT-PATHNAME-DEFAULTS*, which has a non-null + ;; host... + (t (bug "Fallen through COND in %PARSE-NAMESTRING"))) + (when (and host new-host (not (eq new-host host))) + (error 'simple-type-error + :datum new-host + :expected-type `(or null (eql ,host)) + :format-control + "The host in the namestring, ~S,~@ + does not match the explicit HOST argument, ~S." + :format-arguments (list new-host host))) + (let ((pn-host (or new-host host (pathname-host defaults)))) + (values (%make-pathname + pn-host device directory file type version) + end))))))) + +(defun parse-native-namestring (thing + &optional + host + (defaults *default-pathname-defaults*) + &key (start 0) end junk-allowed + as-directory) + #!+sb-doc + "Convert THING into a pathname, using the native conventions +appropriate for the pathname host HOST, or if not specified the +host of DEFAULTS. If THING is a string, the parse is bounded by +START and END, and error behaviour is controlled by JUNK-ALLOWED, +as with PARSE-NAMESTRING. For file systems whose native +conventions allow directories to be indicated as files, if +AS-DIRECTORY is true, return a pathname denoting THING as a +directory." + (declare (type pathname-designator thing defaults) + (type (or list host string (member :unspecific)) host) + (type index start) + (type (or index null) end) + (type (or t null) junk-allowed) + (values (or null pathname) (or null index))) + (with-host (found-host host) + (let ((defaults (etypecase defaults + (pathname + defaults) + (string + (aver (pathnamep *default-pathname-defaults*)) + (parse-native-namestring defaults)) + (stream + (truename defaults))))) + (declare (type pathname defaults)) + (etypecase thing + (simple-string + (%parse-native-namestring + thing found-host defaults start end junk-allowed as-directory)) + (string + (%parse-native-namestring (coerce thing 'simple-string) + found-host defaults start end junk-allowed + as-directory)) + (pathname + (let ((defaulted-host (or found-host (%pathname-host defaults)))) + (declare (type host defaulted-host)) + (unless (eq defaulted-host (%pathname-host thing)) + (error "The HOST argument doesn't match the pathname host:~% ~ + ~S and ~S." + defaulted-host (%pathname-host thing)))) + (values thing start)) + (stream + ;; FIXME + (let ((name (file-name thing))) + (unless name + (error "can't figure out the file associated with stream:~% ~S" + thing)) + (values name nil))))))) (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)) - (funcall (host-unparse host) pathname))))) + (unless host + (error "can't determine the namestring for pathnames with no ~ + host:~% ~S" pathname)) + (funcall (host-unparse host) pathname))))) + +(defun native-namestring (pathname &key as-file) + #!+sb-doc + "Construct the full native (name)string form of PATHNAME. For +file systems whose native conventions allow directories to be +indicated as files, if AS-FILE is true and the name, type, and +version components of PATHNAME are all NIL or :UNSPECIFIC, +construct a string that names the directory according to the file +system's syntax for files." + (declare (type pathname-designator pathname)) + (with-native-pathname (pathname pathname) + (when pathname + (let ((host (%pathname-host pathname))) + (unless host + (error "can't determine the native namestring for pathnames with no ~ + host:~% ~S" pathname)) + (funcall (host-unparse-native host) pathname as-file))))) (defun host-namestring (pathname) #!+sb-doc "Return a string representation of the name of the host in the pathname." - (declare (type pathname-designator pathname) - (values (or null simple-base-string))) + (declare (type pathname-designator pathname)) (with-pathname (pathname pathname) (let ((host (%pathname-host pathname))) (if host - (funcall (host-unparse-host host) pathname) - (error - "can't determine the namestring for pathnames with no host:~% ~S" - pathname))))) + (funcall (host-unparse-host host) pathname) + (error + "can't determine the namestring for pathnames with no host:~% ~S" + pathname))))) (defun directory-namestring (pathname) #!+sb-doc "Return a string representation of the directories used in the pathname." - (declare (type pathname-designator pathname) - (values (or null simple-base-string))) + (declare (type pathname-designator pathname)) (with-pathname (pathname pathname) (let ((host (%pathname-host pathname))) (if host - (funcall (host-unparse-directory host) pathname) - (error - "can't determine the namestring for pathnames with no host:~% ~S" - pathname))))) + (funcall (host-unparse-directory host) pathname) + (error + "can't determine the namestring for pathnames with no host:~% ~S" + pathname))))) (defun file-namestring (pathname) #!+sb-doc "Return a string representation of the name used in the pathname." - (declare (type pathname-designator pathname) - (values (or null simple-base-string))) + (declare (type pathname-designator pathname)) (with-pathname (pathname pathname) (let ((host (%pathname-host pathname))) (if host - (funcall (host-unparse-file host) pathname) - (error - "can't determine the namestring for pathnames with no host:~% ~S" - pathname))))) + (funcall (host-unparse-file host) pathname) + (error + "can't determine the namestring for pathnames with no host:~% ~S" + pathname))))) (defun enough-namestring (pathname - &optional - (defaults *default-pathname-defaults*)) + &optional + (defaults *default-pathname-defaults*)) #!+sb-doc "Return an abbreviated pathname sufficent to identify the pathname relative to the defaults." @@ -871,11 +1027,11 @@ a host-structure or string." (with-pathname (pathname pathname) (let ((host (%pathname-host pathname))) (if host - (with-pathname (defaults defaults) - (funcall (host-unparse-enough host) pathname defaults)) - (error - "can't determine the namestring for pathnames with no host:~% ~S" - pathname))))) + (with-pathname (defaults defaults) + (funcall (host-unparse-enough host) pathname defaults)) + (error + "can't determine the namestring for pathnames with no host:~% ~S" + pathname))))) ;;;; wild pathnames @@ -883,25 +1039,25 @@ a host-structure or string." #!+sb-doc "Predicate for determining whether pathname contains any wildcards." (declare (type pathname-designator pathname) - (type (member nil :host :device :directory :name :type :version) - field-key)) + (type (member nil :host :device :directory :name :type :version) + field-key)) (with-pathname (pathname pathname) (flet ((frob (x) - (or (pattern-p x) (member x '(:wild :wild-inferiors))))) + (or (pattern-p x) (member x '(:wild :wild-inferiors))))) (ecase field-key - ((nil) - (or (wild-pathname-p pathname :host) - (wild-pathname-p pathname :device) - (wild-pathname-p pathname :directory) - (wild-pathname-p pathname :name) - (wild-pathname-p pathname :type) - (wild-pathname-p pathname :version))) - (:host (frob (%pathname-host pathname))) - (:device (frob (%pathname-host pathname))) - (:directory (some #'frob (%pathname-directory pathname))) - (:name (frob (%pathname-name pathname))) - (:type (frob (%pathname-type pathname))) - (:version (frob (%pathname-version pathname))))))) + ((nil) + (or (wild-pathname-p pathname :host) + (wild-pathname-p pathname :device) + (wild-pathname-p pathname :directory) + (wild-pathname-p pathname :name) + (wild-pathname-p pathname :type) + (wild-pathname-p pathname :version))) + (:host (frob (%pathname-host pathname))) + (:device (frob (%pathname-host pathname))) + (:directory (some #'frob (%pathname-directory pathname))) + (:name (frob (%pathname-name pathname))) + (:type (frob (%pathname-type pathname))) + (:version (frob (%pathname-version pathname))))))) (defun pathname-match-p (in-pathname in-wildname) #!+sb-doc @@ -909,16 +1065,17 @@ a host-structure or string." (declare (type pathname-designator in-pathname)) (with-pathname (pathname in-pathname) (with-pathname (wildname in-wildname) - (macrolet ((frob (field &optional (op 'components-match )) - `(or (null (,field wildname)) - (,op (,field pathname) (,field wildname))))) - (and (or (null (%pathname-host wildname)) - (eq (%pathname-host wildname) (%pathname-host pathname))) - (frob %pathname-device) - (frob %pathname-directory directory-components-match) - (frob %pathname-name) - (frob %pathname-type) - (frob %pathname-version)))))) + (macrolet ((frob (field &optional (op 'components-match)) + `(or (null (,field wildname)) + (,op (,field pathname) (,field wildname))))) + (and (or (null (%pathname-host wildname)) + (eq (%pathname-host wildname) (%pathname-host pathname))) + (frob %pathname-device) + (frob %pathname-directory directory-components-match) + (frob %pathname-name) + (frob %pathname-type) + (or (eq (%pathname-host wildname) *physical-host*) + (frob %pathname-version))))))) ;;; Place the substitutions into the pattern and return the string or pattern ;;; that results. If DIDDLE-CASE is true, we diddle the result case as well, @@ -928,85 +1085,86 @@ a host-structure or string." ;;; as a single string, so we ignore subsequent contiguous wildcards. (defun substitute-into (pattern subs diddle-case) (declare (type pattern pattern) - (type list subs) - (values (or simple-base-string pattern) list)) + (type list subs) + (values (or simple-string pattern) list)) (let ((in-wildcard nil) - (pieces nil) - (strings nil)) + (pieces nil) + (strings nil)) (dolist (piece (pattern-pieces pattern)) (cond ((simple-string-p piece) - (push piece strings) - (setf in-wildcard nil)) - (in-wildcard) - (t - (setf in-wildcard t) - (unless subs - (error "not enough wildcards in FROM pattern to match ~ - TO pattern:~% ~S" - pattern)) - (let ((sub (pop subs))) - (typecase sub - (pattern - (when strings - (push (apply #'concatenate 'simple-string - (nreverse strings)) - pieces)) - (dolist (piece (pattern-pieces sub)) - (push piece pieces))) - (simple-string - (push sub strings)) - (t - (error "can't substitute this into the middle of a word:~ - ~% ~S" - sub))))))) + (push piece strings) + (setf in-wildcard nil)) + (in-wildcard) + (t + (setf in-wildcard t) + (unless subs + (error "not enough wildcards in FROM pattern to match ~ + TO pattern:~% ~S" + pattern)) + (let ((sub (pop subs))) + (typecase sub + (pattern + (when strings + (push (apply #'concatenate 'simple-string + (nreverse strings)) + pieces)) + (dolist (piece (pattern-pieces sub)) + (push piece pieces))) + (simple-string + (push sub strings)) + (t + (error "can't substitute this into the middle of a word:~ + ~% ~S" + sub))))))) (when strings (push (apply #'concatenate 'simple-string (nreverse strings)) - pieces)) + pieces)) (values (maybe-diddle-case (if (and pieces (simple-string-p (car pieces)) (null (cdr pieces))) - (car pieces) - (make-pattern (nreverse pieces))) + (car pieces) + (make-pattern (nreverse pieces))) diddle-case) subs))) ;;; Called when we can't see how source and from matched. (defun didnt-match-error (source from) (error "Pathname components from SOURCE and FROM args to TRANSLATE-PATHNAME~@ - did not match:~% ~S ~S" - source from)) + 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 (typecase from (pattern - (typecase source - (pattern - (if (pattern= from source) - source - (didnt-match-error source from))) - (simple-string - (multiple-value-bind (won subs) (pattern-matches from source) - (if won - (values (substitute-into to subs diddle-case)) - (didnt-match-error source from)))) - (t - (maybe-diddle-case source diddle-case)))) + (typecase source + (pattern + (if (pattern= from source) + source + (didnt-match-error source from))) + (simple-string + (multiple-value-bind (won subs) (pattern-matches from source) + (if won + (values (substitute-into to subs diddle-case)) + (didnt-match-error source from)))) + (t + (maybe-diddle-case source diddle-case)))) ((member :wild) - (values (substitute-into to (list source) diddle-case))) + (values (substitute-into to (list source) diddle-case))) (t - (if (components-match source from) - (maybe-diddle-case source diddle-case) - (didnt-match-error source from))))) + (if (components-match source from) + (maybe-diddle-case source diddle-case) + (didnt-match-error source from))))) ((member nil :wild) (maybe-diddle-case source diddle-case)) (t (if (components-match source from) - to - (didnt-match-error source from))))) + to + (didnt-match-error source from))))) ;;; Return a list of all the things that we want to substitute into the TO ;;; pattern (the things matched by from on source.) When From contains @@ -1014,52 +1172,52 @@ a host-structure or string." ;;; subdirectories. (defun compute-directory-substitutions (orig-source orig-from) (let ((source orig-source) - (from orig-from)) + (from orig-from)) (collect ((subs)) (loop - (unless source - (unless (every (lambda (x) (eq x :wild-inferiors)) from) - (didnt-match-error orig-source orig-from)) - (subs ()) - (return)) - (unless from (didnt-match-error orig-source orig-from)) - (let ((from-part (pop from)) - (source-part (pop source))) - (typecase from-part - (pattern - (typecase source-part - (pattern - (if (pattern= from-part source-part) - (subs source-part) - (didnt-match-error orig-source orig-from))) - (simple-string - (multiple-value-bind (won new-subs) - (pattern-matches from-part source-part) - (if won - (dolist (sub new-subs) - (subs sub)) - (didnt-match-error orig-source orig-from)))) - (t - (didnt-match-error orig-source orig-from)))) - ((member :wild) - (subs source-part)) - ((member :wild-inferiors) - (let ((remaining-source (cons source-part source))) - (collect ((res)) - (loop - (when (directory-components-match remaining-source from) - (return)) - (unless remaining-source - (didnt-match-error orig-source orig-from)) - (res (pop remaining-source))) - (subs (res)) - (setq source remaining-source)))) - (simple-string - (unless (and (simple-string-p source-part) - (string= from-part source-part)) - (didnt-match-error orig-source orig-from))) - (t - (didnt-match-error orig-source orig-from))))) + (unless source + (unless (every (lambda (x) (eq x :wild-inferiors)) from) + (didnt-match-error orig-source orig-from)) + (subs ()) + (return)) + (unless from (didnt-match-error orig-source orig-from)) + (let ((from-part (pop from)) + (source-part (pop source))) + (typecase from-part + (pattern + (typecase source-part + (pattern + (if (pattern= from-part source-part) + (subs source-part) + (didnt-match-error orig-source orig-from))) + (simple-string + (multiple-value-bind (won new-subs) + (pattern-matches from-part source-part) + (if won + (dolist (sub new-subs) + (subs sub)) + (didnt-match-error orig-source orig-from)))) + (t + (didnt-match-error orig-source orig-from)))) + ((member :wild) + (subs source-part)) + ((member :wild-inferiors) + (let ((remaining-source (cons source-part source))) + (collect ((res)) + (loop + (when (directory-components-match remaining-source from) + (return)) + (unless remaining-source + (didnt-match-error orig-source orig-from)) + (res (pop remaining-source))) + (subs (res)) + (setq source remaining-source)))) + (simple-string + (unless (and (simple-string-p source-part) + (string= from-part source-part)) + (didnt-match-error orig-source orig-from))) + (t + (didnt-match-error orig-source orig-from))))) (subs)))) ;;; This is called by TRANSLATE-PATHNAME on the directory components @@ -1071,69 +1229,75 @@ a host-structure or string." (defun translate-directories (source from to diddle-case) (if (not (and source to from)) (or (and to (null source) (remove :wild-inferiors to)) - (mapcar (lambda (x) (maybe-diddle-case x diddle-case)) source)) + (mapcar (lambda (x) (maybe-diddle-case x diddle-case)) source)) (collect ((res)) - ;; If TO is :ABSOLUTE, the result should still be :ABSOLUTE. - (res (if (eq (first to) :absolute) - :absolute - (first source))) - (let ((subs-left (compute-directory-substitutions (rest source) - (rest from)))) - (dolist (to-part (rest to)) - (typecase to-part - ((member :wild) - (aver subs-left) - (let ((match (pop subs-left))) - (when (listp match) - (error ":WILD-INFERIORS is not paired in from and to ~ - patterns:~% ~S ~S" from to)) - (res (maybe-diddle-case match diddle-case)))) - ((member :wild-inferiors) - (aver subs-left) - (let ((match (pop subs-left))) - (unless (listp match) - (error ":WILD-INFERIORS not paired in from and to ~ - patterns:~% ~S ~S" from to)) - (dolist (x match) - (res (maybe-diddle-case x diddle-case))))) - (pattern - (multiple-value-bind - (new new-subs-left) - (substitute-into to-part subs-left diddle-case) - (setf subs-left new-subs-left) - (res new))) - (t (res to-part))))) - (res)))) + ;; If TO is :ABSOLUTE, the result should still be :ABSOLUTE. + (res (if (eq (first to) :absolute) + :absolute + (first source))) + (let ((subs-left (compute-directory-substitutions (rest source) + (rest from)))) + (dolist (to-part (rest to)) + (typecase to-part + ((member :wild) + (aver subs-left) + (let ((match (pop subs-left))) + (when (listp match) + (error ":WILD-INFERIORS is not paired in from and to ~ + patterns:~% ~S ~S" from to)) + (res (maybe-diddle-case match diddle-case)))) + ((member :wild-inferiors) + (aver subs-left) + (let ((match (pop subs-left))) + (unless (listp match) + (error ":WILD-INFERIORS not paired in from and to ~ + patterns:~% ~S ~S" from to)) + (dolist (x match) + (res (maybe-diddle-case x diddle-case))))) + (pattern + (multiple-value-bind + (new new-subs-left) + (substitute-into to-part subs-left diddle-case) + (setf subs-left new-subs-left) + (res new))) + (t (res to-part))))) + (res)))) (defun translate-pathname (source from-wildname to-wildname &key) #!+sb-doc "Use the source pathname to translate the from-wildname's wild and - unspecified elements into a completed to-pathname based on the to-wildname." +unspecified elements into a completed to-pathname based on the to-wildname." (declare (type pathname-designator source from-wildname to-wildname)) (with-pathname (source source) (with-pathname (from from-wildname) (with-pathname (to to-wildname) - (let* ((source-host (%pathname-host source)) - (to-host (%pathname-host to)) - (diddle-case - (and source-host to-host - (not (eq (host-customary-case source-host) - (host-customary-case to-host)))))) - (macrolet ((frob (field &optional (op 'translate-component)) - `(let ((result (,op (,field source) - (,field from) - (,field to) - diddle-case))) - (if (eq result :error) - (error "~S doesn't match ~S." source from) - result)))) - (%make-maybe-logical-pathname - (or to-host source-host) - (frob %pathname-device) - (frob %pathname-directory translate-directories) - (frob %pathname-name) - (frob %pathname-type) - (frob %pathname-version)))))))) + (let* ((source-host (%pathname-host source)) + (from-host (%pathname-host from)) + (to-host (%pathname-host to)) + (diddle-case + (and source-host to-host + (not (eq (host-customary-case source-host) + (host-customary-case to-host)))))) + (macrolet ((frob (field &optional (op 'translate-component)) + `(let ((result (,op (,field source) + (,field from) + (,field to) + diddle-case))) + (if (eq result :error) + (error "~S doesn't match ~S." source from) + result)))) + (%make-maybe-logical-pathname + (or to-host source-host) + (frob %pathname-device) + (frob %pathname-directory translate-directories) + (frob %pathname-name) + (frob %pathname-type) + (if (eq from-host *unix-host*) + (if (or (eq (%pathname-version to) :wild) + (eq (%pathname-version to) nil)) + (%pathname-version source) + (%pathname-version to)) + (frob %pathname-version))))))))) ;;;; logical pathname support. ANSI 92-102 specification. ;;;; @@ -1143,26 +1307,33 @@ a host-structure or string." ;;;; utilities +(defun simplify-namestring (namestring &optional host) + (funcall (host-simplify-namestring + (or host + (pathname-host (sane-default-pathname-defaults)))) + namestring)) + ;;; Canonicalize a logical pathname word by uppercasing it checking that it ;;; contains only legal characters. (defun logical-word-or-lose (word) (declare (string word)) (when (string= word "") (error 'namestring-parse-error - :complaint "Attempted to treat invalid logical hostname ~ + :complaint "Attempted to treat invalid logical hostname ~ as a logical host:~% ~S" - :args (list word) - :namestring word :offset 0)) + :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" - :args (list ch) - :namestring word :offset i)))) - word)) + (unless (and (typep ch 'standard-char) + (or (alpha-char-p ch) (digit-char-p ch) (char= ch #\-))) + (error 'namestring-parse-error + :complaint "logical namestring character which ~ + is not alphanumeric or hyphen:~% ~S" + :args (list ch) + :namestring word :offset i)))) + (coerce word 'string))) ; why not simple-string? ;;; Given a logical host or string, return a logical host. If ERROR-P ;;; is NIL, then return NIL when no such host exists. @@ -1170,31 +1341,32 @@ a host-structure or string." (etypecase thing (string (let ((found (gethash (logical-word-or-lose thing) - *logical-hosts*))) + *logical-hosts*))) (if (or found (not errorp)) - found - ;; This is the error signalled from e.g. - ;; LOGICAL-PATHNAME-TRANSLATIONS when host is not a defined - ;; host, and ANSI specifies that that's a TYPE-ERROR. - (error 'simple-type-error - :datum thing - ;; God only knows what ANSI expects us to use for - ;; the EXPECTED-TYPE here. Maybe this will be OK.. - :expected-type - '(and string (satisfies logical-pathname-translations)) - :format-control "logical host not yet defined: ~S" - :format-arguments (list thing))))) + found + ;; This is the error signalled from e.g. + ;; LOGICAL-PATHNAME-TRANSLATIONS when host is not a defined + ;; host, and ANSI specifies that that's a TYPE-ERROR. + (error 'simple-type-error + :datum thing + ;; God only knows what ANSI expects us to use for + ;; the EXPECTED-TYPE here. Maybe this will be OK.. + :expected-type + '(and string (satisfies logical-pathname-translations)) + :format-control "logical host not yet defined: ~S" + :format-arguments (list thing))))) (logical-host thing))) ;;; Given a logical host name or host, return a logical host, creating ;;; a new one if necessary. (defun intern-logical-host (thing) (declare (values logical-host)) - (or (find-logical-host thing nil) - (let* ((name (logical-word-or-lose thing)) - (new (make-logical-host :name name))) - (setf (gethash name *logical-hosts*) new) - new))) + (with-locked-system-table (*logical-hosts*) + (or (find-logical-host thing nil) + (let* ((name (logical-word-or-lose thing)) + (new (make-logical-host :name name))) + (setf (gethash name *logical-hosts*) new) + new)))) ;;;; logical pathname parsing @@ -1203,164 +1375,179 @@ a host-structure or string." (let ((chunk (caar chunks))) (collect ((pattern)) (let ((last-pos 0) - (len (length chunk))) - (declare (fixnum last-pos)) - (loop - (when (= last-pos len) (return)) - (let ((pos (or (position #\* chunk :start last-pos) len))) - (if (= pos last-pos) - (when (pattern) - (error 'namestring-parse-error - :complaint "double asterisk inside of logical ~ - word: ~S" - :args (list chunk) - :namestring namestring - :offset (+ (cdar chunks) pos))) - (pattern (subseq chunk last-pos pos))) - (if (= pos len) - (return) - (pattern :multi-char-wild)) - (setq last-pos (1+ pos))))) - (aver (pattern)) - (if (cdr (pattern)) - (make-pattern (pattern)) - (let ((x (car (pattern)))) - (if (eq x :multi-char-wild) - :wild - x)))))) + (len (length chunk))) + (declare (fixnum last-pos)) + (loop + (when (= last-pos len) (return)) + (let ((pos (or (position #\* chunk :start last-pos) len))) + (if (= pos last-pos) + (when (pattern) + (error 'namestring-parse-error + :complaint "double asterisk inside of logical ~ + word: ~S" + :args (list chunk) + :namestring namestring + :offset (+ (cdar chunks) pos))) + (pattern (subseq chunk last-pos pos))) + (if (= pos len) + (return) + (pattern :multi-char-wild)) + (setq last-pos (1+ pos))))) + (aver (pattern)) + (if (cdr (pattern)) + (make-pattern (pattern)) + (let ((x (car (pattern)))) + (if (eq x :multi-char-wild) + :wild + x)))))) ;;; Return a list of conses where the CDR is the start position and ;;; the CAR is a string (token) or character (punctuation.) (defun logical-chunkify (namestr start end) (collect ((chunks)) (do ((i start (1+ i)) - (prev 0)) - ((= i end) - (when (> end prev) - (chunks (cons (nstring-upcase (subseq namestr prev end)) prev)))) + (prev 0)) + ((= i end) + (when (> end prev) + (chunks (cons (nstring-upcase (subseq namestr prev end)) prev)))) (let ((ch (schar namestr i))) - (unless (or (alpha-char-p ch) (digit-char-p ch) - (member ch '(#\- #\*))) - (when (> i prev) - (chunks (cons (nstring-upcase (subseq namestr prev i)) prev))) - (setq prev (1+ i)) - (unless (member ch '(#\; #\: #\.)) - (error 'namestring-parse-error - :complaint "illegal character for logical pathname:~% ~S" - :args (list ch) - :namestring namestr - :offset i)) - (chunks (cons ch i))))) + (unless (or (alpha-char-p ch) (digit-char-p ch) + (member ch '(#\- #\*))) + (when (> i prev) + (chunks (cons (nstring-upcase (subseq namestr prev i)) prev))) + (setq prev (1+ i)) + (unless (member ch '(#\; #\: #\.)) + (error 'namestring-parse-error + :complaint "illegal character for logical pathname:~% ~S" + :args (list ch) + :namestring namestr + :offset i)) + (chunks (cons ch i))))) (chunks))) ;;; Break up a logical-namestring, always a string, into its ;;; constituent parts. (defun parse-logical-namestring (namestr start end) - (declare (type simple-base-string namestr) - (type index start end)) + (declare (type simple-string namestr) + (type index start end)) (collect ((directory)) (let ((host nil) - (name nil) - (type nil) - (version nil)) + (name nil) + (type nil) + (version nil)) (labels ((expecting (what chunks) - (unless (and chunks (simple-string-p (caar chunks))) - (error 'namestring-parse-error - :complaint "expecting ~A, got ~:[nothing~;~S~]." - :args (list what (caar chunks) (caar chunks)) - :namestring namestr - :offset (if chunks (cdar chunks) end))) - (caar chunks)) - (parse-host (chunks) - (case (caadr chunks) - (#\: - (setq host - (find-logical-host (expecting "a host name" chunks))) - (parse-relative (cddr chunks))) - (t - (parse-relative chunks)))) - (parse-relative (chunks) - (case (caar chunks) - (#\; - (directory :relative) - (parse-directory (cdr chunks))) - (t - (directory :absolute) ; Assumption! Maybe revoked later. - (parse-directory chunks)))) - (parse-directory (chunks) - (case (caadr chunks) - (#\; - (directory - (let ((res (expecting "a directory name" chunks))) - (cond ((string= res "..") :up) - ((string= res "**") :wild-inferiors) - (t - (maybe-make-logical-pattern namestr chunks))))) - (parse-directory (cddr chunks))) - (t - (parse-name chunks)))) - (parse-name (chunks) - (when chunks - (expecting "a file name" chunks) - (setq name (maybe-make-logical-pattern namestr chunks)) - (expecting-dot (cdr chunks)))) - (expecting-dot (chunks) - (when chunks - (unless (eql (caar chunks) #\.) - (error 'namestring-parse-error - :complaint "expecting a dot, got ~S." - :args (list (caar chunks)) - :namestring namestr - :offset (cdar chunks))) - (if type - (parse-version (cdr chunks)) - (parse-type (cdr chunks))))) - (parse-type (chunks) - (expecting "a file type" chunks) - (setq type (maybe-make-logical-pattern namestr chunks)) - (expecting-dot (cdr chunks))) - (parse-version (chunks) - (let ((str (expecting "a positive integer, * or NEWEST" - chunks))) - (cond - ((string= str "*") (setq version :wild)) - ((string= str "NEWEST") (setq version :newest)) - (t - (multiple-value-bind (res pos) - (parse-integer str :junk-allowed t) - (unless (and res (plusp res)) - (error 'namestring-parse-error - :complaint "expected a positive integer, ~ - got ~S" - :args (list str) - :namestring namestr - :offset (+ pos (cdar chunks)))) - (setq version res))))) - (when (cdr chunks) - (error 'namestring-parse-error - :complaint "extra stuff after end of file name" - :namestring namestr - :offset (cdadr chunks))))) - (parse-host (logical-chunkify namestr start end))) + (unless (and chunks (simple-string-p (caar chunks))) + (error 'namestring-parse-error + :complaint "expecting ~A, got ~:[nothing~;~S~]." + :args (list what (caar chunks) (caar chunks)) + :namestring namestr + :offset (if chunks (cdar chunks) end))) + (caar chunks)) + (parse-host (chunks) + (case (caadr chunks) + (#\: + (setq host + (find-logical-host (expecting "a host name" chunks))) + (parse-relative (cddr chunks))) + (t + (parse-relative chunks)))) + (parse-relative (chunks) + (case (caar chunks) + (#\; + (directory :relative) + (parse-directory (cdr chunks))) + (t + (directory :absolute) ; Assumption! Maybe revoked later. + (parse-directory chunks)))) + (parse-directory (chunks) + (case (caadr chunks) + (#\; + (directory + (let ((res (expecting "a directory name" chunks))) + (cond ((string= res "..") :up) + ((string= res "**") :wild-inferiors) + (t + (maybe-make-logical-pattern namestr chunks))))) + (parse-directory (cddr chunks))) + (t + (parse-name chunks)))) + (parse-name (chunks) + (when chunks + (expecting "a file name" chunks) + (setq name (maybe-make-logical-pattern namestr chunks)) + (expecting-dot (cdr chunks)))) + (expecting-dot (chunks) + (when chunks + (unless (eql (caar chunks) #\.) + (error 'namestring-parse-error + :complaint "expecting a dot, got ~S." + :args (list (caar chunks)) + :namestring namestr + :offset (cdar chunks))) + (if type + (parse-version (cdr chunks)) + (parse-type (cdr chunks))))) + (parse-type (chunks) + (expecting "a file type" chunks) + (setq type (maybe-make-logical-pattern namestr chunks)) + (expecting-dot (cdr chunks))) + (parse-version (chunks) + (let ((str (expecting "a positive integer, * or NEWEST" + chunks))) + (cond + ((string= str "*") (setq version :wild)) + ((string= str "NEWEST") (setq version :newest)) + (t + (multiple-value-bind (res pos) + (parse-integer str :junk-allowed t) + (unless (and res (plusp res)) + (error 'namestring-parse-error + :complaint "expected a positive integer, ~ + got ~S" + :args (list str) + :namestring namestr + :offset (+ pos (cdar chunks)))) + (setq version res))))) + (when (cdr chunks) + (error 'namestring-parse-error + :complaint "extra stuff after end of file name" + :namestring namestr + :offset (cdadr chunks))))) + (parse-host (logical-chunkify namestr start end))) (values host :unspecific (directory) name type version)))) ;;; We can't initialize this yet because not all host methods are ;;; loaded yet. (defvar *logical-pathname-defaults*) +(defun logical-namestring-p (x) + (and (stringp x) + (ignore-errors + (typep (pathname x) 'logical-pathname)))) + +(deftype logical-namestring () + `(satisfies logical-namestring-p)) + (defun logical-pathname (pathspec) #!+sb-doc "Converts the pathspec argument to a logical-pathname and returns it." (declare (type (or logical-pathname string stream) pathspec) - (values logical-pathname)) + (values logical-pathname)) (if (typep pathspec 'logical-pathname) pathspec - (let ((res (parse-namestring pathspec nil *logical-pathname-defaults*))) - (when (eq (%pathname-host res) - (%pathname-host *logical-pathname-defaults*)) - (error "This logical namestring does not specify a host:~% ~S" - pathspec)) - res))) + (flet ((oops (problem) + (error 'simple-type-error + :datum pathspec + :expected-type 'logical-namestring + :format-control "~S is not a valid logical namestring:~% ~A" + :format-arguments (list pathspec problem)))) + (let ((res (handler-case + (parse-namestring pathspec nil *logical-pathname-defaults*) + (error (e) (oops e))))) + (when (eq (%pathname-host res) + (%pathname-host *logical-pathname-defaults*)) + (oops "no host specified")) + res)))) ;;;; logical pathname unparsing @@ -1369,37 +1556,70 @@ a host-structure or string." (collect ((pieces)) (let ((directory (%pathname-directory pathname))) (when directory - (ecase (pop directory) - (:absolute) ; nothing special - (:relative (pieces ";"))) - (dolist (dir directory) - (cond ((or (stringp dir) (pattern-p dir)) - (pieces (unparse-logical-piece dir)) - (pieces ";")) - ((eq dir :wild) - (pieces "*;")) - ((eq dir :wild-inferiors) - (pieces "**;")) - (t - (error "invalid directory component: ~S" dir)))))) + (ecase (pop directory) + (:absolute) ; nothing special + (:relative (pieces ";"))) + (dolist (dir directory) + (cond ((or (stringp dir) (pattern-p dir)) + (pieces (unparse-logical-piece dir)) + (pieces ";")) + ((eq dir :wild) + (pieces "*;")) + ((eq dir :wild-inferiors) + (pieces "**;")) + (t + (error "invalid directory component: ~S" dir)))))) (apply #'concatenate 'simple-string (pieces)))) (defun unparse-logical-piece (thing) (etypecase thing + ((member :wild) "*") (simple-string thing) (pattern (collect ((strings)) (dolist (piece (pattern-pieces thing)) - (etypecase piece - (simple-string (strings piece)) - (keyword - (cond ((eq piece :wild-inferiors) - (strings "**")) - ((eq piece :multi-char-wild) - (strings "*")) - (t (error "invalid keyword: ~S" piece)))))) + (etypecase piece + (simple-string (strings piece)) + (keyword + (cond ((eq piece :wild-inferiors) + (strings "**")) + ((eq piece :multi-char-wild) + (strings "*")) + (t (error "invalid keyword: ~S" piece)))))) (apply #'concatenate 'simple-string (strings)))))) +(defun unparse-logical-file (pathname) + (declare (type pathname pathname)) + (collect ((strings)) + (let* ((name (%pathname-name pathname)) + (type (%pathname-type pathname)) + (version (%pathname-version pathname)) + (type-supplied (not (or (null type) (eq type :unspecific)))) + (version-supplied (not (or (null version) + (eq version :unspecific))))) + (when name + (when (and (null type) + (typep name 'string) + (position #\. name :start 1)) + (error "too many dots in the name: ~S" pathname)) + (strings (unparse-logical-piece name))) + (when type-supplied + (unless name + (error "cannot specify the type without a file: ~S" pathname)) + (when (typep type 'string) + (when (position #\. type) + (error "type component can't have a #\. inside: ~S" pathname))) + (strings ".") + (strings (unparse-logical-piece type))) + (when version-supplied + (unless type-supplied + (error "cannot specify the version without a type: ~S" pathname)) + (etypecase version + ((member :newest) (strings ".NEWEST")) + ((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)) @@ -1424,18 +1644,19 @@ a host-structure or string." ;; 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))) + (logical-host-name (%pathname-host pathname)) ":" + (unparse-logical-directory pathname) + (unparse-logical-file pathname))) ;;;; logical pathname translations @@ -1444,80 +1665,105 @@ a host-structure or string." ;;; into patterns.) (defun canonicalize-logical-pathname-translations (translation-list host) (declare (type list translation-list) (type host host) - (values list)) + (values list)) (mapcar (lambda (translation) - (destructuring-bind (from to) translation - (list (if (typep from 'logical-pathname) - from - (parse-namestring from host)) - (pathname to)))) - translation-list)) + (destructuring-bind (from to) translation + (list (if (typep from 'logical-pathname) + from + (parse-namestring from host)) + (pathname to)))) + translation-list)) (defun logical-pathname-translations (host) #!+sb-doc "Return the (logical) host object argument's list of translations." (declare (type (or string logical-host) host) - (values list)) + (values list)) (logical-host-translations (find-logical-host host))) (defun (setf logical-pathname-translations) (translations host) #!+sb-doc "Set the translations list for the logical host argument." (declare (type (or string logical-host) host) - (type list translations) - (values list)) + (type list translations) + (values list)) (let ((host (intern-logical-host host))) (setf (logical-host-canon-transls host) - (canonicalize-logical-pathname-translations translations host)) + (canonicalize-logical-pathname-translations translations host)) (setf (logical-host-translations host) translations))) -;;; KLUDGE: Ordinarily known functions aren't defined recursively, and -;;; it's common for compiler problems (e.g. missing/broken -;;; optimization transforms) to cause them to recurse inadvertently, -;;; so the compiler should warn about it. But the natural definition -;;; of TRANSLATE-LOGICAL-PATHNAME *is* recursive; and we don't want -;;; the warning, so we hide the definition of T-L-P in this -;;; differently named function so that the compiler won't warn about -;;; it. -- WHN 2001-09-16 -(defun %translate-logical-pathname (pathname) +(defun translate-logical-pathname (pathname &key) + #!+sb-doc + "Translate PATHNAME to a physical pathname, which is returned." (declare (type pathname-designator pathname) - (values (or null pathname))) + (values (or null pathname))) (typecase pathname (logical-pathname (dolist (x (logical-host-canon-transls (%pathname-host pathname)) - (error 'simple-file-error - :pathname pathname - :format-control "no translation for ~S" - :format-arguments (list pathname))) + (error 'simple-file-error + :pathname pathname + :format-control "no translation for ~S" + :format-arguments (list pathname))) (destructuring-bind (from to) x - (when (pathname-match-p pathname from) - (return (translate-logical-pathname - (translate-pathname pathname from to))))))) + (when (pathname-match-p pathname from) + (return (translate-logical-pathname + (translate-pathname pathname from to))))))) (pathname pathname) (t (translate-logical-pathname (pathname pathname))))) -(defun translate-logical-pathname (pathname &key) - #!+sb-doc - "Translate PATHNAME to a physical pathname, which is returned." - (declare (type pathname-designator pathname) - (values (or null pathname))) - (%translate-logical-pathname pathname)) - (defvar *logical-pathname-defaults* - (%make-logical-pathname (make-logical-host :name "BOGUS") - :unspecific - nil - nil - nil - nil)) + (%make-logical-pathname + (make-logical-host :name (logical-word-or-lose "BOGUS")) + :unspecific nil nil nil nil)) (defun load-logical-pathname-translations (host) #!+sb-doc + "Reads logical pathname translations from SYS:SITE;HOST.TRANSLATIONS.NEWEST, +with HOST replaced by the supplied parameter. Returns T on success. + +If HOST is already defined as logical pathname host, no file is loaded and NIL +is returned. + +The file should contain a single form, suitable for use with +\(SETF LOGICAL-PATHNAME-TRANSLATIONS). + +Note: behaviour of this function is higly implementation dependent, and +historically it used to be a no-op in SBcL -- the current approach is somewhat +experimental and subject to change." (declare (type string host) - (values (member t nil))) + (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 - (error "logical host ~S not found" host))) + ;; implementation-defined." + (prog1 t + (setf (logical-pathname-translations host) + (with-open-file (lpt (make-pathname :host "SYS" + :directory '(:absolute "SITE") + :name host + :type "TRANSLATIONS" + :version :newest)) + (read lpt)))))) + +(defun !pathname-cold-init () + (let* ((sys *default-pathname-defaults*) + (src + (merge-pathnames + (make-pathname :directory '(:relative "src" :wild-inferiors) + :name :wild :type :wild) + sys)) + (contrib + (merge-pathnames + (make-pathname :directory '(:relative "contrib" :wild-inferiors) + :name :wild :type :wild) + sys)) + (output + (merge-pathnames + (make-pathname :directory '(:relative "output" :wild-inferiors) + :name :wild :type :wild) + sys))) + (setf (logical-pathname-translations "SYS") + `(("SYS:SRC;**;*.*.*" ,src) + ("SYS:CONTRIB;**;*.*.*" ,contrib) + ("SYS:OUTPUT;**;*.*.*" ,output)))))