X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fwin32-pathname.lisp;h=72bb09d2ad27e32d43257d77d1c4efa4cf5f1ba7;hb=0e3c4b4db102bd204a30402d7e5a0de44aea57ce;hp=4a3d10bb4cf52e07f6154bda84730323881c1120;hpb=3eb0a28fe6a7912d6ff2b97221325c0e3bfc5703;p=sbcl.git diff --git a/src/code/win32-pathname.lisp b/src/code/win32-pathname.lisp index 4a3d10b..72bb09d 100644 --- a/src/code/win32-pathname.lisp +++ b/src/code/win32-pathname.lisp @@ -11,18 +11,52 @@ (in-package "SB!IMPL") +(def!struct (win32-host + (:make-load-form-fun make-host-load-form) + (:include host + (parse #'parse-win32-namestring) + (parse-native #'parse-native-win32-namestring) + (unparse #'unparse-win32-namestring) + (unparse-native #'unparse-native-win32-namestring) + (unparse-host #'unparse-win32-host) + (unparse-directory #'unparse-physical-directory) + (unparse-file #'unparse-win32-file) + (unparse-enough #'unparse-win32-enough) + (unparse-directory-separator "\\") + (simplify-namestring #'simplify-win32-namestring) + (customary-case :lower)))) + +(defvar *physical-host* (make-win32-host)) + +;;; +(define-symbol-macro +long-file-name-prefix+ (quote "\\\\?\\")) +(define-symbol-macro +unc-file-name-prefix+ (quote "\\\\?\\UNC")) + (defun extract-device (namestr start end) - (declare (type simple-base-string namestr) + (declare (type simple-string namestr) (type index start end)) - (if (and (>= end (+ start 2)) - (alpha-char-p (char namestr start)) - (eql (char namestr (1+ start)) #\:)) - (values (string (char namestr start)) (+ start 2)) + (if (>= end (+ start 2)) + (let ((c0 (char namestr start)) + (c1 (char namestr (1+ start)))) + (cond ((and (eql c1 #\:) (alpha-char-p c0)) + ;; "X:" style, saved as X + (values (string (char namestr start)) (+ start 2))) + ((and (member c0 '(#\/ #\\)) (eql c0 c1) (>= end (+ start 3))) + ;; "//UNC" style, saved as :UNC device, with host and share + ;; becoming directory components. + (values :unc (+ start 1))) + (t + (values nil start)))) (values nil start))) (defun split-at-slashes-and-backslashes (namestr start end) - (declare (type simple-base-string namestr) + (declare (type simple-string namestr) (type index start end)) + ;; FIXME: There is a fundamental brokenness in using the same + ;; character as escape character and directory separator in + ;; non-native pathnames. (PATHNAME-DIRECTORY #P"\\*/") should + ;; probably be (:RELATIVE "*") everywhere, but on Windows it's + ;; (:ABSOLUTE :WILD)! See lp#673625. (let ((absolute (and (/= start end) (or (char= (schar namestr start) #\/) (char= (schar namestr start) #\\))))) @@ -31,20 +65,20 @@ ;; Next, split the remainder into slash-separated chunks. (collect ((pieces)) (loop - (let ((slash (position-if (lambda (c) - (or (char= c #\/) - (char= c #\\))) - namestr :start start :end end))) - (pieces (cons start (or slash end))) - (unless slash - (return)) - (setf start (1+ slash)))) + (let ((slash (position-if (lambda (c) + (or (char= c #\/) + (char= c #\\))) + namestr :start start :end end))) + (pieces (cons start (or slash end))) + (unless slash + (return)) + (setf start (1+ slash)))) (values absolute (pieces))))) (defun parse-win32-namestring (namestring start end) (declare (type simple-string namestring) (type index start end)) - (setf namestring (coerce namestring 'simple-base-string)) + (setf namestring (coerce namestring 'simple-string)) (multiple-value-bind (device new-start) (extract-device namestring start end) (multiple-value-bind (absolute pieces) @@ -64,45 +98,73 @@ name))) (when position (error 'namestring-parse-error - :complaint "can't embed #\\Nul or #\\/ in Unix namestring" + :complaint "can't embed #\\Nul or #\\/ in Windows namestring" :namestring namestring :offset position)))) - ;; Now we have everything we want. So return it. - (values nil ; no host for Win32 namestrings - device - (collect ((dirs)) - (dolist (piece pieces) - (let ((piece-start (car piece)) - (piece-end (cdr piece))) - (unless (= piece-start piece-end) - (cond ((string= namestring ".." - :start1 piece-start - :end1 piece-end) - (dirs :up)) - ((string= namestring "**" - :start1 piece-start - :end1 piece-end) - (dirs :wild-inferiors)) - (t - (dirs (maybe-make-pattern namestring - piece-start - piece-end))))))) - (cond (absolute - (cons :absolute (dirs))) - ((dirs) - (cons :relative (dirs))) - (t - nil))) - name - type - version))))) -(defun parse-native-win32-namestring (namestring start end) + (let (home) + ;; Deal with ~ and ~user. + (when (car pieces) + (destructuring-bind (start . end) (car pieces) + (when (and (not absolute) + (not (eql start end)) + (string= namestring "~" + :start1 start + :end1 (1+ start))) + (setf absolute t) + (if (> end (1+ start)) + (setf home (list :home (subseq namestring (1+ start) end))) + (setf home :home)) + (pop pieces)))) + + ;; Now we have everything we want. So return it. + (values nil ; no host for Win32 namestrings + device + (collect ((dirs)) + (dolist (piece pieces) + (let ((piece-start (car piece)) + (piece-end (cdr piece))) + (unless (= piece-start piece-end) + (cond ((string= namestring ".." + :start1 piece-start + :end1 piece-end) + (dirs :up)) + ((string= namestring "**" + :start1 piece-start + :end1 piece-end) + (dirs :wild-inferiors)) + (t + (dirs (maybe-make-pattern namestring + piece-start + piece-end))))))) + (cond (absolute + (if home + (list* :absolute home (dirs)) + (cons :absolute (dirs)))) + ((dirs) + (cons :relative (dirs))) + (t + nil))) + name + type + version)))))) + +(defun parse-native-win32-namestring (namestring start end as-directory) (declare (type simple-string namestring) (type index start end)) - (setf namestring (coerce namestring 'simple-base-string)) + (setf namestring (coerce namestring 'simple-string)) (multiple-value-bind (device new-start) - (extract-device namestring start end) + (cond ((= (length +unc-file-name-prefix+) + (mismatch +unc-file-name-prefix+ namestring + :start2 start)) + (values :unc (+ start (length +unc-file-name-prefix+)))) + ((= (length +long-file-name-prefix+) + (mismatch +long-file-name-prefix+ namestring + :start2 start)) + (extract-device namestring + (+ start (length +long-file-name-prefix+)) + end)) + (t (extract-device namestring start end))) (multiple-value-bind (absolute ranges) (split-at-slashes-and-backslashes namestring new-start end) (let* ((components (loop for ((start . end) . rest) on ranges @@ -110,22 +172,27 @@ collect (if (and (string= piece "..") rest) :up piece))) + (directory (if (and as-directory + (string/= "" (car (last components)))) + components + (butlast components))) (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)))))) + (unless as-directory + (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 device - (cons (if absolute :absolute :relative) (butlast components)) + (cons (if absolute :absolute :relative) directory) (first name-and-type) (second name-and-type) nil))))) @@ -138,86 +205,22 @@ ;; FIXME: same as UNPARSE-UNIX-HOST. That's probably not good. "") -(defun unparse-win32-device (pathname) +(defun unparse-win32-device (pathname &optional native) (declare (type pathname pathname)) - (let ((device (pathname-device pathname))) - (if (or (null device) (eq device :unspecific)) - "" - (concatenate 'simple-string (string device) ":")))) - -(defun unparse-win32-piece (thing) - (etypecase thing - ((member :wild) "*") - (simple-string - (let* ((srclen (length thing)) - (dstlen srclen)) - (dotimes (i srclen) - (case (schar thing i) - ((#\* #\? #\[) - (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) char) - (incf dst))) - result))) - (pattern - (collect ((strings)) - (dolist (piece (pattern-pieces thing)) - (etypecase piece - (simple-string - (strings piece)) - (symbol - (ecase piece - (:multi-char-wild - (strings "*")) - (:single-char-wild - (strings "?")))) - (cons - (case (car piece) - (:character-set - (strings "[") - (strings (cdr piece)) - (strings "]")) - (t - (error "invalid pattern piece: ~S" piece)))))) - (apply #'concatenate - 'simple-base-string - (strings)))))) - -(defun unparse-win32-directory-list (directory) - (declare (type list directory)) - (collect ((pieces)) - (when directory - (ecase (pop directory) - (:absolute - (pieces "\\")) - (:relative - ;; nothing special - )) - (dolist (dir directory) - (typecase dir - ((member :up) - (pieces "..\\")) - ((member :back) - (error ":BACK cannot be represented in namestrings.")) - ((member :wild-inferiors) - (pieces "**\\")) - ((or simple-string pattern (member :wild)) - (pieces (unparse-unix-piece dir)) - (pieces "\\")) + (let ((device (pathname-device pathname)) + (directory (pathname-directory pathname))) + (cond ((or (null device) (eq device :unspecific)) + "") + ((eq device :unc) + (if native "\\" "/")) + ((and (= 1 (length device)) (alpha-char-p (char device 0))) + (concatenate 'simple-string device ":")) + ((and (consp directory) (eq :relative (car directory))) + (error "No printed representation for a relative UNC pathname.")) (t - (error "invalid directory component: ~S" dir))))) - (apply #'concatenate 'simple-base-string (pieces)))) - -(defun unparse-win32-directory (pathname) - (declare (type pathname pathname)) - (unparse-win32-directory-list (%pathname-directory pathname))) + (if native + (concatenate 'simple-string "\\\\" device) + (concatenate 'simple-string "//" device)))))) (defun unparse-win32-file (pathname) (declare (type pathname pathname)) @@ -237,7 +240,7 @@ (when (and (typep name 'string) (string= name "")) (error "name is of length 0: ~S" pathname)) - (strings (unparse-unix-piece name))) + (strings (unparse-physical-piece name))) (when type-supplied (unless name (error "cannot specify the type without a file: ~S" pathname)) @@ -245,53 +248,108 @@ (when (position #\. type) (error "type component can't have a #\. inside: ~S" pathname))) (strings ".") - (strings (unparse-unix-piece type)))) - (apply #'concatenate 'simple-base-string (strings)))) + (strings (unparse-physical-piece type)))) + (apply #'concatenate 'simple-string (strings)))) (defun unparse-win32-namestring (pathname) (declare (type pathname pathname)) - (concatenate 'simple-base-string + (concatenate 'simple-string (unparse-win32-device pathname) - (unparse-win32-directory pathname) + (unparse-physical-directory pathname) (unparse-win32-file pathname))) -(defun unparse-native-win32-namestring (pathname) +(defun unparse-native-win32-namestring (pathname as-file) (declare (type pathname pathname)) - (let ((device (pathname-device pathname)) - (directory (pathname-directory pathname)) - (name (pathname-name pathname)) - (type (pathname-type pathname))) + (let* ((device (pathname-device pathname)) + (directory (pathname-directory pathname)) + (name (pathname-name pathname)) + (name-present-p (typep name '(not (member nil :unspecific)))) + (name-string (if name-present-p name "")) + (type (pathname-type pathname)) + (type-present-p (typep type '(not (member nil :unspecific)))) + (type-string (if type-present-p type "")) + (absolutep (and device (eql :absolute (car directory))))) + (when name-present-p + (setf as-file nil)) + (when (and absolutep (member :up directory)) + ;; employ merge-pathnames to parse :BACKs into which we turn :UPs + (setf directory + (pathname-directory + (merge-pathnames + (make-pathname :defaults pathname :directory '(:relative)) + (make-pathname :defaults pathname + :directory (substitute :back :up directory)))))) (coerce (with-output-to-string (s) - (when device - (write-string device s) - (write-char #\: s)) - (tagbody - (ecase (pop directory) - (:absolute (write-char #\\ s)) - (:relative)) - (unless directory (go :done)) - :subdir - (let ((piece (pop directory))) - (typecase piece - ((member :up) (write-string ".." s)) - (string (write-string piece s)) - (t (error "ungood piece in NATIVE-NAMESTRING: ~S" piece)))) - (when directory - (write-char #\\ s) - (go :subdir)) - :done) - (when name - (unless (stringp name) - (error "non-STRING name in NATIVE-NAMESTRING: ~S" name)) - (write-char #\\ s) - (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))) + (when absolutep + (write-string (case device + (:unc +unc-file-name-prefix+) + (otherwise +long-file-name-prefix+)) s)) + (when (or (not absolutep) (not (member device '(:unc nil)))) + (write-string (unparse-win32-device pathname t) s)) + (when directory + (ecase (pop directory) + (:absolute + (let ((next (pop directory))) + ;; Don't use USER-HOMEDIR-NAMESTRING, since + ;; it can be specified as C:/User/user + ;; and (native-namestring (user-homedir-pathname)) + ;; will be not equal to it, because it's parsed first. + (cond ((eq :home next) + (write-string (native-namestring (user-homedir-pathname)) + s)) + ((and (consp next) (eq :home (car next))) + (let ((where (user-homedir-pathname (second next)))) + (if where + (write-string (native-namestring where) s) + (error "User homedir unknown for: ~S" + (second next))))) + ;; namestring of user-homedir-pathname already has + ;; // at the end + (next + (write-char #\\ s) + (push next directory)) + (t + (write-char #\\ s))))) + (:relative))) + (loop for (piece . subdirs) on directory + do (typecase piece + ((member :up) (write-string ".." s)) + (string (write-string piece s)) + (t (error "ungood directory segment in NATIVE-NAMESTRING: ~S" + piece))) + if (or subdirs (stringp name)) + do (write-char #\\ s) + else + do (unless as-file + (write-char #\\ s))) + (if name-present-p + (progn + (unless (stringp name-string) ;some kind of wild field + (error "ungood name component in NATIVE-NAMESTRING: ~S" name)) + (write-string name-string s) + (when type-present-p + (unless (stringp type-string) ;some kind of wild field + (error "ungood type component in NATIVE-NAMESTRING: ~S" type)) + (write-char #\. s) + (write-string type-string s))) + (when type-present-p + (error + "type component without a name component in NATIVE-NAMESTRING: ~S" + type))) + (when absolutep + (let ((string (get-output-stream-string s))) + (return-from unparse-native-win32-namestring + (cond ((< (- 260 12) (length string)) + ;; KLUDGE: account for additional length of 8.3 name to make + ;; directories always accessible + (coerce string 'simple-string)) + ((eq :unc device) + (replace + (subseq string (1- (length +unc-file-name-prefix+))) + "\\")) + (t (subseq string (length +long-file-name-prefix+)))))))) + 'simple-string))) ;;; FIXME. (defun unparse-win32-enough (pathname defaults) @@ -307,7 +365,7 @@ (cond ((null pathname-directory) '(:relative)) ((eq (car pathname-directory) :relative) pathname-directory) - ((and (> prefix-len 1) + ((and (> prefix-len 0) (>= (length pathname-directory) prefix-len) (compare-component (subseq pathname-directory 0 prefix-len) @@ -320,7 +378,7 @@ pathname-directory) (t (bug "Bad fallthrough in ~S" 'unparse-unix-enough))))) - (strings (unparse-unix-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)))) @@ -333,15 +391,106 @@ (when name-needed (unless pathname-name (lose)) (when (and (null pathname-type) + (typep pathname-name 'simple-string) (position #\. pathname-name :start 1)) (error "too many dots in the name: ~S" pathname)) - (strings (unparse-unix-piece pathname-name))) + (strings (unparse-physical-piece pathname-name))) (when type-needed (when (or (null pathname-type) (eq pathname-type :unspecific)) (lose)) - (when (typep pathname-type 'simple-base-string) + (when (typep pathname-type 'simple-string) (when (position #\. pathname-type) (error "type component can't have a #\. inside: ~S" pathname))) (strings ".") - (strings (unparse-unix-piece pathname-type)))) + (strings (unparse-physical-piece pathname-type)))) (apply #'concatenate 'simple-string (strings))))) + +;; FIXME: This has been converted rather blindly from the Unix +;; version, with no reference to any Windows docs what so ever. +(defun simplify-win32-namestring (src) + (declare (type simple-string src)) + (let* ((src-len (length src)) + (dst (make-string src-len :element-type 'character)) + (dst-len 0) + (dots 0) + (last-slash nil)) + (flet ((deposit (char) + (setf (schar dst dst-len) char) + (incf dst-len)) + (slashp (char) + (find char "\\/"))) + (dotimes (src-index src-len) + (let ((char (schar src src-index))) + (cond ((char= char #\.) + (when dots + (incf dots)) + (deposit char)) + ((slashp char) + (case dots + (0 + ;; either ``/...' or ``...//...' + (unless last-slash + (setf last-slash dst-len) + (deposit char))) + (1 + ;; either ``./...'' or ``..././...'' + (decf dst-len)) + (2 + ;; We've found .. + (cond + ((and last-slash (not (zerop last-slash))) + ;; There is something before this .. + (let ((prev-prev-slash + (position-if #'slashp dst :end last-slash :from-end t))) + (cond ((and (= (+ (or prev-prev-slash 0) 2) + last-slash) + (char= (schar dst (- last-slash 2)) #\.) + (char= (schar dst (1- last-slash)) #\.)) + ;; The something before this .. is another .. + (deposit char) + (setf last-slash dst-len)) + (t + ;; The something is some directory or other. + (setf dst-len + (if prev-prev-slash + (1+ prev-prev-slash) + 0)) + (setf last-slash prev-prev-slash))))) + (t + ;; There is nothing before this .., so we need to keep it + (setf last-slash dst-len) + (deposit char)))) + (t + ;; something other than a dot between slashes + (setf last-slash dst-len) + (deposit char))) + (setf dots 0)) + (t + (setf dots nil) + (setf (schar dst dst-len) char) + (incf dst-len))))) + ;; ...finish off + (when (and last-slash (not (zerop last-slash))) + (case dots + (1 + ;; We've got ``foobar/.'' + (decf dst-len)) + (2 + ;; We've got ``foobar/..'' + (unless (and (>= last-slash 2) + (char= (schar dst (1- last-slash)) #\.) + (char= (schar dst (- last-slash 2)) #\.) + (or (= last-slash 2) + (slashp (schar dst (- last-slash 3))))) + (let ((prev-prev-slash + (position-if #'slashp dst :end last-slash :from-end t))) + (if prev-prev-slash + (setf dst-len (1+ prev-prev-slash)) + (return-from simplify-win32-namestring + (coerce ".\\" 'simple-string))))))))) + (cond ((zerop dst-len) + ".\\") + ((= dst-len src-len) + dst) + (t + (subseq dst 0 dst-len)))))