~ chicken-core (chicken-5) 59200008876d3fc6cda1dfe0276b5ef1a59de65c
commit 59200008876d3fc6cda1dfe0276b5ef1a59de65c
Author: felix <felix@call-with-current-continuation.org>
AuthorDate: Fri Nov 6 10:13:16 2015 +0100
Commit: Mario Domenech Goulart <mario.goulart@gmail.com>
CommitDate: Thu Nov 12 21:16:30 2015 -0200
On UNIX-based systems, only accept "/" as path-separator. Windows still allows "/" and "\" (as does the Windows file-APIs)
Signed-off-by: Mario Domenech Goulart <mario.goulart@gmail.com>
diff --git a/files.scm b/files.scm
index 8f19c39f..32a756d1 100644
--- a/files.scm
+++ b/files.scm
@@ -161,7 +161,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)))) ) )
@@ -170,7 +170,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
@@ -185,7 +188,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)
@@ -197,7 +200,7 @@ EOF
(loop (cdr strs))
(string-append
(chop-pds (car strs))
- "/"
+ pds
(loop (cdr strs))) ) ) ) ) )
(define (canonicalize-dirs dirs)
@@ -235,12 +238,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
@@ -375,6 +382,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)
@@ -401,7 +412,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)
@@ -411,7 +422,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)) ) ) ) ) ) ) )
@@ -423,7 +434,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 6e66fa66..52eefc4b 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,50 +81,117 @@
(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")))
+
+(if ##sys#windows-platform
+ (test '("a." ".b" #f) (receive (decompose-pathname "a.\\.b")))
+ (test '(#f "a.\\" "b") (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"))
+
+(if ##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 'error (handle-exceptions _ 'error (make-pathname '(#f) "foo")))
Trap