X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fwin32-pathname.lisp;h=ac29f7b7587706a451f598d43c102657693cd989;hb=25fe91bf63fd473d9316675b0e0ca9be0079e9eb;hp=f39891abe7c370b444ebc679cfce0f8a3fcda0a9;hpb=54b330585ed41edeb93a289f0e59aec67fa9ded9;p=sbcl.git

diff --git a/src/code/win32-pathname.lisp b/src/code/win32-pathname.lisp
index f39891a..ac29f7b 100644
--- a/src/code/win32-pathname.lisp
+++ b/src/code/win32-pathname.lisp
@@ -31,14 +31,14 @@
     ;; 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)
@@ -276,15 +276,15 @@
             (typecase piece
               ((member :up) (write-string ".." s))
               (string (write-string piece s))
-              (t (error "ungood piece in NATIVE-NAMESTRING: ~S" piece))))
+              (t (error "ungood piece in NATIVE-NAMESTRING: ~S" piece)))
+            (when (or directory name type)
+              (write-char #\\ s)))
           (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)
@@ -333,7 +333,7 @@
         (when name-needed
           (unless pathname-name (lose))
           (when (and (null pathname-type)
-                     (typep pathname-name 'simple-base-string)
+                     (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)))
@@ -346,3 +346,93 @@
           (strings ".")
           (strings (unparse-unix-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)))))