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
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
(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)
(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)
--- /dev/null
+@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
* Efficiency::
* Beyond the ANSI Standard::
* Foreign Function Interface::
+* Pathnames::
* Extensible Streams::
* Package Locks::
* Threading::
@include efficiency.texinfo
@include beyond-ansi.texinfo
@include ffi.texinfo
+@include pathnames.texinfo
@include streams.texinfo
@include package-locks.texi-temp
@include threading.texinfo
"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"
(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 ()
(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)
(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
(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
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)
(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 ()
(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.
(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.
;;; 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)
(: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))))
(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.
(: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)
(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))
\f
;;; pathname methods
(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
(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.
;; 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
;; 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))
(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
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."
(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 ()
;; 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)
((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))
(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.
;;; 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))))
;;; 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"
projects / sbcl.git / commitdiff