>From 18bbe16b78a3a079e6f84ed083fd6e70c4e5a308 Mon Sep 17 00:00:00 2001 From: Evan Hanson Date: Sat, 1 Jun 2013 16:18:30 +1200 Subject: [PATCH] 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. --- files.scm | 19 +++++++++++-------- tests/path-tests.scm | 46 ++++++++++++++++++++++++++++++++++++++++++++++ 2 files changed, 57 insertions(+), 8 deletions(-) diff --git a/files.scm b/files.scm index 7398350..8c8f1fa 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 6b9fc45..b9e2a4d 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/x")) +(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)) -- 1.7.10.4