From: Christophe Rhodes Date: Tue, 27 Jan 2004 10:34:54 +0000 (+0000) Subject: 0.8.7.22: X-Git-Url: http://repo.macrolet.net/gitweb/?a=commitdiff_plain;h=696e38f7210c587ba0b54795f4795f58e62fed2d;p=sbcl.git 0.8.7.22: RIP (physical) PATHNAME-VERSION significance ... remove all internal discrimination based on the version field if the pathname involved has the Unix host. ... parsing of a physical pathname namestring (i.e. again either explicitly or implicitly on the Unix host) never produces a version from the namestring. ... make :if-exists :new-version behave like :if-exists :error, because despite weasel-words in CLHS someone might legitimately expect :if-exists :new-version not to clobber the old version. ... (this latter needs to be revisited, when OPEN is made aware of logical pathnames and the wacky logic they impose; we can support :new-version with LPNs, but only if OPEN is clever). ... make pathnames more likely to be read/print consistent, by throwing errors in more cases (we now pass PFD's test for that, not that it's that stringent). ... throw errors on use of (:absolute :up) and friends in CL operators, but... ... don't throw error on creation, and in fact test in sb-posix that we can use #p"/../" for what it means. --- diff --git a/NEWS b/NEWS index ee020d9..ea7f17a 100644 --- a/NEWS +++ b/NEWS @@ -2234,6 +2234,18 @@ changes in sbcl-0.8.7 relative to sbcl-0.8.6: ** VALUES tranformer lost derived type. changes in sbcl-0.8.8 relative to sbcl-0.8.7: + * minor incompatible change: parsing of namestrings on a physical + (Unix) host has changed; numbers after the final #\. in a + namestring are no longer interpreted as a version field. This is + intented to be largely invisible to the user, except that the + meaning of the namestring "*.*.*" has changed: it now refers to a + pathname with :TYPE :WILD :NAME #. This namestring + should usually be replaced by + (make-pathname :name :wild :type :wild :version :wild) + with the added benefit that this is more likely to be portable. + As a consequence of this change, the :IF-EXISTS :NEW-VERSION + option to OPEN now signals an error if the file being opened + exists; this may have an impact on existing code. * bug fix: DECODE-UNIVERSAL-TIME now accepts timezone arguments with second-resolution: integer multiples of 1/3600 between -24 and 24. (thanks to Vincent Arkesteijn) @@ -2266,6 +2278,11 @@ changes in sbcl-0.8.8 relative to sbcl-0.8.7: or not a character is whitespace. ** MERGE-PATHNAMES handles the case when the pathname does not specify a name while the default-pathname specifies a version. + ** Pathnames now stand a better chance of respecting print/read + consistency. + ** Attempting to use standardized file system operators with a + pathname with invalid :DIRECTORY components signals a + FILE-ERROR. planned incompatible changes in 0.8.x: * (not done yet, but planned:) When the profiling interface settles diff --git a/contrib/sb-executable/sb-executable.lisp b/contrib/sb-executable/sb-executable.lisp index 4273d8d..90d39d4 100644 --- a/contrib/sb-executable/sb-executable.lisp +++ b/contrib/sb-executable/sb-executable.lisp @@ -30,7 +30,9 @@ exec sbcl --noinform ~{~A ~}--eval \"(with-open-file (i \\\"$0\\\" :element-type "--sysinit /dev/null")) initial-function) "Write an executable called OUTPUT-FILE which can be run from the shell, by 'linking' together code from FASLS. Actually works by concatenating them and prepending a #! header" - (with-open-file (out output-file :direction :output + (with-open-file (out output-file + :direction :output + :if-exists :supersede :element-type '(unsigned-byte 8)) (write-sequence (map 'vector #'char-code (format nil *exec-header* runtime-flags diff --git a/contrib/sb-posix/macros.lisp b/contrib/sb-posix/macros.lisp index b35a31f..0aad987 100644 --- a/contrib/sb-posix/macros.lisp +++ b/contrib/sb-posix/macros.lisp @@ -17,7 +17,8 @@ (write-char #\/ s)) (dolist (piece (cdr directory)) (etypecase piece - (string (write-string piece s) (write-char #\/ s)))))) + (string (write-string piece s) (write-char #\/ s)) + ((member :up) (write-string "../" s)))))) (etypecase name (null) (string (write-string name s))) diff --git a/contrib/sb-posix/posix-tests.lisp b/contrib/sb-posix/posix-tests.lisp index 4761a22..647af23 100644 --- a/contrib/sb-posix/posix-tests.lisp +++ b/contrib/sb-posix/posix-tests.lisp @@ -38,6 +38,18 @@ (sb-posix:chdir *current-directory*) 0) +(deftest chdir.6 + (sb-posix:chdir "/../") + 0) + +(deftest chdir.7 + (sb-posix:chdir #p"/../") + 0) + +(deftest chdir.8 + (sb-posix:chdir (make-pathname :directory '(:absolute :up))) + 0) + (deftest chdir.error.1 (let ((dne (make-pathname :directory '(:relative "chdir.does-not-exist")))) (handler-case @@ -188,6 +200,15 @@ (< (- atime unix-now) 10)) t) +(deftest stat.2 + (let* ((stat (sb-posix:stat (make-pathname :directory '(:absolute :up)))) + (mode (sb-posix::stat-mode stat))) + ;; it's logically possible for / to be writeable by others... but + ;; if it is, either someone is playing with strange security + ;; modules or they want to know about it anyway. + (logand mode sb-posix::s-iwoth)) + 0) + ;;; FIXME: add tests for carrying a stat structure around in the ;;; optional argument to SB-POSIX:STAT diff --git a/contrib/sb-simple-streams/internal.lisp b/contrib/sb-simple-streams/internal.lisp index ea5309a..f8afe67 100644 --- a/contrib/sb-simple-streams/internal.lisp +++ b/contrib/sb-simple-streams/internal.lisp @@ -482,11 +482,11 @@ :new-version :error))) (case if-exists - ((:error nil) + ((:error nil :new-version) (setf mask (logior mask sb-unix:o_excl))) ((:rename :rename-and-delete) (setf mask (logior mask sb-unix:o_creat))) - ((:new-version :supersede) + ((:supersede) (setf mask (logior mask sb-unix:o_trunc))))) (t (setf if-exists nil))) ; :ignore-this-arg diff --git a/src/code/fd-stream.lisp b/src/code/fd-stream.lisp index 2fbafbf..2dee43a 100644 --- a/src/code/fd-stream.lisp +++ b/src/code/fd-stream.lisp @@ -1120,11 +1120,11 @@ :append :supersede nil) :if-exists) (case if-exists - ((:error nil) + ((:new-version :error nil) (setf mask (logior mask sb!unix:o_excl))) ((:rename :rename-and-delete) (setf mask (logior mask sb!unix:o_creat))) - ((:new-version :supersede) + ((:supersede) (setf mask (logior mask sb!unix:o_trunc))) (:append (setf mask (logior mask sb!unix:o_append))))) diff --git a/src/code/filesys.lisp b/src/code/filesys.lisp index f5f8ffc..3f1f5c5 100644 --- a/src/code/filesys.lisp +++ b/src/code/filesys.lisp @@ -158,40 +158,16 @@ (declare (type simple-base-string namestr) (type index start end)) (let* ((last-dot (position #\. namestr :start (1+ start) :end end - :from-end t)) - (second-to-last-dot (and last-dot - (position #\. namestr :start (1+ start) - :end last-dot :from-end t))) - (version :newest)) - ;; If there is a second-to-last dot, check to see whether there is - ;; a valid version after the last dot. - (when second-to-last-dot - (cond ((and (= (+ last-dot 2) end) - (char= (schar namestr (1+ last-dot)) #\*)) - (setf version :wild)) - ((and (< (1+ last-dot) end) - (do ((index (1+ last-dot) (1+ index))) - ((= index end) t) - (unless (char<= #\0 (schar namestr index) #\9) - (return nil)))) - (setf version - (parse-integer namestr :start (1+ last-dot) :end end))) - (t - (setf second-to-last-dot nil)))) - (cond (second-to-last-dot - (values (maybe-make-pattern namestr start second-to-last-dot) - (maybe-make-pattern namestr - (1+ second-to-last-dot) - last-dot) - version)) - (last-dot - (values (maybe-make-pattern namestr start last-dot) - (maybe-make-pattern namestr (1+ last-dot) end) - version)) - (t - (values (maybe-make-pattern namestr start end) - nil - version))))) + :from-end t))) + (cond + (last-dot + (values (maybe-make-pattern namestr start last-dot) + (maybe-make-pattern namestr (1+ last-dot) end) + :newest)) + (t + (values (maybe-make-pattern namestr start end) + nil + :newest))))) (/show0 "filesys.lisp 200") @@ -362,10 +338,15 @@ ;; translating logical pathnames to a filesystem without ;; versions (like Unix). (when name + (when (and (null type) (position #\. name :start 1)) + (error "too many dots in the name: ~S" pathname)) (strings (unparse-unix-piece name))) (when type-supplied (unless name (error "cannot specify the type without a file: ~S" pathname)) + (when (typep type 'simple-base-string) + (when (position #\. type) + (error "type component can't have a #\. inside: ~S" pathname))) (strings ".") (strings (unparse-unix-piece type)))) (apply #'concatenate 'simple-string (strings)))) @@ -403,13 +384,9 @@ ;; We are a relative directory. So we lose. (lose))))) (strings (unparse-unix-directory-list result-directory))) - (let* ((pathname-version (%pathname-version pathname)) - (version-needed (and pathname-version - (not (eq pathname-version :newest)))) - (pathname-type (%pathname-type pathname)) - (type-needed (or version-needed - (and pathname-type - (not (eq pathname-type :unspecific))))) + (let* ((pathname-type (%pathname-type pathname)) + (type-needed (and pathname-type + (not (eq pathname-type :unspecific)))) (pathname-name (%pathname-name pathname)) (name-needed (or type-needed (and pathname-name @@ -418,20 +395,18 @@ defaults))))))) (when name-needed (unless pathname-name (lose)) + (when (and (null pathname-type) + (position #\. pathname-name :start 1)) + (error "too many dots in the name: ~S" pathname)) (strings (unparse-unix-piece pathname-name))) (when type-needed (when (or (null pathname-type) (eq pathname-type :unspecific)) (lose)) + (when (typep pathname-type 'simple-base-string) + (when (position #\. pathname-type) + (error "type component can't have a #\. inside: ~S" pathname))) (strings ".") - (strings (unparse-unix-piece pathname-type))) - (when version-needed - (typecase pathname-version - ((member :wild) - (strings ".*")) - (integer - (strings (format nil ".~D" pathname-version))) - (t - (lose))))) + (strings (unparse-unix-piece pathname-type)))) (apply #'concatenate 'simple-string (strings))))) ;;;; wildcard matching stuff @@ -528,6 +503,13 @@ verify-existence follow-links nodes function)))) ((member :wild-inferiors) + ;; now with extra error case handling from CLHS + ;; 19.2.2.4.3 -- CSR, 2004-01-24 + (when (member (cadr tail) '(:up :back)) + (error 'simple-file-error + :pathname pathname + :format-control "~@." + :format-arguments (list (cadr tail)))) (%enumerate-directories head (rest tail) pathname verify-existence follow-links nodes function) @@ -563,13 +545,24 @@ verify-existence follow-links nodes function)))))))) ((member :up) - (with-directory-node-removed (head) + (when (string= head "/") + (error 'simple-file-error + :pathname pathname + :format-control "~@")) + (with-directory-node-removed (head) (let ((head (concatenate 'base-string head ".."))) (with-directory-node-noted (head) (%enumerate-directories (concatenate 'base-string head "/") (rest tail) pathname verify-existence follow-links - nodes function))))))) + nodes function))))) + ((member :back) + ;; :WILD-INFERIORS is handled above, so the only case here + ;; should be (:ABSOLUTE :BACK) + (aver (string= head "/")) + (error 'simple-file-error + :pathname pathname + :format-control "~@")))) (%enumerate-files head pathname verify-existence function)))) ;;; Call FUNCTION on files. @@ -677,8 +670,6 @@ ;;; Convert PATHNAME into a string that can be used with UNIX system ;;; calls, or return NIL if no match is found. Wild-cards are expanded. -;;; FIXME this should signal file-error if the pathname is wild, whether -;;; or not it turns out to have only one match. Fix post 0.7.2 (defun unix-namestring (pathname-spec &optional (for-input t)) (let* ((namestring (physicalize-pathname (merge-pathnames pathname-spec))) (matches nil)) ; an accumulator for actual matches diff --git a/src/code/target-pathname.lisp b/src/code/target-pathname.lisp index 542432a..fa8b426 100644 --- a/src/code/target-pathname.lisp +++ b/src/code/target-pathname.lisp @@ -97,7 +97,9 @@ (upcase-maybe name) (upcase-maybe type) version) - (%make-pathname host device directory name type version)))) + (progn + (aver (eq host *unix-host*)) + (%make-pathname host device directory name type version))))) ;;; Hash table searching maps a logical pathname's host to its ;;; physical pathname translation. @@ -267,8 +269,9 @@ (%pathname-name pathname2)) (compare-component (%pathname-type pathname1) (%pathname-type pathname2)) - (compare-component (%pathname-version pathname1) - (%pathname-version 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. @@ -383,7 +386,8 @@ (flet ((add (dir) (if (and (eq dir :back) results - (not (eq (car results) :back))) + (not (member (car results) + '(:back :wild-inferiors)))) (pop results) (push dir results)))) (dolist (dir (maybe-diddle-case dir2 diddle-case)) @@ -920,7 +924,8 @@ a host-structure or string." (frob %pathname-directory directory-components-match) (frob %pathname-name) (frob %pathname-type) - (frob %pathname-version)))))) + (or (eq (%pathname-host wildname) *unix-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, @@ -979,7 +984,8 @@ a host-structure or string." 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 @@ -1116,6 +1122,7 @@ a host-structure or string." (with-pathname (from from-wildname) (with-pathname (to to-wildname) (let* ((source-host (%pathname-host source)) + (from-host (%pathname-host from)) (to-host (%pathname-host to)) (diddle-case (and source-host to-host @@ -1135,7 +1142,11 @@ a host-structure or string." (frob %pathname-directory translate-directories) (frob %pathname-name) (frob %pathname-type) - (frob %pathname-version)))))))) + (if (eq from-host *unix-host*) + (if (eq (%pathname-version to) :wild) + (%pathname-version from) + (%pathname-version to)) + (frob %pathname-version))))))))) ;;;; logical pathname support. ANSI 92-102 specification. ;;;; diff --git a/tests/pathnames.impure.lisp b/tests/pathnames.impure.lisp index f939a49..9b93d33 100644 --- a/tests/pathnames.impure.lisp +++ b/tests/pathnames.impure.lisp @@ -63,7 +63,7 @@ ;;; compelling reason for the implementors to choose case ;;; insensitivity and a canonical case.) (setf (logical-pathname-translations "FOO") - '(("**;*.*.*" "/full/path/to/foo/**/*.*.*"))) + '(("**;*.*.*" "/full/path/to/foo/**/*.*"))) (let* ((pn1 (make-pathname :host "FOO" :directory "etc" :name "INETD" :type "conf")) (pn2 (make-pathname :host "foo" :directory "ETC" :name "inetd" diff --git a/version.lisp-expr b/version.lisp-expr index e847bcc..9b5b5f3 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.8.7.21" +"0.8.7.22"