X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fwin32-pathname.lisp;h=5c0f9a56c215582799560f2c55214e5dc0c3b5e3;hb=71bc8b09fc75083ea4bb2aee954abca1f1e1f214;hp=81ddebd5ca22d7eea249c84683adb5bc91fbeaa7;hpb=fb8e5ded0b56f50de2024efbcc9ce68b401415f5;p=sbcl.git

diff --git a/src/code/win32-pathname.lisp b/src/code/win32-pathname.lisp
index 81ddebd..5c0f9a5 100644
--- a/src/code/win32-pathname.lisp
+++ b/src/code/win32-pathname.lisp
@@ -14,15 +14,36 @@
 (defun extract-device (namestr start end)
   (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
+               ;; FIXME: at unparsing time we tell these apart by length,
+               ;; which seems a bit lossy -- presumably one-letter UNC
+               ;; hosts can exist as well. That seems a less troublesome
+               ;; restriction than disallowing UNC hosts whose names match
+               ;; logical pathname hosts... Time will tell -- both LispWorks
+               ;; and ACL use the host component for UNC hosts, so maybe
+               ;; we will end up there as well.
+               (let ((p (or (position c0 namestr :start (+ start 3) :end end)
+                            end)))
+                 (values (subseq namestr (+ start 2) p) p)))
+              (t
+               (values nil start))))
       (values nil start)))
 
 (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) #\\)))))
@@ -67,37 +88,55 @@
                      :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)))))
 
-(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-string))
@@ -109,23 +148,28 @@
                                for piece = (subseq namestring start end)
                                collect (if (and (string= piece "..") rest)
                                            :up
-                                           piece)))             
+                                           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 +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)))
-    (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-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))
+           "")
+          ((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-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 +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))
@@ -245,52 +223,72 @@
           (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)
+(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 "")))
+    (when name-present-p
+      (setf as-file nil))
     (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 (or directory name type)
+         (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)
-       (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))))
+           (: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))))
      'simple-string)))
 
 ;;; FIXME.
@@ -307,7 +305,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 +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))))
@@ -336,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))
@@ -344,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
@@ -410,7 +408,7 @@
                 (t
                  (setf dots nil)
                  (setf (schar dst dst-len) char)
-                 (incf dst-len)))))      
+                 (incf dst-len)))))
       ;; ...finish off
       (when (and last-slash (not (zerop last-slash)))
         (case dots