From dbf0a0a5487007950c61f80bd2ed7bf94a371dfe Mon Sep 17 00:00:00 2001
From: felix <address@hidden>
Date: Fri, 6 Nov 2015 10:13:16 +0100
Subject: [PATCH] On UNIX-based systems, only accept "/" as path-separator.
 Windows still allows "/" and "\" (as does the Windows file-APIs)

---
 chicken-install.scm       |  17 +++++-
 files.scm                 |  31 +++++++---
 tests/path-tests.scm      | 151 ++++++++++++++++++++++++++++++++++++----------
 tests/test-find-files.scm |  55 +++++++++++------
 4 files changed, 190 insertions(+), 64 deletions(-)

diff --git a/chicken-install.scm b/chicken-install.scm
index 3b3e0ea..bcba62e 100644
--- a/chicken-install.scm
+++ b/chicken-install.scm
@@ -513,6 +513,19 @@
 		 (and (not (any loop (cdr p))) (fail)))
 		(else (error "invalid `platform' property" name (cadr platform))))))))
 
+  (define (qx str)
+    (with-output-to-string
+      (lambda ()
+	(let ((len (string-length str)))
+	  (do ((i 0 (add1 i)))
+	      ((fx>= i len))
+	    (let ((c (string-ref str i)))
+	      (case c
+		((#\\ #\' #\") 
+		 (write-char #\\)
+		 (write-char c))
+		(else (write-char c)))))))))
+
   (define (make-install-command egg-name egg-version dep?)
     (conc
      *csi*
@@ -535,12 +548,12 @@
      (let ((prefix (get-prefix)))
        (if prefix
 	   (sprintf " -e \"(destination-prefix \\\"~a\\\")\"" 
-	     (normalize-pathname prefix 'unix))
+	     (qx (normalize-pathname prefix)))
 	   ""))
      (let ((prefix (get-prefix #t)))
        (if prefix
 	   (sprintf " -e \"(runtime-prefix \\\"~a\\\")\"" 
-	     (normalize-pathname prefix 'unix))
+	     (qx (normalize-pathname prefix)))
 	   ""))
      (if (pair? *csc-features*)
 	 (sprintf " -e \"(extra-features '~s)\"" *csc-features*)
diff --git a/files.scm b/files.scm
index 59de961..1d96416 100644
--- a/files.scm
+++ b/files.scm
@@ -147,7 +147,7 @@ EOF
       (set! absolute-pathname-root (lambda (pn) (irregex-match rx pn)))
       (set! root-origin (lambda (rt) (and rt (irregex-match-substring rt 1))))
       (set! root-directory (lambda (rt) (and rt (irregex-match-substring rt 2)))) )
-    (let ((rx (irregex "([\\/\\\\]).*")))
+    (let ((rx (irregex "(/).*")))
       (set! absolute-pathname-root (lambda (pn) (irregex-match rx pn)))
       (set! root-origin (lambda (rt) #f))
       (set! root-directory (lambda (rt) (and rt (irregex-match-substring rt 1)))) ) )
@@ -156,7 +156,10 @@ EOF
   (##sys#check-string pn 'absolute-pathname?)
   (irregex-match-data? (absolute-pathname-root pn)) )
 
-(define-inline (*char-pds? ch) (memq ch '(#\\ #\/)))
+(define-inline (*char-pds? ch) 
+  (if ##sys#windows-platform 
+      (memq ch '(#\\ #\/))
+      (eq? #\/ ch)))
 
 (define (chop-pds str)
   (and str
@@ -171,7 +174,7 @@ EOF
 (define make-pathname)
 (define make-absolute-pathname)
 
-(let ()
+(let ((pds (if ##sys#windows-platform "\\" "/")))
 
   (define (conc-dirs dirs)
     (##sys#check-list dirs 'make-pathname)
@@ -183,7 +186,7 @@ EOF
 		(loop (cdr strs))
 		(string-append 
 		 (chop-pds (car strs))
-		 "/"
+		 pds
 		 (loop (cdr strs))) ) ) ) ) )
 
   (define (canonicalize-dirs dirs)
@@ -221,12 +224,16 @@ EOF
        (let ((dir (canonicalize-dirs dirs)))
 	 (if (absolute-pathname? dir)
 	     dir
-	     (##sys#string-append "/"dir)) )
+	     (##sys#string-append pds dir)) )
        file ext) ) ) )
 
 (define decompose-pathname
-  (let* ([patt1 "^(.*[\\/\\\\])?([^\\/\\\\]+)(\\.([^\\/\\\\.]+))$"]
-	 [patt2 "^(.*[\\/\\\\])?((\\.)?[^\\/\\\\]+)$"]
+  (let* ((patt1 (if ##sys#windows-platform
+                    "^(.*[\\/\\\\])?([^\\/\\\\]+)(\\.([^\\/\\\\.]+))$"
+                    "^(.*/)?([^/]+)(\\.([^/.]+))$"))
+	 (patt2 (if ##sys#windows-platform
+                    "^(.*[\\/\\\\])?((\\.)?[^\\/\\\\]+)$"
+                    "^(.*/)?((\\.)?[^/]+)$"))
 	 [rx1 (irregex patt1)]
 	 [rx2 (irregex patt2)]
 	 [strip-pds
@@ -361,6 +368,10 @@ EOF
             (else (cons part parts) ) ) )
     (lambda (path #!optional (platform bldplt))
       (let ((sep (if (eq? platform 'windows) #\\ #\/)))
+        (define (pds? c)
+          (if (eq? platform 'windows)
+              (memq c '(#\/ #\\))
+              (eq? c #\/)))
 	(##sys#check-string path 'normalize-pathname)
 	(let ((len (##sys#size path))
 	      (type #f)
@@ -387,7 +398,7 @@ EOF
 			   (when drive
 			     (set! r (##sys#string-append drive r)))
 			   r))))
-		  ((*char-pds? (string-ref path i))
+		  ((pds? (string-ref path i))
 		   (when (not type)
 		     (set! type (if (fx= i prev) 'abs 'rel)))
 		   (if (fx= i prev)
@@ -397,7 +408,7 @@ EOF
 			     (addpart (##sys#substring path prev i) parts))))
 		  ((and (null? parts) 
 			(char=? (string-ref path i) #\:)
-			(eq? 'windows platform))
+			(eq? platform 'windows))
 		   (set! drive (##sys#substring path 0 (fx+ i 1)))
 		   (loop (fx+ i 1) (fx+ i 1) '()))
 		  (else (loop (fx+ i 1) prev parts)) ) ) ) ) ) ) )
@@ -409,7 +420,7 @@ EOF
 (define split-directory
   (lambda (loc dir keep?)
     (##sys#check-string dir loc)
-    (string-split dir "/\\" keep?) ) )
+    (string-split dir (if ##sys#windows-platform "/\\" "/") keep?) ) )
 
 ;; Directory string or list only contains path-separators
 ;; and/or current-directory (".") names.
diff --git a/tests/path-tests.scm b/tests/path-tests.scm
index 6e66fa6..68ac902 100644
--- a/tests/path-tests.scm
+++ b/tests/path-tests.scm
@@ -36,7 +36,7 @@
 (test "a" (normalize-pathname "a"))
 (test "a/" (normalize-pathname "a/" 'unix))
 (test "a/b" (normalize-pathname "a/b" 'unix))
-(test "a/b" (normalize-pathname "a\\b" 'unix))
+(test "a\\b" (normalize-pathname "a\\b" 'unix))
 (test "a\\b" (normalize-pathname "a\\b" 'windows))
 (test "a\\b" (normalize-pathname "a/b" 'windows))
 (test "a/b/" (normalize-pathname "a/b/" 'unix))
@@ -67,7 +67,11 @@
 (assert (not (directory-null? "//foo//")))
 
 (test '(#f "/" (".")) (receive (decompose-directory "/.//")))
-(test '(#f "/" #f) (receive (decompose-directory "///\\///")))
+
+(if ##sys#windows-platform
+    (test '(#f "/" #f) (receive (decompose-directory "///\\///")))
+    (test '(#f "/" ("\\")) (receive (decompose-directory "///\\///"))))
+
 (test '(#f "/" ("foo")) (receive (decompose-directory "//foo//")))
 (test '(#f "/" ("foo" "bar")) (receive (decompose-directory "//foo//bar")))
 (test '(#f #f (".")) (receive (decompose-directory ".//")))
@@ -77,57 +81,140 @@
 
 (test '(#f #f #f) (receive (decompose-pathname "")))
 (test '("/" #f #f) (receive (decompose-pathname "/")))
-(test '("\\" #f #f) (receive (decompose-pathname "\\")))
+
+(if ##sys#windows-platform
+    (test '("\\" #f #f) (receive (decompose-pathname "\\")))
+    (test '(#f "\\" #f) (receive (decompose-pathname "\\"))))
+
 (test '("/" "a" #f) (receive (decompose-pathname "/a")))
-(test '("\\" "a" #f) (receive (decompose-pathname "\\a")))
+
+(if ##sys#windows-platform
+    (test '("\\" "a" #f) (receive (decompose-pathname "\\a")))
+    (test '(#f "\\a" #f) (receive (decompose-pathname "\\a"))))
+
 (test '("/" #f #f) (receive (decompose-pathname "///")))
-(test '("\\" #f #f) (receive (decompose-pathname "\\\\\\")))
+
+(if ##sys#windows-platform
+    (test '("\\" #f #f) (receive (decompose-pathname "\\\\\\")))
+    (test '(#f "\\\\\\" #f) (receive (decompose-pathname "\\\\\\"))))
+
 (test '("/" "a" #f) (receive (decompose-pathname "///a")))
-(test '("\\" "a" #f) (receive (decompose-pathname "\\\\\\a")))
+
+(if ##sys#windows-platform
+    (test '("\\" "a" #f) (receive (decompose-pathname "\\\\\\a")))
+    (test '(#f "\\\\\\a" #f) (receive (decompose-pathname "\\\\\\a"))))
+
 (test '("/a" "b" #f) (receive (decompose-pathname "/a/b")))
-(test '("\\a" "b" #f) (receive (decompose-pathname "\\a\\b")))
+
+(if ##sys#windows-platform
+    (test '("\\a" "b" #f) (receive (decompose-pathname "\\a\\b")))
+    (test '(#f "\\a\\b" #f) (receive (decompose-pathname "\\a\\b"))))
+
 (test '("/a" "b" "c") (receive (decompose-pathname "/a/b.c")))
-(test '("\\a" "b" "c") (receive (decompose-pathname "\\a\\b.c")))
+
+(if ##sys#windows-platform
+    (test '("\\a" "b" "c") (receive (decompose-pathname "\\a\\b.c")))
+    (test '(#f "\\a\\b" "c") (receive (decompose-pathname "\\a\\b.c"))))
+
 (test '("." "a" #f) (receive (decompose-pathname "./a")))
-(test '("." "a" #f) (receive (decompose-pathname ".\\a")))
+
+(if ##sys#windows-platform
+    (test '("." "a" #f) (receive (decompose-pathname ".\\a")))
+    (test '(#f ".\\a" #f) (receive (decompose-pathname ".\\a"))))
+
 (test '("." "a" "b") (receive (decompose-pathname "./a.b")))
-(test '("." "a" "b") (receive (decompose-pathname ".\\a.b")))
+
+(if ##sys#windows-platform
+    (test '("." "a" "b") (receive (decompose-pathname ".\\a.b")))
+    (test '(#f ".\\a" "b") (receive (decompose-pathname ".\\a.b"))))
+
 (test '("./a" "b" #f) (receive (decompose-pathname "./a/b")))
-(test '(".\\a" "b" #f) (receive (decompose-pathname ".\\a\\b")))
+
+(if ##sys#windows-platform
+    (test '(".\\a" "b" #f) (receive (decompose-pathname ".\\a\\b")))
+    (test '(#f ".\\a\\b" #f) (receive (decompose-pathname ".\\a\\b"))))
+
 (test '(#f "a" #f) (receive (decompose-pathname "a")))
 (test '(#f "a." #f) (receive (decompose-pathname "a.")))
 (test '(#f ".a" #f) (receive (decompose-pathname ".a")))
 (test '("a" "b" #f) (receive (decompose-pathname "a/b")))
-(test '("a" "b" #f) (receive (decompose-pathname "a\\b")))
+
+(if ##sys#windows-platform
+    (test '("a" "b" #f) (receive (decompose-pathname "a\\b")))
+    (test '(#f "a\\b" #f) (receive (decompose-pathname "a\\b"))))
+
 (test '("a" "b" #f) (receive (decompose-pathname "a///b")))
-(test '("a" "b" #f) (receive (decompose-pathname "a\\\\\\b")))
+
+(if ##sys#windows-platform
+    (test '("a" "b" #f) (receive (decompose-pathname "a\\\\\\b")))
+    (test '(#f "a\\\\\\b" #f) (receive (decompose-pathname "a\\\\\\b"))))
+
 (test '("a/b" "c" #f) (receive (decompose-pathname "a/b/c")))
-(test '("a\\b" "c" #f) (receive (decompose-pathname "a\\b\\c")))
+
+(if ##sys#windows-platform
+    (test '("a\\b" "c" #f) (receive (decompose-pathname "a\\b\\c")))
+    (test '(#f "a\\b\\c" #f) (receive (decompose-pathname "a\\b\\c"))))
+
 (test '("a/b/c" #f #f) (receive (decompose-pathname "a/b/c/")))
-(test '("a\\b\\c" #f #f) (receive (decompose-pathname "a\\b\\c\\")))
+
+(if ##sys#windows-platform
+    (test '("a\\b\\c" #f #f) (receive (decompose-pathname "a\\b\\c\\")))
+    (test '(#f "a\\b\\c\\" #f) (receive (decompose-pathname "a\\b\\c\\"))))
+
 (test '("a/b/c" #f #f) (receive (decompose-pathname "a/b/c///")))
-(test '("a\\b\\c" #f #f) (receive (decompose-pathname "a\\b\\c\\\\\\")))
+
+(if ##sys#windows-platform
+    (test '("a\\b\\c" #f #f) (receive (decompose-pathname "a\\b\\c\\\\\\")))
+    (test '(#f "a\\b\\c\\\\\\" #f) (receive (decompose-pathname "a\\b\\c\\\\\\"))))
+
 (test '(#f "a" "b") (receive (decompose-pathname "a.b")))
 (test '("a.b" #f #f) (receive (decompose-pathname "a.b/")))
-(test '("a.b" #f #f) (receive (decompose-pathname "a.b\\")))
+
+(if ##sys#windows-platform
+    (test '("a.b" #f #f) (receive (decompose-pathname "a.b\\")))
+    (test '(#f "a" "b\\") (receive (decompose-pathname "a.b\\"))))
+
 (test '(#f "a.b" "c") (receive (decompose-pathname "a.b.c")))
 (test '(#f "a." "b") (receive (decompose-pathname "a..b")))
 (test '(#f "a.." "b") (receive (decompose-pathname "a...b")))
 (test '("a." ".b" #f) (receive (decompose-pathname "a./.b")))
-(test '("a." ".b" #f) (receive (decompose-pathname "a.\\.b")))
-
-(test "x/y/z.q" (make-pathname "x/y" "z" "q"))
-(test "x/y/z.q" (make-pathname "x/y" "z.q"))
-(test "x/y/z.q" (make-pathname "x/y/" "z.q"))
-(test "x/y/z.q" (make-pathname "x/y/" "z.q"))
-(test "x/y/z.q" (make-pathname "x/y\\" "z.q"))
-(test "x//y/z.q" (make-pathname "x//y/" "z.q"))
-(test "x\\y/z.q" (make-pathname "x\\y" "z.q"))
+
+(if ##sys#windows-platform
+    (test '("a." ".b" #f) (receive (decompose-pathname "a.\\.b")))
+    (test '(#f "a.\\" "b") (receive (decompose-pathname "a.\\.b"))))
+
+(cond (##sys#windows-platform
+       (test "x/y\\z.q" (make-pathname "x/y" "z" "q"))
+       (test "x/y\\z.q" (make-pathname "x/y" "z.q"))
+       (test "x/y\\z.q" (make-pathname "x/y/" "z.q"))
+       (test "x/y\\z.q" (make-pathname "x/y/" "z.q"))
+       (test "x/y\\z.q" (make-pathname "x/y\\" "z.q"))
+       (test "x//y\\z.q" (make-pathname "x//y/" "z.q"))
+       (test "x\\y\\z.q" (make-pathname "x\\y" "z.q")))
+      (else
+       (test "x/y/z.q" (make-pathname "x/y" "z" "q"))
+       (test "x/y/z.q" (make-pathname "x/y" "z.q"))
+       (test "x/y/z.q" (make-pathname "x/y/" "z.q"))
+       (test "x/y/z.q" (make-pathname "x/y/" "z.q"))
+       (test "x/y\\/z.q" (make-pathname "x/y\\" "z.q"))
+       (test "x//y/z.q" (make-pathname "x//y/" "z.q"))
+       (test "x\\y/z.q" (make-pathname "x\\y" "z.q"))))
+
 (test 'error (handle-exceptions _ 'error (make-pathname '(#f) "foo")))
+
 (test "/x/y/z" (make-pathname #f "/x/y/z"))
-(test "/x/y/z" (make-pathname "/" "x/y/z"))
-(test "/x/y/z" (make-pathname "/x" "/y/z"))
-(test "/x/y/z" (make-pathname '("/") "x/y/z"))
-(test "/x/y/z" (make-pathname '("/" "x") "y/z"))
-(test "/x/y/z" (make-pathname '("/x" "y") "z"))
-(test "/x/y/z/" (make-pathname '("/x" "y" "z") #f))
+
+(cond (##sys#windows-platform
+       (test "\\x/y/z" (make-pathname "/" "x/y/z"))
+       (test "/x\\y/z" (make-pathname "/x" "/y/z"))
+       (test "\\x/y/z" (make-pathname '("/") "x/y/z"))
+       (test "\\x\\y/z" (make-pathname '("/" "x") "y/z"))
+       (test "/x\\y\\z" (make-pathname '("/x" "y") "z"))
+       (test "/x\\y\\z\\" (make-pathname '("/x" "y" "z") #f)))
+      (else
+       (test "/x/y/z" (make-pathname "/" "x/y/z"))
+       (test "/x/y/z" (make-pathname "/x" "/y/z"))
+       (test "/x/y/z" (make-pathname '("/") "x/y/z"))
+       (test "/x/y/z" (make-pathname '("/" "x") "y/z"))
+       (test "/x/y/z" (make-pathname '("/x" "y") "z"))
+       (test "/x/y/z/" (make-pathname '("/x" "y" "z") #f))))
diff --git a/tests/test-find-files.scm b/tests/test-find-files.scm
index c3ef3e4..62fe5a0 100644
--- a/tests/test-find-files.scm
+++ b/tests/test-find-files.scm
@@ -24,14 +24,19 @@
 (change-directory "find-files-test-dir")
 
 (cond-expand
-  ((and windows (not cygwin)))		; Cannot handle symlinks
-  (else (create-symbolic-link "dir-link-target" "dir-link-name")))
+  ((and windows (not cygwin))		; Cannot handle symlinks
+   (define (path lst)
+     (map (cut string-translate <> "/" "\\") lst)) )
+  (else
+   (create-symbolic-link "dir-link-target" "dir-link-name")
+   (define (path lst) lst)))
 
 (test-begin "find-files")
 
 (test-equal "no keyword args"
             (find-files ".")
-            `("./foo/bar/baz"
+            (path 
+	     `("./foo/bar/baz"
               "./foo/bar"
               "./foo"
               "./dir-link-target/foo"
@@ -41,11 +46,12 @@
 	      ,@(cond-expand
 		  ((and windows (not cygwin)) '())
 		  (else '("./dir-link-name")))
-              "./file2")
+              "./file2"))
             file-list=?)
 
 (test-equal "dotfiles: #t"
             (find-files "." dotfiles: #t)
+	    (path
             `("./foo/bar/baz/.quux"
               "./foo/bar/baz"
               "./foo/bar"
@@ -58,12 +64,13 @@
 	      ,@(cond-expand
 		  ((and windows (not cygwin)) '())
 		  (else '("./dir-link-name")))
-              "./file2")
+              "./file2"))
             file-list=?)
 
 (test-equal "follow-symlinks: #t"
             (find-files "." follow-symlinks: #t)
-            `("./foo/bar/baz"
+            (path
+	     `("./foo/bar/baz"
               "./foo/bar"
               "./foo"
               "./dir-link-target/foo"
@@ -75,12 +82,13 @@
 		  (else '("./dir-link-name/foo"
 			  "./dir-link-name/bar"
 			  "./dir-link-name")))
-              "./file2")
+              "./file2"))
             file-list=?)
 
 (test-equal "limit: 1"
             (find-files "." limit: 1)
-            `("./foo/bar"
+            (path
+	     `("./foo/bar"
               "./foo"
               "./dir-link-target/foo"
               "./dir-link-target/bar"
@@ -89,11 +97,12 @@
 	      ,@(cond-expand
 		  ((and windows (not cygwin)) '())
 		  (else '("./dir-link-name")))
-              "./file2")
+              "./file2"))
             file-list=?)
 
 (test-equal "limit: 1 follow-symlinks: #t"
             (find-files "." limit: 1 follow-symlinks: #t)
+	    (path
             `("./foo/bar"
               "./foo"
               "./dir-link-target/foo"
@@ -105,11 +114,12 @@
 		  (else '("./dir-link-name/foo"
 			  "./dir-link-name/bar"
 			  "./dir-link-name")))
-              "./file2")
+              "./file2"))
             file-list=?)
 
 (test-equal "limit: 2"
             (find-files "." limit: 2)
+	    (path
             `("./foo/bar/baz"
               "./foo/bar"
               "./foo"
@@ -120,11 +130,12 @@
 	      ,@(cond-expand
 		  ((and windows (not cygwin)) '())
 		  (else '("./dir-link-name")))
-              "./file2")
+              "./file2"))
             file-list=?)
 
 (test-equal "limit: 2 follow-symlinks: #t"
             (find-files "." limit: 2 follow-symlinks: #t)
+	    (path
             `("./foo/bar/baz"
               "./foo/bar"
               "./foo"
@@ -137,36 +148,39 @@
 		  (else '("./dir-link-name/foo"
 			  "./dir-link-name/bar"
 			  "./dir-link-name")))
-              "./file2")
+              "./file2"))
             file-list=?)
 
 (test-equal "test: (lambda (f) (directory? f))"
             (find-files "." test: (lambda (f) (directory? f)))
-            `("./foo/bar/baz"
+            (path
+	     `("./foo/bar/baz"
               "./foo/bar"
               "./foo"
               "./dir-link-target"
 	      ,@(cond-expand
 		  ((and windows (not cygwin)) '())
-		  (else '("./dir-link-name"))))
+		  (else '("./dir-link-name")))))
             file-list=?)
 
 (test-equal "test: (lambda (f) (directory? f)) action: (lambda (f p) (cons (string-append \"--\" f) p))"
             (find-files "."
                         test: (lambda (f) (directory? f))
                         action: (lambda (f p) (cons (string-append "--" f) p)))
-            `("--./foo/bar/baz"
+            (path
+	     `("--./foo/bar/baz"
               "--./foo/bar"
               "--./foo"
               "--./dir-link-target"
 	      ,@(cond-expand
 		  ((and windows (not cygwin)) '())
-		  (else '("--./dir-link-name"))))
+		  (else '("--./dir-link-name")))))
             file-list=?)
 
 (test-equal "dotfiles: #t test: (lambda (f) (directory? f)) follow-symlinks: #t"
             (find-files "." dotfiles: #t test: (lambda (f) (directory? f)) follow-symlinks: #t)
-            `("./foo/bar/baz/.quux"
+            (path
+	     `("./foo/bar/baz/.quux"
               "./foo/bar/baz"
               "./foo/bar"
               "./foo/.x"
@@ -174,7 +188,7 @@
               "./dir-link-target"
 	      ,@(cond-expand
 		  ((and windows (not cygwin)) '())
-		  (else '("./dir-link-name"))))
+		  (else '("./dir-link-name")))))
             file-list=?)
 
 (test-equal "dotfiles: #t test: (lambda (f) (directory? f)) follow-symlinks: #t limit: 1"
@@ -183,13 +197,14 @@
                         test: (lambda (f) (directory? f))
                         follow-symlinks: #t
                         limit: 1)
-            `("./foo/bar"
+            (path
+	     `("./foo/bar"
               "./foo/.x"
               "./foo"
               "./dir-link-target"
 	      ,@(cond-expand
 		  ((and windows (not cygwin)) '())
-		  (else '("./dir-link-name"))))
+		  (else '("./dir-link-name")))))
             file-list=?)
 
 (test-end "find-files")
-- 
1.9.4.msysgit.2