Fcalva/chibi-scheme
1
0
Fork 0
mirror of https://github.com/ashinn/chibi-scheme.git synced 2025-05-21 22:59:16 +02:00
Code Issues Projects Releases Packages Wiki Activity Actions

Adding path-strip-leading-parents.

Browse source
This commit is contained in:
Alex Shinn 2013-08-31 20:02:53 +09:00
parent 38685f6aca
commit d198557c8b
3 changed files with 15 additions and 1 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

7
lib/chibi/pathname.scm
View file

@ -76,6 +76,13 @@
(define (path-replace-extension path ext) (define (path-replace-extension path ext)
(string-append (path-strip-extension path) "." ext)) (string-append (path-strip-extension path) "." ext))
;;> Returns \var{path} with any leading ../ removed.
(define (path-strip-leading-parents path)
(if (string-prefix? "../" path)
(path-strip-leading-parents (substring path 3))
(if (equal? path "..") "" path)))
;;> Returns \scheme{#t} iff \var{path} is an absolute path, ;;> Returns \scheme{#t} iff \var{path} is an absolute path,
;;> i.e. begins with "/". ;;> i.e. begins with "/".

2
lib/chibi/pathname.sld
View file

@ -2,7 +2,7 @@
(define-library (chibi pathname) (define-library (chibi pathname)
(export path-strip-directory path-directory (export path-strip-directory path-directory
path-extension path-strip-extension path-replace-extension path-extension path-strip-extension path-replace-extension
path-absolute? path-relative? path-absolute? path-relative? path-strip-leading-parents
path-relative-to path-normalize make-path) path-relative-to path-normalize make-path)
(import (chibi) (chibi string)) (import (chibi) (chibi string))
(include "pathname.scm")) (include "pathname.scm"))

7
tests/path-tests.scm
View file

@ -172,6 +172,13 @@
(test "../.." (path-normalize "a/b/c/../../../../..")) (test "../.." (path-normalize "a/b/c/../../../../.."))
(test "../../.." (path-normalize "../a/b/c/../../../../..")) (test "../../.." (path-normalize "../a/b/c/../../../../.."))
(test "" (path-strip-leading-parents ".."))
(test "" (path-strip-leading-parents "../"))
(test "a" (path-strip-leading-parents "../a"))
(test "a/b" (path-strip-leading-parents "../../a/b"))
(test "a/b" (path-strip-leading-parents "../../../a/b"))
(test "a/../b" (path-strip-leading-parents "../../../a/../b"))
(test "path-relative-to" "c" (path-relative-to "/a/b/c" "/a/b")) (test "path-relative-to" "c" (path-relative-to "/a/b/c" "/a/b"))
(test "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/"))