scsh-0.6/scsh/fname-system.scm

72 lines
2.3 KiB
Scheme
Raw Normal View History

;; user/group-dependent stuff
(define (resolve-tilde-file-name fname)
(let ((len (string-length fname)))
(if (and (> len 0) (char=? #\~ (string-ref fname 0)))
(let ((tilde->homedir (lambda (end)
(if (= end 1)
home-directory ; Just ~
(let* ((user (substring fname 1 end))
(ui (name->user-info user)))
(user-info:home-dir ui))))))
(cond ((string-index fname #\/ 1) =>
(lambda (slash)
(string-append (tilde->homedir slash) "/"
(substring fname (+ slash 1) len))))
(else (tilde->homedir len))))
fname)))
(define (resolve-file-name fname . maybe-root)
(let* ((root (ensure-file-name-is-nondirectory (:optional maybe-root ".")))
(fname (ensure-file-name-is-nondirectory fname)))
(if (zero? (string-length fname))
"/"
(let ((c (string-ref fname 0)))
(cond ((char=? #\/ c) fname) ; Absolute file name.
((char=? #\~ c) ; ~ file name
(resolve-tilde-file-name fname))
(else (string-append (file-name-as-directory root) fname)))))))
(define (expand-file-name fname . maybe-dir)
(simplify-file-name (apply resolve-file-name fname maybe-dir)))
;; process-state-dependent stuff
(define (absolute-file-name fname . maybe-root)
(let ((fname (ensure-file-name-is-nondirectory fname)))
(if (zero? (string-length fname))
"/"
(simplify-file-name
(if (char=? #\/ (string-ref fname 0))
fname ; Absolute file name.
(let ((root (:optional maybe-root (cwd))))
(string-append (file-name-as-directory root) fname)))))))
;;; Ugh.
(define (substitute-env-vars str)
(let lp ((ans '()) (s str))
(let ((len (string-length s)))
(cond
((zero? len) (apply string-append (reverse! ans)))
((string-index s #\$) =>
(lambda (i)
(let ((ans (cons (substring s 0 i) ans))
(s (substring s (+ i 1) len))
(len (- len (+ i 1))))
(if (zero? len)
(lp ans "")
(let ((next-char (string-ref s 0)))
(cond ((char=? #\{ next-char)
(cond ((string-index s #\}) =>
(lambda (i)
(lp (cons (getenv (substring s 1 i)) ans)
(substring s (+ i 1) len))))
(else (error "Unbalanced ${ delimiter in string" s))))
(else
(let ((i (or (string-index s #\/) len)))
(lp (cons (getenv (substring s 0 i)) ans)
(substring s i len))))))))))
(else (lp (cons s ans) ""))))))