diff --git a/lib/chibi/pathname.scm b/lib/chibi/pathname.scm index 31c3fc73..5fae8f11 100644 --- a/lib/chibi/pathname.scm +++ b/lib/chibi/pathname.scm @@ -1,94 +1,73 @@ -;; Copyright (c) 2009-2011 Alex Shinn. All rights reserved. +;; Copyright (c) 2009-2013 Alex Shinn. All rights reserved. ;; BSD-style license: http://synthcode.com/license.txt -;;> A general, non-host-specific pathname library. - -(define (string-scan c str . o) - (let ((limit (string-length str))) - (let lp ((i (if (pair? o) (car o) 0))) - (cond ((>= i limit) #f) - ((eqv? c (string-ref str i)) i) - (else (lp (+ i 1))))))) - -(define (string-scan-right c str . o) - (let lp ((i (if (pair? o) (car o) (- (string-length str) 1)))) - (cond ((negative? i) #f) - ((eqv? c (string-ref str i)) i) - (else (lp (- i 1)))))) - -(define (string-skip c str . o) - (let ((limit (string-length str))) - (let lp ((i (if (pair? o) (car o) 0))) - (cond ((>= i limit) #f) - ((not (eqv? c (string-ref str i))) i) - (else (lp (+ i 1))))))) - -(define (string-skip-right c str . o) - (let lp ((i (if (pair? o) (car o) (- (string-length str) 1)))) - (cond ((negative? i) #f) - ((not (eqv? c (string-ref str i))) i) - (else (lp (- i 1)))))) +;;> A general, non-filesystem-specific pathname library. ;; POSIX basename ;; (define (path-strip-directory path) ;; (if (string=? path "") ;; path -;; (let ((end (string-skip-right #\/ path))) -;; (if (not end) +;; (let ((end (string-skip-right path #\/))) +;; (if (zero? end) ;; "/" -;; (let ((start (string-scan-right #\/ path (- end 1)))) -;; (substring path (if start (+ start 1) 0) (+ end 1))))))) +;; (let ((start (string-find-right path #\/ 0 end))) +;; (substring-cursor path start end)))))) ;;> Returns just the basename of \var{path}, with any directory ;;> removed. If \var{path} does not contain a directory separator, ;;> return the whole \var{path}. If \var{path} ends in a directory -;;> separator (i.e. path is a directory) return the empty string. +;;> separator (i.e. path is a directory), or is empty, return the +;;> empty string. ;; GNU basename (define (path-strip-directory path) - (if (string=? path "") - path - (let ((len (string-length path))) - (if (eqv? #\/ (string-ref path (- len 1))) - "" - (let ((slash (string-scan-right #\/ path))) - (if (not slash) - path - (substring path (+ slash 1) len))))))) + (substring-cursor path (string-find-right path #\/))) ;;> Returns just the directory of \var{path}. -;;> If \var{path} is relative, return \scheme{"."}. +;;> If \var{path} is relative (or empty), return \scheme{"."}. (define (path-directory path) (if (string=? path "") "." - (let ((end (string-skip-right #\/ path))) - (if (not end) + (let ((end (string-skip-right path #\/))) + (if (zero? end) "/" - (let ((start (string-scan-right #\/ path (- end 1)))) - (if (not start) + (let ((start (string-find-right path #\/ 0 end))) + (if (zero? start) "." - (let ((start (string-skip-right #\/ path start))) - (if (not start) "/" (substring path 0 (+ start 1)))))))))) + (let ((start2 (string-skip-right path #\/ 0 start))) + (if (zero? start2) + "/" + (substring-cursor path 0 start2))))))))) -(define (path-extension-pos path) (string-scan-right #\. path)) +(define (path-extension-pos path) + (let ((end (string-cursor-end path))) + (let lp ((i end) (dot #f)) + (if (<= i 0) + #f + (let* ((i2 (string-cursor-prev path i)) + (ch (string-cursor-ref path i2))) + (cond ((eqv? #\. ch) (and (< i end) (lp i2 (or dot i)))) + ((eqv? #\/ ch) #f) + (dot) + (else (lp i2 #f)))))))) -;;> Returns the rightmost extension of \var{path}, not including -;;> the \scheme{"."}. If there is no extension, returns \scheme{#f}. +;;> Returns the rightmost extension of \var{path}, not including the +;;> \scheme{"."}. If there is no extension, returns \scheme{#f}. The +;;> extension will always be non-empty and contain no \scheme{"."}s. (define (path-extension path) (let ((i (path-extension-pos path))) (and i - (let ((start (+ i 1)) (end (string-length path))) - (and (< start end) (substring path start end)))))) + (substring-cursor path i)))) ;;> Returns \var{path} with the extension, if any, removed, ;;> along with the \scheme{"."}. (define (path-strip-extension path) (let ((i (path-extension-pos path))) - (if (and i (< (+ i 1) (string-length path))) - (substring path 0 i) + (if i + (substring-cursor path 0 (string-cursor-prev path i)) path))) ;;> Returns \var{path} with the extension, if any, replaced @@ -97,7 +76,8 @@ (define (path-replace-extension path ext) (string-append (path-strip-extension path) "." ext)) -;;> Returns \scheme{#t} iff \var{path} is an absolute path. +;;> Returns \scheme{#t} iff \var{path} is an absolute path, +;;> i.e. begins with "/". (define (path-absolute? path) (and (not (string=? "" path)) (eqv? #\/ (string-ref path 0)))) @@ -106,6 +86,34 @@ (define (path-relative? path) (not (path-absolute? path))) +;;> Returns the suffix of \var{path} relative to the directory +;;> \var{dir}, or \scheme{#f} if \var{path} is not contained in +;;> \var{dir}. If the two are the same (modulo a trailing +;;> \scheme{"/"}), then \scheme{"."} is returned. + +(define (path-relative-to path dir) + (let* ((path (path-normalize path)) + (path-end (string-cursor-end path)) + (dir (path-normalize dir)) + (dir-end (string-cursor-end dir)) + (i (string-mismatch dir path))) + (cond + ((not (<= 1 dir-end i path-end)) + (let ((i2 (string-cursor-next path i))) + (and (= i path-end) + (= i2 dir-end) + (eqv? #\/ (string-cursor-ref dir i)) + "."))) + ((= i path-end) + ".") + ((eqv? #\/ (string-cursor-ref path i)) + (let ((i2 (string-cursor-next path i))) + (if (= i2 path-end) "." (substring-cursor path i2)))) + ((eqv? #\/ (string-cursor-ref path (string-cursor-prev path i))) + (substring-cursor path i)) + (else + #f)))) + ;; This looks big and hairy, but it's mutation-free and guarantees: ;; (string=? s (path-normalize s)) <=> (eq? s (path-normalize s)) ;; i.e. fast and simple for already normalized paths. @@ -124,7 +132,7 @@ (define (finish i res) (if (zero? i) path - (apply string-append (reverse (collect i len res))))) + (string-join (reverse (collect i len res))))) ;; loop invariants: ;; - res is a list such that (string-concatenate-reverse res) ;; is always the normalized string up to j @@ -186,6 +194,8 @@ ;;> Return a new string representing the path where each of \var{args} ;;> is a path component, separated with the directory separator. +;;> \var{args} may include symbols and integers, in addition to +;;> strings. (define (make-path . args) (define (x->string x) @@ -194,8 +204,7 @@ ((number? x) (number->string x)) (else (error "not a valid path component" x)))) (define (trim-trailing-slash s) - (let ((i (string-skip-right #\/ s))) - (if i (substring s 0 (+ i 1)) ""))) + (substring-cursor s 0 (string-skip-right s #\/))) (if (null? args) "" (let ((start (trim-trailing-slash (x->string (car args))))) @@ -203,7 +212,7 @@ (res (if (string=? "" start) '() (list start)))) (cond ((null? ls) - (apply string-append (reverse res))) + (string-join (reverse res))) ((pair? (car ls)) (lp (append (car ls) (cdr ls)) res)) (else diff --git a/lib/chibi/pathname.sld b/lib/chibi/pathname.sld index ea6f5540..016cf7fe 100644 --- a/lib/chibi/pathname.sld +++ b/lib/chibi/pathname.sld @@ -1,7 +1,8 @@ (define-library (chibi pathname) - (export path-strip-directory path-directory ;; path-extension-pos + (export path-strip-directory path-directory path-extension path-strip-extension path-replace-extension - path-absolute? path-relative? path-normalize make-path) - (import (chibi)) + path-absolute? path-relative? + path-relative-to path-normalize make-path) + (import (chibi) (chibi string)) (include "pathname.scm")) diff --git a/tests/path-tests.scm b/tests/path-tests.scm new file mode 100644 index 00000000..d6f30654 --- /dev/null +++ b/tests/path-tests.scm @@ -0,0 +1,189 @@ + +(import (chibi) (chibi pathname) (chibi test)) + +(test-begin "pathname") + +;; tests from the dirname(3) manpage + +(test "dirname(3)" "/usr" (path-directory "/usr/lib")) +(test "lib" (path-strip-directory "/usr/lib")) + +(test "/" (path-directory "/usr/")) +(test "" (path-strip-directory "/usr/")) + +(test "." (path-directory "usr")) +(test "usr" (path-strip-directory "usr")) + +(test "/" (path-directory "/")) +(test "" (path-strip-directory "/")) + +(test "." (path-directory ".")) +(test "." (path-strip-directory ".")) + +(test "." (path-directory "..")) +(test ".." (path-strip-directory "..")) + +;; additional tests (should match GNU dirname/basename behavior) + +(test "path-directory:border" + "/" (path-directory "//")) +(test "" (path-strip-directory "//")) + +(test "." (path-directory "")) +(test "" (path-strip-directory "")) + +(test "." (path-directory "../")) +(test "" (path-strip-directory "../")) + +(test ".." (path-directory "../..")) +(test ".." (path-strip-directory "../..")) + +(test "path-directory:extra" + "/usr/local" (path-directory "/usr/local/lib")) +(test "lib" (path-strip-directory "/usr/local/lib")) + +(test "/usr" (path-directory "/usr/local/")) +(test "" (path-strip-directory "/usr/local/")) + +(test "usr" (path-directory "usr/local")) +(test "local" (path-strip-directory "usr/local")) + +(test "/" (path-directory "//usr")) +(test "usr" (path-strip-directory "//usr")) + +(test "/" (path-directory "//usr/")) +(test "" (path-strip-directory "//usr/")) + +(test "path-directory:small" + "/a" (path-directory "/a/b")) +(test "b" (path-strip-directory "/a/b")) + +(test "a" (path-directory "a/b")) +(test "b" (path-strip-directory "a/b")) + +(test "a" (path-directory "a/b/")) +(test "" (path-strip-directory "a/b/")) + +(test "/a/b/c" (path-directory "/a/b/c/d")) +(test "d" (path-strip-directory "/a/b/c/d")) + +(test "/a/b/c" (path-directory "/a/b/c/d/")) +(test "" (path-strip-directory "/a/b/c/d/")) + +(test "a/b/c" (path-directory "a/b/c/d")) +(test "d" (path-strip-directory "a/b/c/d")) + +(test "/a/b" (path-directory "/a/b/c.d")) +(test "c.d" (path-strip-directory "/a/b/c.d")) + +(test "/a/b" (path-directory "/a/b/c.d/")) +(test "" (path-strip-directory "/a/b/c.d/")) + +(test "/a/b/c" (path-directory "/a/b/c/.")) +(test "." (path-strip-directory "/a/b/c/.")) + +(test "/a/b/c" (path-directory "/a/b/c/..")) +(test ".." (path-strip-directory "/a/b/c/..")) + +(test "/a/b/." (path-directory "/a/b/./c")) +(test "c" (path-strip-directory "/a/b/./c")) + +(test "/a/b/.." (path-directory "/a/b/../c")) +(test "c" (path-strip-directory "/a/b/../c")) + +(test "/a/b" (path-directory "/a/b/c//")) +(test "" (path-strip-directory "/a/b/c//")) + +(test "/a/b" (path-directory "/a/b//c///")) +(test "" (path-strip-directory "/a/b//c///")) + +;; extensions + +(test "path-extension" "scm" (path-extension "foo.scm")) +(test "foo" (path-strip-extension "foo.scm")) + +(test "c" (path-extension "foo.scm.c")) +(test "foo.scm" (path-strip-extension "foo.scm.c")) + +(test "scm" (path-extension "/home/me/foo.scm")) +(test "/home/me/foo" (path-strip-extension "/home/me/foo.scm")) + +(test "scm" (path-extension "foo..scm")) +(test "foo." (path-strip-extension "foo..scm")) + +(test "s" (path-extension "foo.s")) +(test "foo" (path-strip-extension "foo.s")) + +(test #f (path-extension "foo.")) +(test "foo." (path-strip-extension "foo.")) + +(test #f (path-extension "foo.scm.")) +(test "foo.scm." (path-strip-extension "foo.scm.")) + +(test #f (path-extension ".")) +(test "." (path-strip-extension ".")) + +(test #f (path-extension "a.")) +(test "a." (path-strip-extension "a.")) + +(test #f (path-extension "/.")) +(test "/." (path-strip-extension "/.")) + +(test #f (path-extension "foo.scm/")) +(test "foo.scm/" (path-strip-extension "foo.scm/")) + +(test "path-replace-extension" + "foo.c" (path-replace-extension "foo.scm" "c")) +(test "foo.c" (path-replace-extension "foo" "c")) + +;; absolute paths + +(test-assert (path-absolute? "/")) +(test-assert (path-absolute? "//")) +(test-assert (path-absolute? "/usr")) +(test-assert (path-absolute? "/usr/")) +(test-assert (path-absolute? "/usr/.")) +(test-assert (path-absolute? "/usr/..")) +(test-assert (path-absolute? "/usr/./")) +(test-assert (path-absolute? "/usr/../")) + +(test-assert (not (path-absolute? ""))) +(test-assert (not (path-absolute? "."))) +(test-assert (not (path-absolute? "usr"))) +(test-assert (not (path-absolute? "usr/"))) + +;; normalization & building + +(test "path-normalize" "/a/b/c/d/e" (path-normalize "/a/b/c/d/./e")) +(test "/a/b/c/d/e" (path-normalize "/a/b//.///c//d/./e")) +(test "/a/b/c/d/e/" (path-normalize "/a/b//.///c//d/./e/")) +(test "/a/c/d/e" (path-normalize "/a/b/../c/d/e")) +(test "/a/b/c/e" (path-normalize "/a/b//.///c//d/../e")) +(test "/a/c/e" (path-normalize "/a/b//..///c//d/../e")) +(test "/a/b/c/d/e/" + (path-normalize "/a/b//./../c/d/../../b//c/d/e/f/..")) + +(test "path-normalize:border" "" (path-normalize "")) +(test "." (path-normalize ".")) +(test "/" (path-normalize "/")) + +(test "path-normalize:overflow" + "/" (path-normalize "/a/b/c/../../../../..")) +(test "../.." (path-normalize "a/b/c/../../../../..")) +(test "../../.." (path-normalize "../a/b/c/../../../../..")) + +(test "path-relative-to" "c" (path-relative-to "/a/b/c" "/a/b")) +(test "c" (path-relative-to "/a/b/c" "/a/b/")) +(test "." (path-relative-to "/a/b/" "/a/b/")) +(test "." (path-relative-to "/a/b/" "/a/b")) +(test "." (path-relative-to "/a/b" "/a/b/")) +(test "." (path-relative-to "/a/b" "/a/b")) +(test-not (path-relative-to "/d/a/b/c" "/a/b")) + +(test "make-path" "a/b" (make-path "a" "b")) +(test "a/b" (make-path "a/" "b")) +(test "a/b/./c" (make-path "a" "b" "." "c")) +(test "a/b/../c" (make-path "a" "b" ".." "c")) +(test "a/b/c" (make-path "a" '("b" "c"))) + +(test-end)