~ chicken-core (chicken-5) 35367c581c590eb9021234babf74428027287478
commit 35367c581c590eb9021234babf74428027287478
Author: Evan Hanson <evhan@foldling.org>
AuthorDate: Sat Jun 1 16:18:30 2013 +1200
Commit: Christian Kellermann <ckeen@pestilenz.org>
CommitDate: Sat Jun 29 19:59:24 2013 +0200
Strip all trailing slashes from directory pathname parts
This causes decompose-pathname (and its derivatives pathname-directory,
pathname-replace-file, etc.) to strip all trailing slashes from the
directory parts of pathnames, rather than just the last one.
Signed-off-by: Peter Bex <peter.bex@xs4all.nl>
Signed-off-by: Christian Kellermann <ckeen@pestilenz.org>
diff --git a/files.scm b/files.scm
index 73983509..8c8f1fa3 100644
--- a/files.scm
+++ b/files.scm
@@ -161,11 +161,13 @@ EOF
(define (chop-pds str)
(and str
- (let ((len (##sys#size str)))
- (if (and (fx>= len 1)
- (*char-pds? (##core#inline "C_subchar" str (fx- len 1)) ) )
- (##sys#substring str 0 (fx- len 1))
- str) ) ) )
+ (let lp ((len (##sys#size str)))
+ (cond ((and (fx>= len 1)
+ (*char-pds? (##core#inline "C_subchar" str (fx- len 1))))
+ (lp (fx- len 1)))
+ ((fx< len (##sys#size str))
+ (##sys#substring str 0 len))
+ (else str)))))
(define make-pathname)
(define make-absolute-pathname)
@@ -231,9 +233,10 @@ EOF
[strip-pds
(lambda (dir)
(and dir
- (if (member dir '("/" "\\"))
- dir
- (chop-pds dir) ) ) )] )
+ (let ((chopped (chop-pds dir)))
+ (if (fx> (##sys#size chopped) 0)
+ chopped
+ (##sys#substring dir 0 1) ) ) ) )] )
(lambda (pn)
(##sys#check-string pn 'decompose-pathname)
(if (fx= 0 (##sys#size pn))
diff --git a/tests/path-tests.scm b/tests/path-tests.scm
index 6b9fc458..b40ea893 100644
--- a/tests/path-tests.scm
+++ b/tests/path-tests.scm
@@ -71,6 +71,47 @@
(test '(#f #f (" " "foo" "bar")) (receive (decompose-directory " //foo//bar")))
(test '(#f #f ("foo" "bar")) (receive (decompose-directory "foo//bar/")))
+(test '(#f #f #f) (receive (decompose-pathname "")))
+(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")))
+(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")))
+(test '("/a" "b" #f) (receive (decompose-pathname "/a/b")))
+(test '("\\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")))
+(test '("." "a" #f) (receive (decompose-pathname "./a")))
+(test '("." "a" #f) (receive (decompose-pathname ".\\a")))
+(test '("." "a" "b") (receive (decompose-pathname "./a.b")))
+(test '("." "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 '(#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")))
+(test '("a" "b" #f) (receive (decompose-pathname "a///b")))
+(test '("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")))
+(test '("a/b/c" #f #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///")))
+(test '("a\\b\\c" #f #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\\")))
+(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"))
@@ -80,4 +121,9 @@
(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))
Trap