>From 667e8bfdf8f550940d20a1b225ca4d3527dcbd9a 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 | 12 +++++++----- tests/path-tests.scm | 41 +++++++++++++++++++++++++++++++++++++++++ 2 files changed, 48 insertions(+), 5 deletions(-) diff --git a/files.scm b/files.scm index 7398350..1ad12d8 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) diff --git a/tests/path-tests.scm b/tests/path-tests.scm index 6b9fc45..d08f87a 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")) -- 1.7.10.4