X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fwin32-pathname.lisp;h=5c0f9a56c215582799560f2c55214e5dc0c3b5e3;hb=1d881f74d4c2c6099107544a5f337837eb281865;hp=c521dca81774083c77d46fe90a1f527ca48dc86a;hpb=8ebb917259ea3332d46e0301907e7494107eb2f5;p=sbcl.git diff --git a/src/code/win32-pathname.lisp b/src/code/win32-pathname.lisp index c521dca..5c0f9a5 100644 --- a/src/code/win32-pathname.lisp +++ b/src/code/win32-pathname.lisp @@ -20,7 +20,7 @@ (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)) + ((and (member c0 '(#\/ #\\)) (eql c0 c1) (>= end (+ start 3))) ;; "//UNC" style, saved as UNC ;; FIXME: at unparsing time we tell these apart by length, ;; which seems a bit lossy -- presumably one-letter UNC @@ -39,6 +39,11 @@ (defun split-at-slashes-and-backslashes (namestr start end) (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) #\\))))) @@ -83,35 +88,53 @@ :complaint "can't embed #\\Nul or #\\/ in Unix 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))))) + + (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) @@ -159,92 +182,20 @@ ;; 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)) (directory (pathname-directory pathname))) (cond ((or (null device) (eq device :unspecific)) "") - ((= 1 (length device)) + ((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 - (concatenate 'simple-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-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 "\\")) - (t - (error "invalid directory component: ~S" dir))))) - (apply #'concatenate 'simple-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)) @@ -264,7 +215,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)) @@ -272,20 +223,18 @@ (when (position #\. type) (error "type component can't have a #\. inside: ~S" pathname))) (strings ".") - (strings (unparse-unix-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-win32-directory pathname) + (unparse-physical-directory pathname) (unparse-win32-file pathname))) (defun unparse-native-win32-namestring (pathname as-file) - (declare (type pathname pathname) - ;; Windows doesn't like directory names with trailing slashes. - (ignore as-file)) + (declare (type pathname pathname)) (let* ((device (pathname-device pathname)) (directory (pathname-directory pathname)) (name (pathname-name pathname)) @@ -294,28 +243,38 @@ (type (pathname-type pathname)) (type-present-p (typep type '(not (member nil :unspecific)))) (type-string (if type-present-p type ""))) + (when name-present-p + (setf as-file nil)) (coerce (with-output-to-string (s) (when device - (write-string (unparse-win32-device pathname) s)) - (tagbody - (when directory - (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 directory segment in NATIVE-NAMESTRING: ~S" - piece))) - (when (or directory name) + (write-string (unparse-win32-device pathname t) s)) + (when directory + (ecase (pop directory) + (:absolute + (let ((next (pop directory))) + (cond ((eq :home next) + (write-string (user-homedir-namestring) s)) + ((and (consp next) (eq :home (car next))) + (let ((where (user-homedir-namestring (second next)))) + (if where + (write-string where s) + (error "User homedir unknown for: ~S" (second next))))) + (next + (push next directory))) (write-char #\\ s))) - (when directory - (go :subdir)) - :done) + (: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 @@ -359,7 +318,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)))) @@ -375,7 +334,7 @@ (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)) @@ -383,7 +342,7 @@ (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