From: Christophe R. <cr...@us...> - 2014-02-21 17:21:51
|
The branch "master" has been updated in SBCL: via a10227c238ea1454bd1b5428827d9adf14363543 (commit) from f6f5570c55c5dc382a7d64a77a9af2ad2e16ce04 (commit) - Log ----------------------------------------------------------------- commit a10227c238ea1454bd1b5428827d9adf14363543 Author: Christophe Rhodes <cs...@ca...> Date: Tue Feb 18 12:42:23 2014 +0000 define sane escaping in win32 pathname namestrings We can't use \\ to escape, because it's the directory separator; that way lies madness. There's some evidence from random web searching that win32 users might not be too confused with ^ as an escape character, so try that. --- NEWS | 3 ++ src/code/filesys.lisp | 54 ++++++++++++++++++++++++------------------ src/code/pathname.lisp | 8 +++--- src/code/unix-pathname.lisp | 22 ++++++++++------- src/code/win32-pathname.lisp | 22 ++++++++++------- tests/pathnames.impure.lisp | 4 +++ 6 files changed, 68 insertions(+), 45 deletions(-) diff --git a/NEWS b/NEWS index 1cfe542..3b265df 100644 --- a/NEWS +++ b/NEWS @@ -1,5 +1,8 @@ ;;;; -*- coding: utf-8; fill-column: 78 -*- changes relative to sbcl-1.1.15: + * minor incompatible change: improve read/print consistency for pathnames on + Win32, by using the circumflex character #\^ as the escape character. + (lp#673625) * enhancement: SB-EXT:DEFINE-LOAD-TIME-GLOBAL. (lp#1253688) * enhancement: Loading fasls with symbols from an undefined package includes the name of the symbol in the error message. diff --git a/src/code/filesys.lisp b/src/code/filesys.lisp index f013fb1..613ac32 100644 --- a/src/code/filesys.lisp +++ b/src/code/filesys.lisp @@ -49,12 +49,13 @@ ;;; {str1,str2,...,strn} - matches any of str1, str2, ..., or strn. ;;; (FIXME: no it doesn't) ;;; -;;; Any of these special characters can be preceded by a backslash to -;;; cause it to be treated as a regular character. -(defun remove-backslashes (namestr start end) +;;; Any of these special characters can be preceded by an escape +;;; character to cause it to be treated as a regular character. +(defun remove-escape-characters (namestr start end escape-char) #!+sb-doc - "Remove any occurrences of #\\ from the string because we've already - checked for whatever they may have protected." + "Remove any occurrences of escape characters from the string + because we've already checked for whatever they may have + protected." (declare (type simple-string namestr) (type index start end)) (let* ((result (make-string (- end start) :element-type 'character)) @@ -68,21 +69,22 @@ (incf dst)) (t (let ((char (schar namestr src))) - (cond ((char= char #\\) + (cond ((char= char escape-char) (setq quoted t)) (t (setf (schar result dst) char) (incf dst))))))) (when quoted (error 'namestring-parse-error - :complaint "backslash in a bad place" + :complaint "escape char in a bad place" :namestring namestr :offset (1- end))) (%shrink-vector result dst))) -(defun maybe-make-pattern (namestr start end) +(defun maybe-make-pattern (namestr start end escape-char) (declare (type simple-string namestr) - (type index start end)) + (type index start end) + (type character escape-char)) (collect ((pattern)) (let ((quoted nil) (any-quotes nil) @@ -91,9 +93,9 @@ (flet ((flush-pending-regulars () (when last-regular-char (pattern (if any-quotes - (remove-backslashes namestr - last-regular-char - index) + (remove-escape-characters + namestr last-regular-char + index escape-char) (subseq namestr last-regular-char index))) (setf any-quotes nil) (setf last-regular-char nil)))) @@ -104,7 +106,7 @@ (cond (quoted (incf index) (setf quoted nil)) - ((char= char #\\) + ((char= char escape-char) (setf quoted t) (setf any-quotes t) (unless last-regular-char @@ -149,24 +151,30 @@ (t (make-pattern (pattern)))))) -(defun unparse-physical-piece (thing) +(defun unparse-physical-piece (thing escape-char) (etypecase thing ((member :wild) "*") (simple-string (let* ((srclen (length thing)) (dstlen srclen)) (dotimes (i srclen) - (case (schar thing i) - ((#\* #\? #\[) - (incf dstlen)))) + (let ((char (schar thing i))) + (case char + ((#\* #\? #\[) + (incf dstlen)) + (t (when (char= char escape-char) + (incf dstlen)))))) (let ((result (make-string dstlen)) (dst 0)) (dotimes (src srclen) (let ((char (schar thing src))) (case char ((#\* #\? #\[) - (setf (schar result dst) #\\) - (incf dst))) + (setf (schar result dst) escape-char) + (incf dst)) + (t (when (char= char escape-char) + (setf (schar result dst) escape-char) + (incf dst)))) (setf (schar result dst) char) (incf dst))) result))) @@ -204,18 +212,18 @@ (/show0 "filesys.lisp 160") -(defun extract-name-type-and-version (namestr start end) +(defun extract-name-type-and-version (namestr start end escape-char) (declare (type simple-string namestr) (type index start end)) (let* ((last-dot (position #\. namestr :start (1+ start) :end end :from-end t))) (cond (last-dot - (values (maybe-make-pattern namestr start last-dot) - (maybe-make-pattern namestr (1+ last-dot) end) + (values (maybe-make-pattern namestr start last-dot escape-char) + (maybe-make-pattern namestr (1+ last-dot) end escape-char) :newest)) (t - (values (maybe-make-pattern namestr start end) + (values (maybe-make-pattern namestr start end escape-char) nil :newest))))) diff --git a/src/code/pathname.lisp b/src/code/pathname.lisp index 522e832..848749e 100644 --- a/src/code/pathname.lisp +++ b/src/code/pathname.lisp @@ -133,11 +133,11 @@ ;;; \ and / as directory separators on Windows, we print our ;;; own always with /, which is much less confusing what with ;;; being \ needing to be escaped. -(defun unparse-physical-directory (pathname) +(defun unparse-physical-directory (pathname escape-char) (declare (pathname pathname)) - (unparse-physical-directory-list (%pathname-directory pathname))) + (unparse-physical-directory-list (%pathname-directory pathname) escape-char)) -(defun unparse-physical-directory-list (directory) +(defun unparse-physical-directory-list (directory escape-char) (declare (list directory)) (collect ((pieces)) (when directory @@ -166,7 +166,7 @@ ((member :wild-inferiors) (pieces "**/")) ((or simple-string pattern (member :wild)) - (pieces (unparse-physical-piece dir)) + (pieces (unparse-physical-piece dir escape-char)) (pieces "/")) (t (error "invalid directory component: ~S" dir))))) diff --git a/src/code/unix-pathname.lisp b/src/code/unix-pathname.lisp index 324f9d4..cab326b 100644 --- a/src/code/unix-pathname.lisp +++ b/src/code/unix-pathname.lisp @@ -19,7 +19,7 @@ (unparse #'unparse-unix-namestring) (unparse-native #'unparse-native-unix-namestring) (unparse-host #'unparse-unix-host) - (unparse-directory #'unparse-physical-directory) + (unparse-directory #'unparse-unix-directory) (unparse-file #'unparse-unix-file) (unparse-enough #'unparse-unix-enough) (unparse-directory-separator "/") @@ -60,7 +60,7 @@ (tail-end (cdr tail))) (unless (= tail-start tail-end) (setf pieces (butlast pieces)) - (extract-name-type-and-version namestring tail-start tail-end))) + (extract-name-type-and-version namestring tail-start tail-end #\\))) (when (stringp name) (let ((position (position-if (lambda (char) @@ -107,7 +107,8 @@ (t (dirs (maybe-make-pattern namestring piece-start - piece-end))))))) + piece-end + #\\))))))) (cond (absolute (if home (list* :absolute home (dirs)) @@ -167,6 +168,9 @@ ;; 2002-05-09 "") +(defun unparse-unix-directory (pathname) + (unparse-physical-directory pathname #\\)) + (defun unparse-unix-file (pathname) (declare (type pathname pathname)) (collect ((strings)) @@ -185,7 +189,7 @@ (when (and (typep name 'string) (string= name "")) (error "name is of length 0: ~S" pathname)) - (strings (unparse-physical-piece name))) + (strings (unparse-physical-piece name #\\))) (when type-supplied (unless name (error "cannot specify the type without a file: ~S" pathname)) @@ -193,7 +197,7 @@ (when (position #\. type) (error "type component can't have a #\. inside: ~S" pathname))) (strings ".") - (strings (unparse-physical-piece type)))) + (strings (unparse-physical-piece type #\\)))) (apply #'concatenate 'simple-string (strings)))) (/show0 "filesys.lisp 406") @@ -201,7 +205,7 @@ (defun unparse-unix-namestring (pathname) (declare (type pathname pathname)) (concatenate 'simple-string - (unparse-physical-directory pathname) + (unparse-unix-directory pathname) (unparse-unix-file pathname))) (defun unparse-native-unix-namestring (pathname as-file) @@ -288,7 +292,7 @@ pathname-directory) (t (bug "Bad fallthrough in ~S" 'unparse-unix-enough))))) - (strings (unparse-physical-directory-list result-directory))) + (strings (unparse-physical-directory-list result-directory #\\))) (let* ((pathname-type (%pathname-type pathname)) (type-needed (and pathname-type (not (eq pathname-type :unspecific)))) @@ -304,7 +308,7 @@ (typep pathname-name 'simple-string) (position #\. pathname-name :start 1)) (error "too many dots in the name: ~S" pathname)) - (strings (unparse-physical-piece pathname-name))) + (strings (unparse-physical-piece pathname-name #\\))) (when type-needed (when (or (null pathname-type) (eq pathname-type :unspecific)) (lose)) @@ -312,7 +316,7 @@ (when (position #\. pathname-type) (error "type component can't have a #\. inside: ~S" pathname))) (strings ".") - (strings (unparse-physical-piece pathname-type)))) + (strings (unparse-physical-piece pathname-type #\\)))) (apply #'concatenate 'simple-string (strings))))) (defun simplify-unix-namestring (src) diff --git a/src/code/win32-pathname.lisp b/src/code/win32-pathname.lisp index b332261..f8b6dd5 100644 --- a/src/code/win32-pathname.lisp +++ b/src/code/win32-pathname.lisp @@ -19,7 +19,7 @@ (unparse #'unparse-win32-namestring) (unparse-native #'unparse-native-win32-namestring) (unparse-host #'unparse-win32-host) - (unparse-directory #'unparse-physical-directory) + (unparse-directory #'unparse-win32-directory) (unparse-file #'unparse-win32-file) (unparse-enough #'unparse-win32-enough) (unparse-directory-separator "\\") @@ -89,7 +89,7 @@ (tail-end (cdr tail))) (unless (= tail-start tail-end) (setf pieces (butlast pieces)) - (extract-name-type-and-version namestring tail-start tail-end))) + (extract-name-type-and-version namestring tail-start tail-end #\^))) (when (stringp name) (let ((position (position-if (lambda (char) @@ -136,7 +136,8 @@ (t (dirs (maybe-make-pattern namestring piece-start - piece-end))))))) + piece-end + #\^))))))) (cond (absolute (if home (list* :absolute home (dirs)) @@ -222,6 +223,9 @@ (concatenate 'simple-string "\\\\" device) (concatenate 'simple-string "//" device)))))) +(defun unparse-win32-directory (pathname) + (unparse-physical-directory pathname #\^)) + (defun unparse-win32-file (pathname) (declare (type pathname pathname)) (collect ((strings)) @@ -240,7 +244,7 @@ (when (and (typep name 'string) (string= name "")) (error "name is of length 0: ~S" pathname)) - (strings (unparse-physical-piece name))) + (strings (unparse-physical-piece name #\^))) (when type-supplied (unless name (error "cannot specify the type without a file: ~S" pathname)) @@ -248,14 +252,14 @@ (when (position #\. type) (error "type component can't have a #\. inside: ~S" pathname))) (strings ".") - (strings (unparse-physical-piece type)))) + (strings (unparse-physical-piece type #\^)))) (apply #'concatenate 'simple-string (strings)))) (defun unparse-win32-namestring (pathname) (declare (type pathname pathname)) (concatenate 'simple-string (unparse-win32-device pathname) - (unparse-physical-directory pathname) + (unparse-physical-directory pathname #\^) (unparse-win32-file pathname))) (defun unparse-native-win32-namestring (pathname as-file) @@ -378,7 +382,7 @@ pathname-directory) (t (bug "Bad fallthrough in ~S" 'unparse-unix-enough))))) - (strings (unparse-physical-directory-list result-directory))) + (strings (unparse-physical-directory-list result-directory #\^))) (let* ((pathname-type (%pathname-type pathname)) (type-needed (and pathname-type (not (eq pathname-type :unspecific)))) @@ -394,7 +398,7 @@ (typep pathname-name 'simple-string) (position #\. pathname-name :start 1)) (error "too many dots in the name: ~S" pathname)) - (strings (unparse-physical-piece pathname-name))) + (strings (unparse-physical-piece pathname-name #\^))) (when type-needed (when (or (null pathname-type) (eq pathname-type :unspecific)) (lose)) @@ -402,7 +406,7 @@ (when (position #\. pathname-type) (error "type component can't have a #\. inside: ~S" pathname))) (strings ".") - (strings (unparse-physical-piece pathname-type)))) + (strings (unparse-physical-piece pathname-type #\^)))) (apply #'concatenate 'simple-string (strings))))) ;; FIXME: This has been converted rather blindly from the Unix diff --git a/tests/pathnames.impure.lisp b/tests/pathnames.impure.lisp index f37d26e..398267a 100644 --- a/tests/pathnames.impure.lisp +++ b/tests/pathnames.impure.lisp @@ -331,6 +331,10 @@ (make-pathname :name "foo" :type "txt" :version 1) (make-pathname :name "foo" :type ".txt") (make-pathname :name "foo." :type "txt") + (make-pathname :name "\\" :type "txt") + (make-pathname :name "^" :type "txt") + (make-pathname :name "foo*" :type "txt") + (make-pathname :name "foo[" :type "txt") (parse-namestring "SCRATCH:FOO.TXT.1") (parse-namestring "SCRATCH:FOO.TXT.NEWEST") (parse-namestring "SCRATCH:FOO.TXT")))) ----------------------------------------------------------------------- hooks/post-receive -- SBCL |