mirror of
https://github.com/ashinn/chibi-scheme.git
synced 2025-05-18 21:29:19 +02:00
263 lines
10 KiB
Scheme
263 lines
10 KiB
Scheme
;; Copyright (c) 2009-2013 Alex Shinn. All rights reserved.
|
|
;; BSD-style license: http://synthcode.com/license.txt
|
|
|
|
;; POSIX basename
|
|
;; (define (path-strip-directory path)
|
|
;; (if (string=? path "")
|
|
;; path
|
|
;; (let ((end (string-skip-right path #\/)))
|
|
;; (if (zero? end)
|
|
;; "/"
|
|
;; (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), or is empty, return the
|
|
;;> empty string.
|
|
|
|
;; GNU basename
|
|
(define (path-strip-directory path)
|
|
(substring-cursor path (string-find-right path #\/)))
|
|
|
|
;;> Returns just the directory of \var{path}.
|
|
;;> If \var{path} is relative (or empty), return \scheme{"."}.
|
|
|
|
(define (path-directory path)
|
|
(if (string=? path "")
|
|
"."
|
|
(let ((start (string-cursor-start path))
|
|
(end (string-skip-right path #\/)))
|
|
(if (string-cursor=? start end)
|
|
"/"
|
|
(let ((slash (string-find-right path #\/ start end)))
|
|
(if (string-cursor=? start slash)
|
|
"."
|
|
(let ((start2 (string-skip-right path #\/ start slash)))
|
|
(if (string-cursor=? start start2)
|
|
"/"
|
|
(substring-cursor path start start2)))))))))
|
|
|
|
(define (path-extension-pos path)
|
|
(let ((start (string-cursor-start path))
|
|
(end (string-cursor-end path)))
|
|
(let lp ((i end) (dot #f))
|
|
(if (string-cursor<=? i start)
|
|
#f
|
|
(let* ((i2 (string-cursor-prev path i))
|
|
(ch (string-cursor-ref path i2)))
|
|
(cond ((eqv? #\. ch)
|
|
(and (string-cursor<? 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}. The
|
|
;;> extension will always be non-empty and contain no \scheme{"."}s.
|
|
|
|
(define (path-extension path)
|
|
(let ((i (path-extension-pos path)))
|
|
(and i
|
|
(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 i
|
|
(substring-cursor path
|
|
(string-cursor-start path)
|
|
(string-cursor-prev path i))
|
|
path)))
|
|
|
|
;;> Returns \var{path} with the extension, if any, replaced
|
|
;;> with \var{ext}.
|
|
|
|
(define (path-replace-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-cursor
|
|
path
|
|
(string-cursor-forward path (string-cursor-start path) 3)))
|
|
(if (equal? path "..") "" 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))))
|
|
|
|
;;> Returns \scheme{#t} iff \var{path} is a relative path.
|
|
|
|
(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 (string-cursor<=? 1 dir-end i path-end))
|
|
(let ((i2 (string-cursor-next path i)))
|
|
(and (string-cursor=? i path-end)
|
|
(string-cursor=? i2 dir-end)
|
|
(eqv? #\/ (string-cursor-ref dir i))
|
|
".")))
|
|
((string-cursor=? i path-end)
|
|
".")
|
|
((eqv? #\/ (string-cursor-ref path i))
|
|
(let ((i2 (string-cursor-next path i)))
|
|
(if (string-cursor=? i2 path-end) "." (substring-cursor path i2))))
|
|
((eqv? #\/ (string-cursor-ref path (string-cursor-prev path i)))
|
|
(substring-cursor path i))
|
|
(else
|
|
#f))))
|
|
|
|
;;> Resolve \var{path} relative to the given directory. Returns
|
|
;;> \var{path} unchanged if already absolute.
|
|
|
|
(define (path-resolve path dir)
|
|
(if (path-absolute? path) path (make-path dir path)))
|
|
|
|
;; 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.
|
|
|
|
;;> Returns a normalized version of path, with duplicate directory
|
|
;;> separators removed and "/./" and "x/../" references removed.
|
|
;;> Does not take symbolic links into account - this is meant to
|
|
;;> be abstract and applicable to paths on remote systems and in
|
|
;;> URIs. Returns \var{path} itself if \var{path} is already
|
|
;;> normalized.
|
|
|
|
(define (path-normalize path)
|
|
(let* ((start (string-cursor-start path))
|
|
(end (string-cursor-end path))
|
|
(end-1 (string-cursor-prev path end)))
|
|
(define (collect i j res)
|
|
(if (string-cursor>=? i j) res (cons (substring-cursor path i j) res)))
|
|
(define (finish i res)
|
|
(if (string-cursor=? start i)
|
|
path
|
|
(string-join (reverse (collect i end res)))))
|
|
;; loop invariants:
|
|
;; - res is a list such that (string-concatenate-reverse res)
|
|
;; is always the normalized string up to j
|
|
;; - the tail of the string from j onward can be concatenated to
|
|
;; the above value to get a partially normalized path referring
|
|
;; to the same location as the original path
|
|
(define (inside i j res)
|
|
(if (string-cursor>=? j end)
|
|
(finish i res)
|
|
(if (eqv? #\/ (string-cursor-ref path j))
|
|
(boundary i (string-cursor-next path j) res)
|
|
(inside i (string-cursor-next path j) res))))
|
|
(define (boundary i j res)
|
|
(if (string-cursor>=? j end)
|
|
(finish i res)
|
|
(case (string-cursor-ref path j)
|
|
((#\.)
|
|
(cond
|
|
((or (string-cursor=? j end-1)
|
|
(eqv? #\/ (string-cursor-ref path (string-cursor-next path j))))
|
|
(if (string-cursor=? i j)
|
|
(boundary (string-cursor-forward path j 2)
|
|
(string-cursor-forward path j 2)
|
|
res)
|
|
(let ((s (substring-cursor path i j)))
|
|
(boundary (string-cursor-forward path j 2)
|
|
(string-cursor-forward path j 2)
|
|
(cons s res)))))
|
|
((eqv? #\. (string-cursor-ref path (string-cursor-next path j)))
|
|
(if (or (string-cursor>=? j (string-cursor-backward path end 2))
|
|
(eqv? #\/ (string-cursor-ref
|
|
path
|
|
(string-cursor-forward path j 2))))
|
|
(if (string-cursor>=? i (string-cursor-prev path j))
|
|
(if (null? res)
|
|
(backup j "" '())
|
|
(backup j (car res) (cdr res)))
|
|
(backup j (substring-cursor path i j) res))
|
|
(inside i (string-cursor-forward path j 2) res)))
|
|
(else
|
|
(inside i (string-cursor-next path j) res))))
|
|
((#\/)
|
|
(boundary (string-cursor-next path j)
|
|
(string-cursor-next path j)
|
|
(collect i j res)))
|
|
(else (inside i (string-cursor-next path j) res)))))
|
|
(define (backup j s res)
|
|
(let ((pos (string-cursor-forward path j 3)))
|
|
(cond
|
|
;; case 1: we're reduced to accumulating parents of the cwd
|
|
((or (string=? s "/..") (string=? s ".."))
|
|
(boundary pos pos (cons "/.." (cons s res))))
|
|
;; case 2: the string isn't a component itself, skip it
|
|
((or (string=? s "") (string=? s ".") (string=? s "/"))
|
|
(if (pair? res)
|
|
(backup j (car res) (cdr res))
|
|
(boundary pos pos (if (string=? s "/") '("/") '("..")))))
|
|
;; case3: just take the directory of the string
|
|
(else
|
|
(let ((d (path-directory s)))
|
|
(cond
|
|
((string=? d "/")
|
|
(boundary pos pos (if (null? res) '("/") res)))
|
|
((string=? d ".")
|
|
(boundary pos pos res))
|
|
(else (boundary pos pos (cons "/" (cons d res))))))))))
|
|
;; start with boundary if abs path, otherwise inside
|
|
(if (string-cursor=? start end)
|
|
path
|
|
((if (eqv? #\/ (string-ref path 0)) boundary inside)
|
|
start (string-cursor-next path start) '()))))
|
|
|
|
;;> 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)
|
|
(cond ((string? x) x)
|
|
((symbol? x) (symbol->string x))
|
|
((number? x) (number->string x))
|
|
(else (error "not a valid path component" x))))
|
|
(define (trim-trailing-slash s)
|
|
(substring-cursor s (string-cursor-start s) (string-skip-right s #\/)))
|
|
(if (null? args)
|
|
""
|
|
(let* ((args0 (x->string (car args)))
|
|
(start (trim-trailing-slash args0)))
|
|
(let lp ((ls (cdr args))
|
|
(res (if (string=? "" start) '() (list start))))
|
|
(cond
|
|
((null? ls)
|
|
(if (and (null? res) (not (string=? "" args0)))
|
|
"/"
|
|
(string-join (reverse res))))
|
|
((pair? (car ls))
|
|
(lp (append (car ls) (cdr ls)) res))
|
|
(else
|
|
(let ((x (trim-trailing-slash (x->string (car ls)))))
|
|
(cond
|
|
((string=? x "")
|
|
(lp (cdr ls) res))
|
|
((eqv? #\/ (string-ref x 0))
|
|
(lp (cdr ls) (cons x res)))
|
|
(else
|
|
(lp (cdr ls) (cons x (cons "/" res))))))))))))
|