From fec3614baf361523a4fb154ed80d9b73e1452b2d Mon Sep 17 00:00:00 2001 From: Christophe Rhodes Date: Fri, 16 Dec 2005 15:06:09 +0000 Subject: [PATCH] 0.9.7.31: Merge essentially as "Pathname goodness" from CSR sbcl-devel 2005-12-15. ... define pathname host-specific PARSE-NATIVE and UNPARSE-NATIVE methods. ... define NATIVE-PATHNAME, NATIVE-NAMESTRING and PARSE-NATIVE-NAMESTRING in a direct analogy with PATHNAME, NAMESTRING and PARSE-NAMESTRING. ... use NATIVE-PATHNAME both on what POSIX-GETCWD/ returns and on files the user has asked us to load at the command line. (Fixes bug #296 and *DEFAULT-PATHNAME-DEFAULTS* being wrong when a component of the current directory contains a pathname metacharacter in "[*?\\") ... don't create a string from --load (and --disable-debugger) that just gets read again; instead allow process-eval-options to deal with non-strings too. ... tease *physical-host* (the default physical host on the platform) and *unix-host* apart ever so slightly, with obvious knock-on benefits for ports to non-Unixoid platforms. ... sb-posix no longer needs its own implementation of NATIVE-FILENAME. ... delete unused UNIX-MAYBE-PREPEND-DIRECTORY. ... some tests and some documentation. --- BUGS | 8 - NEWS | 2 + contrib/sb-introspect/sb-introspect.lisp | 6 +- contrib/sb-posix/macros.lisp | 28 +-- doc/manual/pathnames.texinfo | 97 +++++++++ doc/manual/sbcl.texinfo | 2 + package-data-list.lisp-expr | 5 + src/code/bsd-os.lisp | 6 +- src/code/filesys.lisp | 77 ++++++- src/code/linux-os.lisp | 8 +- src/code/osf1-os.lisp | 8 +- src/code/pathname.lisp | 10 + src/code/sunos-os.lisp | 6 +- src/code/target-pathname.lisp | 335 ++++++++++++++++++++---------- src/code/toplevel.lisp | 41 ++-- src/code/unix.lisp | 16 -- tests/filesys.pure.lisp | 45 ++++ version.lisp-expr | 2 +- 18 files changed, 497 insertions(+), 205 deletions(-) create mode 100644 doc/manual/pathnames.texinfo diff --git a/BUGS b/BUGS index 220c486..14fba6f 100644 --- a/BUGS +++ b/BUGS @@ -971,14 +971,6 @@ WORKAROUND: the control word; however, this clobbers any change the user might have made. -296: - (reported by Adam Warner, sbcl-devel 2003-09-23) - - The --load toplevel argument does not perform any sanitization of its - argument. As a result, files with Lisp pathname pattern characters - (#\* or #\?, for instance) or quotation marks can cause the system - to perform arbitrary behaviour. - 297: LOOP with non-constant arithmetic step clauses suffers from overzealous type constraint: code of the form diff --git a/NEWS b/NEWS index 393e251..11bf76e 100644 --- a/NEWS +++ b/NEWS @@ -5,6 +5,8 @@ changes in sbcl-0.9.8 relative to sbcl-0.9.7: the change in the 0.9.7 release). (SETF CLASS-NAME) is specified by ANSI as a generic function, and for consistency (SETF GENERIC-FUNCTION-NAME) is treated likewise. + * fixed bug #296: no more arbitrary behaviour from filenames with + odd characters as --load arguments. (reported by Adam Warner) * fixed bug #390: :CHARACTER-SET pathname components now work as expected. (reported by Tim Daly Jr) * fixed bug #391: complicated :TYPE intersections in slot diff --git a/contrib/sb-introspect/sb-introspect.lisp b/contrib/sb-introspect/sb-introspect.lisp index cd328d3..d0bcbac 100644 --- a/contrib/sb-introspect/sb-introspect.lisp +++ b/contrib/sb-introspect/sb-introspect.lisp @@ -141,9 +141,9 @@ If an unsupported TYPE is requested, the function will return NIL. (if (listp x) x (list x))) - (get-class (name) - (and (symbolp name) - (find-class name nil)))) + (get-class (name) + (and (symbolp name) + (find-class name nil)))) (listify (case type ((:variable) diff --git a/contrib/sb-posix/macros.lisp b/contrib/sb-posix/macros.lisp index 2e0d4bf..2399c98 100644 --- a/contrib/sb-posix/macros.lisp +++ b/contrib/sb-posix/macros.lisp @@ -1,34 +1,8 @@ (in-package :sb-posix-internal) -;;; some explanation may be necessary. The namestring "[foo]" -;;; denotes a wild pathname. When there's a file on the disk whose -;;; Unix name is "[foo]", the appropriate CL namestring for it is -;;; "\\[foo]". So, don't call NAMESTRING, instead call a function -;;; that gets us the Unix name -(defun native-filename (pathname) - (let ((directory (pathname-directory pathname)) - (name (pathname-name pathname)) - (type (pathname-type pathname))) - (with-output-to-string (s nil :element-type 'base-char) - (etypecase directory - (string (write-string directory s)) - (list - (when (eq (car directory) :absolute) - (write-char #\/ s)) - (dolist (piece (cdr directory)) - (etypecase piece - (string (write-string piece s) (write-char #\/ s)) - ((member :up) (write-string "../" s)))))) - (etypecase name - (null) - (string (write-string name s))) - (etypecase type - (null) - (string (write-char #\. s) (write-string type s)))))) - (define-designator filename c-string (pathname - (native-filename (translate-logical-pathname filename))) + (sb-ext:native-namestring (translate-logical-pathname filename))) (string filename)) (define-designator file-descriptor (integer 32) diff --git a/doc/manual/pathnames.texinfo b/doc/manual/pathnames.texinfo new file mode 100644 index 0000000..f1faf01 --- /dev/null +++ b/doc/manual/pathnames.texinfo @@ -0,0 +1,97 @@ +@node Pathnames +@comment node-name, next, previous, up +@chapter Pathnames + +@menu +* Lisp Pathnames:: +* Native Filenames:: +@end menu + +@node Lisp Pathnames +@comment node-name, next, previous, up +@section Lisp Pathnames + +There are many aspects of ANSI Common Lisp's pathname support which are +implementation-defined and so need documentation. + +@c FIXME: as a matter of ANSI conformance, we are required to document +@c implementation-defined stuff, which for pathnames (chapter 19 of CLtS) +@c includes: +@c +@c * Otherwise, the parsing of thing is implementation-defined. +@c (PARSE-NAMESTRING) +@c +@c * If thing contains an explicit host name and no explicit device name, +@c then it is implementation-defined whether parse-namestring will supply +@c the standard default device for that host as the device component of +@c the resulting pathname. (PARSE-NAMESTRING) +@c +@c * The specific nature of the search is implementation-defined. +@c (LOAD-LOGICAL-PATHNAME-TRANSLATIONS) +@c +@c * Any additional elements are implementation-defined. +@c (LOGICAL-PATHNAME-TRANSLATIONS) +@c +@c * The matching rules are implementation-defined but should be consistent +@c with directory. (PATHNAME-MATCH-P) +@c +@c * Any such additional translations are implementation-defined. +@c (TRANSLATE-LOGICAL-PATHNAMES) +@c +@c * ...or an implementation-defined portion of a component... +@c (TRANSLATE-PATHNAME) +@c +@c * The portion of source that is copied into the resulting pathname is +@c implementation-defined. (TRANSLATE-PATHNAME) +@c +@c * During the copying of a portion of source into the resulting +@c pathname, additional implementation-defined translations of case or +@c file naming conventions might occur. (TRANSLATE-PATHNAME) +@c +@c * In general, the syntax of namestrings involves the use of +@c implementation-defined conventions. (19.1.1) +@c +@c * The nature of the mapping between structure imposed by pathnames and +@c the structure, if any, that is used by the underlying file system is +@c implementation-defined. (19.1.2) +@c +@c * The mapping of the pathname components into the concepts peculiar to +@c each file system is implementation-defined. (19.1.2) +@c +@c * Whether separator characters are permitted as part of a string in a +@c pathname component is implementation-defined; (19.2.2.1.1) +@c +@c * Whether a value of :unspecific is permitted for any component on any +@c given file system accessible to the implementation is +@c implementation-defined. (19.2.2.2.3) +@c +@c * Other symbols and integers have implementation-defined meaning. +@c (19.2.2.4.6) +@c +@c * The existence and meaning of SYS: logical pathnames is +@c implementation-defined. (19.3.1.1.1) + +@node Native Filenames +@comment node-name, next, previous, up +@section Native Filenames + +In some circumstances, what is wanted is a Lisp pathname object which +corresponds to a string produced by the Operating System. In this case, +some of the default parsing rules are inappropriate: most filesystems do +not have a native understanding of wild pathnames; such functionality is +often provided by shells above the OS, often in mutually-incompatible +ways. + +To allow the user to deal with this, the following functions are +provided: @code{parse-native-namestring} and @code{native-pathname} +return the closest equivalent Lisp pathname to a given string +(appropriate for the Operating System), while @code{native-namestring} +converts a non-wild pathname designator to the equivalent native +namestring, if possible. Some Lisp pathname concepts (such as the +@code{:back} directory component) have no direct equivalents in most +Operating Systems; the behaviour of @code{native-namestring} is +unspecified if an inappropriate pathname designator is passed to it. + +@include fun-sb-ext-parse-native-namestring.texinfo +@include fun-sb-ext-native-pathname.texinfo +@include fun-sb-ext-native-namestring.texinfo diff --git a/doc/manual/sbcl.texinfo b/doc/manual/sbcl.texinfo index ea5c44a..a1aa289 100644 --- a/doc/manual/sbcl.texinfo +++ b/doc/manual/sbcl.texinfo @@ -59,6 +59,7 @@ provided with absolutely no warranty. See the @file{COPYING} and * Efficiency:: * Beyond the ANSI Standard:: * Foreign Function Interface:: +* Pathnames:: * Extensible Streams:: * Package Locks:: * Threading:: @@ -82,6 +83,7 @@ provided with absolutely no warranty. See the @file{COPYING} and @include efficiency.texinfo @include beyond-ansi.texinfo @include ffi.texinfo +@include pathnames.texinfo @include streams.texinfo @include package-locks.texi-temp @include threading.texinfo diff --git a/package-data-list.lisp-expr b/package-data-list.lisp-expr index e0a5612..80006e6 100644 --- a/package-data-list.lisp-expr +++ b/package-data-list.lisp-expr @@ -735,6 +735,11 @@ like *STACK-TOP-HINT* and unsupported stuff like *TRACED-FUN-LIST*." "PROCESS-PID" "PROCESS-PLIST" "PROCESS-PTY" "PROCESS-STATUS" "PROCESS-STATUS-HOOK" "PROCESS-WAIT" + ;; pathnames + "NATIVE-PATHNAME" + "PARSE-NATIVE-NAMESTRING" + "NATIVE-NAMESTRING" + ;; external-format support "OCTETS-TO-STRING" "STRING-TO-OCTETS" diff --git a/src/code/bsd-os.lisp b/src/code/bsd-os.lisp index ed8d868..b9c8009 100644 --- a/src/code/bsd-os.lisp +++ b/src/code/bsd-os.lisp @@ -36,12 +36,12 @@ (defun os-cold-init-or-reinit () (setf *software-version* nil) (setf *default-pathname-defaults* - ;; (temporary value, so that #'PATHNAME won't blow up when + ;; (temporary value, so that #'NATIVE-PATHNAME won't blow up when ;; we call it below:) (make-trivial-default-pathname) *default-pathname-defaults* - ;; (final value, constructed using #'PATHNAME:) - (pathname (sb!unix:posix-getcwd/)))) + ;; (final value, constructed using #'NATIVE-PATHNAME:) + (native-pathname (sb!unix:posix-getcwd/)))) ;;; Return system time, user time and number of page faults. (defun get-system-info () diff --git a/src/code/filesys.lisp b/src/code/filesys.lisp index 2887bac..9349fe9 100644 --- a/src/code/filesys.lisp +++ b/src/code/filesys.lisp @@ -191,18 +191,19 @@ (setf start (1+ slash)))) (values absolute (pieces))))) -(defun parse-unix-namestring (namestr start end) - (declare (type simple-string namestr) +(defun parse-unix-namestring (namestring start end) + (declare (type simple-string namestring) (type index start end)) - (setf namestr (coerce namestr 'simple-base-string)) - (multiple-value-bind (absolute pieces) (split-at-slashes namestr start end) + (setf namestring (coerce namestring 'simple-base-string)) + (multiple-value-bind (absolute pieces) + (split-at-slashes namestring start end) (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-name-type-and-version namestr tail-start tail-end))) + (extract-name-type-and-version namestring tail-start tail-end))) (when (stringp name) (let ((position (position-if (lambda (char) @@ -212,7 +213,7 @@ (when position (error 'namestring-parse-error :complaint "can't embed #\\Nul or #\\/ in Unix namestring" - :namestring namestr + :namestring namestring :offset position)))) ;; Now we have everything we want. So return it. (values nil ; no host for Unix namestrings @@ -222,16 +223,16 @@ (let ((piece-start (car piece)) (piece-end (cdr piece))) (unless (= piece-start piece-end) - (cond ((string= namestr ".." + (cond ((string= namestring ".." :start1 piece-start :end1 piece-end) (dirs :up)) - ((string= namestr "**" + ((string= namestring "**" :start1 piece-start :end1 piece-end) (dirs :wild-inferiors)) (t - (dirs (maybe-make-pattern namestr + (dirs (maybe-make-pattern namestring piece-start piece-end))))))) (cond (absolute @@ -244,6 +245,37 @@ type version)))) +(defun parse-native-unix-namestring (namestring start end) + (declare (type simple-string namestring) + (type index start end)) + (setf namestring (coerce namestring 'simple-base-string)) + (multiple-value-bind (absolute ranges) + (split-at-slashes namestring start end) + (let* ((components (loop for ((start . end) . rest) on ranges + for piece = (subseq namestring start end) + collect (if (and (string= piece "..") rest) + :up + piece))) + (name-and-type + (let* ((end (first (last components))) + (dot (position #\. end :from-end t))) + ;; FIXME: can we get this dot-interpretation knowledge + ;; from existing code? EXTRACT-NAME-TYPE-AND-VERSION + ;; does slightly more work than that. + (cond + ((string= end "") + (list nil nil)) + ((and dot (> dot 0)) + (list (subseq end 0 dot) (subseq end (1+ dot)))) + (t + (list end nil)))))) + (values nil + nil + (cons (if absolute :absolute :relative) (butlast components)) + (first name-and-type) + (second name-and-type) + nil)))) + (/show0 "filesys.lisp 300") (defun unparse-unix-host (pathname) @@ -366,6 +398,33 @@ (unparse-unix-directory pathname) (unparse-unix-file pathname))) +(defun unparse-native-unix-namestring (pathname) + (declare (type pathname pathname)) + (let ((directory (pathname-directory pathname)) + (name (pathname-name pathname)) + (type (pathname-type pathname))) + (coerce + (with-output-to-string (s) + (ecase (car directory) + (:absolute (write-char #\/ s)) + (:relative)) + (dolist (piece (cdr directory)) + (typecase piece + ((member :up) (write-string ".." s)) + (string (write-string piece s)) + (t (error "ungood piece in NATIVE-NAMESTRING: ~S" piece))) + (write-char #\/ s)) + (when name + (unless (stringp name) + (error "non-STRING name in NATIVE-NAMESTRING: ~S" name)) + (write-string name s) + (when type + (unless (stringp type) + (error "non-STRING type in NATIVE-NAMESTRING: ~S" name)) + (write-char #\. s) + (write-string type s)))) + 'simple-base-string))) + (defun unparse-unix-enough (pathname defaults) (declare (type pathname pathname defaults)) (flet ((lose () diff --git a/src/code/linux-os.lisp b/src/code/linux-os.lisp index 585401e..14f758d 100644 --- a/src/code/linux-os.lisp +++ b/src/code/linux-os.lisp @@ -42,12 +42,12 @@ (setf *software-version* nil) (/show0 "setting *DEFAULT-PATHNAME-DEFAULTS*") (setf *default-pathname-defaults* - ;; (temporary value, so that #'PATHNAME won't blow up when - ;; we call it below:) + ;; (temporary value, so that #'NATIVE-PATHNAME won't blow up + ;; when we call it below:) (make-trivial-default-pathname) *default-pathname-defaults* - ;; (final value, constructed using #'PATHNAME:) - (pathname (sb!unix:posix-getcwd/))) + ;; (final value, constructed using #'NATIVE-PATHNAME:) + (native-pathname (sb!unix:posix-getcwd/))) (/show0 "leaving linux-os.lisp OS-COLD-INIT-OR-REINIT")) ;;; Return system time, user time and number of page faults. diff --git a/src/code/osf1-os.lisp b/src/code/osf1-os.lisp index 2ef75b8..abc4c02 100644 --- a/src/code/osf1-os.lisp +++ b/src/code/osf1-os.lisp @@ -38,12 +38,12 @@ (setf *software-version* nil) (/show "setting *DEFAULT-PATHNAME-DEFAULTS*") (setf *default-pathname-defaults* - ;; (temporary value, so that #'PATHNAME won't blow up when - ;; we call it below:) + ;; (temporary value, so that #'NATIVE-PATHNAME won't blow up + ;; when we call it below:) (make-trivial-default-pathname) *default-pathname-defaults* - ;; (final value, constructed using #'PATHNAME:) - (pathname (sb!unix:posix-getcwd/))) + ;; (final value, constructed using #'NATIVE-PATHNAME:) + (native-pathname (sb!unix:posix-getcwd/))) (/show "leaving osf1-os.lisp OS-COLD-INIT-OR-REINIT")) ;;; Return system time, user time and number of page faults. diff --git a/src/code/pathname.lisp b/src/code/pathname.lisp index 6d3052d..18c14b9 100644 --- a/src/code/pathname.lisp +++ b/src/code/pathname.lisp @@ -18,7 +18,9 @@ ;;; translation the inverse (unparse) functions. (def!struct (host (:constructor nil)) (parse (missing-arg) :type function) + (parse-native (missing-arg) :type function) (unparse (missing-arg) :type function) + (unparse-native (missing-arg) :type function) (unparse-host (missing-arg) :type function) (unparse-directory (missing-arg) :type function) (unparse-file (missing-arg) :type function) @@ -32,7 +34,15 @@ (:make-load-form-fun make-logical-host-load-form-fun) (:include host (parse #'parse-logical-namestring) + (parse-native + (lambda (x) + (error "called PARSE-NATIVE-NAMESTRING using a ~ + logical host: ~S" x))) (unparse #'unparse-logical-namestring) + (unparse-native + (lambda (x) + (error "called NATIVE-NAMESTRING using a ~ + logical host: ~S" x))) (unparse-host (lambda (x) (logical-host-name (%pathname-host x)))) diff --git a/src/code/sunos-os.lisp b/src/code/sunos-os.lisp index 63e4e31..7134c38 100644 --- a/src/code/sunos-os.lisp +++ b/src/code/sunos-os.lisp @@ -38,12 +38,12 @@ (setf *software-version* nil) (/show "setting *DEFAULT-PATHNAME-DEFAULTS*") (setf *default-pathname-defaults* - ;; (temporary value, so that #'PATHNAME won't blow up when + ;; (temporary value, so that #'NATIVE-PATHNAME won't blow up when ;; we call it below:) (make-trivial-default-pathname) *default-pathname-defaults* - ;; (final value, constructed using #'PATHNAME:) - (pathname (sb!unix:posix-getcwd/))) + ;; (final value, constructed using #'NATIVE-PATHNAME:) + (native-pathname (sb!unix:posix-getcwd/))) (/show "leaving sunos-os.lisp OS-COLD-INIT-OR-REINIT")) ;;; Return system time, user time and number of page faults. diff --git a/src/code/target-pathname.lisp b/src/code/target-pathname.lisp index 8c0f0fa..226e4c4 100644 --- a/src/code/target-pathname.lisp +++ b/src/code/target-pathname.lisp @@ -19,7 +19,9 @@ (: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-unix-directory) (unparse-file #'unparse-unix-file) @@ -32,11 +34,13 @@ (declare (ignore host)) '*unix-host*) +(defvar *physical-host* *unix-host*) + ;;; Return a value suitable, e.g., for preinitializing ;;; *DEFAULT-PATHNAME-DEFAULTS* before *DEFAULT-PATHNAME-DEFAULTS* is ;;; initialized (at which time we can't safely call e.g. #'PATHNAME). (defun make-trivial-default-pathname () - (%make-pathname *unix-host* nil nil nil nil :newest)) + (%make-pathname *physical-host* nil nil nil nil :newest)) ;;; pathname methods @@ -81,7 +85,7 @@ (upcase-maybe type) version) (progn - (aver (eq host *unix-host*)) + (aver (eq host *physical-host*)) (%make-pathname host device directory name type version))))) ;;; Hash table searching maps a logical pathname's host to its @@ -271,26 +275,92 @@ (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) +(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))) + +(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))) + +(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 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." + (declare (type pathname-designator pathspec)) + (with-pathname (pathname pathspec) + pathname)) + +(defun native-pathname (pathspec) + #!+sb-doc + "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. @@ -485,11 +555,7 @@ a host-structure or string." ;; 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 + (host (or (find-host host nil) default-host)) (diddle-args (and (eq (host-customary-case host) :lower) (eq case :common))) (diddle-defaults @@ -670,7 +736,7 @@ a host-structure or string." ;; implementation-defined." ;; ;; Both clauses are handled here, as the default - ;; *DEFAULT-PATHNAME-DEFAULTS has a SB-IMPL::UNIX-HOST + ;; *DEFAULT-PATHNAME-DEFAULTS* has a SB-IMPL::UNIX-HOST ;; for a host. ((pathname-host defaults) (funcall (host-parse (pathname-host defaults)) @@ -726,90 +792,127 @@ a host-structure or string." (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*) + (with-host (found-host host) + (let (;; According to ANSI defaults may be any valid pathname designator + (defaults (etypecase defaults + (pathname + defaults) (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))) - ;; According to ANSI defaults may be any valid pathname designator - (defaults (etypecase defaults - (pathname - defaults) - (string - (aver (pathnamep *default-pathname-defaults*)) - (parse-namestring defaults)) - (stream - (truename defaults))))) - (declare (type (or null host) found-host) - (type pathname defaults)) - (etypecase thing - (simple-string - (%parse-namestring thing found-host defaults start end junk-allowed)) - (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)))))) + (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) + (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)) + ((pathname-host defaults) + (funcall (host-parse-native (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 + :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) + #!+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." + (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)) + (string + (%parse-native-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 + ;; 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 @@ -823,6 +926,18 @@ a host-structure or string." host:~% ~S" pathname)) (funcall (host-unparse host) pathname))))) +(defun native-namestring (pathname) + #!+sb-doc + "Construct the full native (name)string form of PATHNAME." + (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))))) + (defun host-namestring (pathname) #!+sb-doc "Return a string representation of the name of the host in the pathname." diff --git a/src/code/toplevel.lisp b/src/code/toplevel.lisp index 13bd93e..9c01fa9 100644 --- a/src/code/toplevel.lisp +++ b/src/code/toplevel.lisp @@ -324,23 +324,29 @@ steppers to maintain contextual information.") (abort () :report "Skip rest of initialization file.")))) -(defun process-eval-options (eval-strings) +(defun process-eval-options (eval-strings-or-forms) (/show0 "handling --eval options") - (flet ((process-1 (string) - (multiple-value-bind (expr pos) (read-from-string string) - (unless (eq string (read-from-string string nil string :start pos)) - (error "More than one expression in ~S" string)) - (eval expr) - (flush-standard-output-streams)))) + (flet ((process-1 (string-or-form) + (etypecase string-or-form + (string + (multiple-value-bind (expr pos) (read-from-string string-or-form) + (unless (eq string-or-form + (read-from-string string-or-form nil string-or-form + :start pos)) + (error "More than one expression in ~S" string-or-form)) + (eval expr) + (flush-standard-output-streams))) + (cons (eval string-or-form) (flush-standard-output-streams))))) (restart-case - (dolist (expr-as-string eval-strings) + (dolist (expr-as-string-or-form eval-strings-or-forms) (/show0 "handling one --eval option") (restart-case - (handler-bind ((error (lambda (e) - (error "Error during processing of --eval ~ - option ~S:~%~% ~A" - expr-as-string e)))) - (process-1 expr-as-string)) + (handler-bind + ((error (lambda (e) + (error "Error during processing of --eval ~ + option ~S:~%~% ~A" + expr-as-string-or-form e)))) + (process-1 expr-as-string-or-form)) (continue () :report "Ignore and continue with next --eval option."))) (abort () @@ -359,7 +365,9 @@ steppers to maintain contextual information.") ;; The values are stored as strings, so that they can be ;; passed to READ only after their predecessors have been ;; EVALed, so that things work when e.g. REQUIRE in one EVAL - ;; form creates a package referred to in the next EVAL form. + ;; form creates a package referred to in the next EVAL form, + ;; except for forms transformed from syntactically-sugary + ;; switches like --load and --disable-debugger. (reversed-evals nil) ;; Has a --noprint option been seen? (noprint nil) @@ -412,15 +420,14 @@ steppers to maintain contextual information.") ((string= option "--load") (pop-option) (push - ;; FIXME: see BUG 296 - (concatenate 'string "(|LOAD| \"" (pop-option) "\")") + (list 'cl:load (native-pathname (pop-option))) reversed-evals)) ((string= option "--noprint") (pop-option) (setf noprint t)) ((string= option "--disable-debugger") (pop-option) - (push "(|DISABLE-DEBUGGER|)" reversed-evals)) + (push (list 'sb!ext:disable-debugger) reversed-evals)) ((string= option "--end-toplevel-options") (pop-option) (return)) diff --git a/src/code/unix.lisp b/src/code/unix.lisp index e6dfddf..3ef530f 100644 --- a/src/code/unix.lisp +++ b/src/code/unix.lisp @@ -327,22 +327,6 @@ SYSCALL-FORM. Repeat evaluation of SYSCALL-FORM if it is interrupted." (defun posix-getcwd/ () (concatenate 'string (posix-getcwd) "/")) -;;; Convert at the UNIX level from a possibly relative filename to -;;; an absolute filename. -;;; -;;; FIXME: Do we still need this even as we switch to -;;; *DEFAULT-PATHNAME-DEFAULTS*? I think maybe we do, since it seems -;;; to be valid for the user to set *DEFAULT-PATHNAME-DEFAULTS* to -;;; have a NIL directory component, and then this'd be the only way to -;;; interpret a relative directory specification. But I don't find the -;;; ANSI pathname documentation to be a model of clarity. Maybe -;;; someone who understands it better can take a look at this.. -- WHN -(defun unix-maybe-prepend-current-directory (name) - (declare (simple-string name)) - (if (and (> (length name) 0) (char= (schar name 0) #\/)) - name - (concatenate 'simple-string (posix-getcwd/) name))) - ;;; Duplicate an existing file descriptor (given as the argument) and ;;; return it. If FD is not a valid file descriptor, NIL and an error ;;; number are returned. diff --git a/tests/filesys.pure.lisp b/tests/filesys.pure.lisp index 4a5d0be..e9abce8 100644 --- a/tests/filesys.pure.lisp +++ b/tests/filesys.pure.lisp @@ -84,3 +84,48 @@ ;;; reported a fix for CMU CL, which was ported to sbcl-0.6.12.35.) (assert (typep (nth-value 1 (ignore-errors (file-length *terminal-io*))) 'type-error)) + +;;; Test for NATIVE-PATHNAME / NATIVE-NAMESTRING stuff +;;; +;;; given only safe characters in the namestring, NATIVE-PATHNAME will +;;; never error, and NATIVE-NAMESTRING on the result will return the +;;; original namestring. +(let ((safe-chars + ;; for WIN32, we might want to remove #\: here + (coerce + (cons #\Newline + (loop for x from 32 to 127 collect (code-char x))) + 'simple-base-string)) + (tricky-sequences #("/../" "../" "/.." "." "/." "./" "/./" + "[]" "*" "**" "/**" "**/" "/**/" "?" + "\\*" "\\[]" "\\?" "\\*\\*" "*\\*"))) + (loop repeat 1000 + for length = (random 32) + for native-namestring = (coerce + (loop repeat length + collect + (char safe-chars + (random (length safe-chars)))) + 'simple-base-string) + for pathname = (native-pathname native-namestring) + for nnn = (native-namestring pathname) + do (assert (string= nnn native-namestring))) + (loop repeat 1000 + for native-namestring = (with-output-to-string (s) + (loop + (let ((r (random 1.0))) + (cond + ((< r 1/20) (return)) + ((< r 1/2) + (write-char + (char safe-chars + (random (length safe-chars))) + s)) + (t (write-string + (aref tricky-sequences + (random + (length tricky-sequences))) + s)))))) + for pathname = (native-pathname native-namestring) + for nnn = (native-namestring pathname) + do (assert (string= nnn native-namestring)))) diff --git a/version.lisp-expr b/version.lisp-expr index 9d11339..cca7241 100644 --- a/version.lisp-expr +++ b/version.lisp-expr @@ -17,4 +17,4 @@ ;;; checkins which aren't released. (And occasionally for internal ;;; versions, especially for internal versions off the main CVS ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".) -"0.9.7.30" +"0.9.7.31" -- 1.7.10.4