scsh-0.6/scsh/fname.scm

269 lines
8.5 KiB
Scheme

;;; Code for processing Unix file names.
;;; Copyright (c) 1992 by Olin Shivers (shivers@lcs.mit.edu).
;;; Please imagine a long, tedious, legalistic 5-page gnu-style copyright
;;; notice appearing here to the effect that you may use this code any
;;; way you like, as long as you don't charge money for it, remove this
;;; notice, or hold me liable for its results.
;;; We adhere to Posix file name rules, plus we treat files beginning with
;;; ~ as absolute paths.
;;; Relevant bits of CScheme:
;;; pathnm sfile strnin unxcwd unxdir unxpar unxprm unxpth unxunp wrkdir
(define (file-name-directory? fname)
(or (string=? fname "") ; Note! "" is directory (cwd)
(char=? #\/ (string-ref fname (- (string-length fname) 1)))))
(define (file-name-non-directory? fname)
(or (string=? fname "") ; and file-name (root).
(not (char=? #\/ (string-ref fname (- (string-length fname) 1))))))
(define (file-name-as-directory fname)
(if (string=? fname ".") ""
(let ((len (string-length fname)))
(if (and (> len 0)
(char=? #\/ (string-ref fname (- len 1))))
fname
(string-append fname "/")))))
;;; Return #f if str doesn't contain a slash at all.
(define (last-non-slash str)
(let lp ((i (- (string-length str) 1)))
(and (>= i 0)
(if (char=? #\/ (string-ref str i))
(lp (- i 1))
i))))
(define (directory-as-file-name fname)
(let ((len (string-length fname)))
(if (zero? len) "." ; "" -> "."
;; Trim trailing slashes.
(cond ((last-non-slash fname) =>
(lambda (i)
(if (= i (- len 1)) fname ; No slash.
(substring fname 0 (+ i 1))))) ; Trim slashes.
;;; Solid slashes -- invoke weird Posix rule.
(else (if (= len 2) "//" "/"))))))
(define (ensure-file-name-is-directory fname)
(if (string=? fname "") ""
(file-name-as-directory fname)))
(define (ensure-file-name-is-nondirectory fname)
(if (string=? fname "") ""
(directory-as-file-name fname)))
(define (file-name-absolute? fname)
(or (= (string-length fname) 0)
(char=? #\/ (string-ref fname 0))
(char=? #\~ (string-ref fname 0))))
;;; Returns FNAME's directory component in *directory form.*
(define (file-name-directory fname)
(cond ((rindex fname #\/) =>
(lambda (rslash)
(if (last-non-slash fname)
(substring fname 0 (+ 1 rslash))
""))) ; Posix strangeness: solid slashes are root.
(else "")))
(define (file-name-nondirectory fname)
(cond ((rindex fname #\/) =>
(lambda (rslash)
(if (last-non-slash fname)
(substring fname (+ 1 rslash) (string-length fname))
fname))) ; Posix strangeness: solid slashes are root.
(else fname)))
(define (split-file-name fname)
(let* ((fname (ensure-file-name-is-nondirectory fname))
(len (string-length fname)))
(let split ((start 0))
(cond ((>= start len) '())
((index fname #\/ start) =>
(lambda (slash)
(cons (substring fname start slash)
(split (+ slash 1)))))
(else (list (substring fname start len)))))))
(define (path-list->file-name pathlist . maybe-dir)
(let ((root (ensure-file-name-is-nondirectory (:optional maybe-dir ".")))
;; Insert slashes *between* elts of PATHLIST.
(w/slashes (if (pair? pathlist)
(let insert-slashes ((pathlist pathlist))
(let ((elt (car pathlist))
(pathlist (cdr pathlist)))
(cons elt (if (pair? pathlist)
(cons "/" (insert-slashes pathlist))
'()))))
'(""))))
(apply string-append
(if (and (pair? pathlist)
(string=? "" (car pathlist)))
w/slashes ; Absolute path not relocated.
(cons (file-name-as-directory root) w/slashes)))))
(define (parse-file-name fname)
(let ((nd (file-name-nondirectory fname)))
(values (file-name-directory fname)
(file-name-sans-extension nd)
(file-name-extension nd))))
;;; Return the index of the . separating the extension from the rest of
;;; the file name. If no extension, returns an index pointing off the
;;; end of the string, i.e. (string-length fname). "Dot-files," such as
;;; /usr/shivers/.login are not considered extensions.
(define (file-name-extension-index fname)
(let ((dot (rindex fname #\.)))
(if (and dot
(> dot 0)
(not (char=? #\/ (string-ref fname (- dot 1)))))
dot
(string-length fname))))
(define (file-name-sans-extension fname)
(substring fname 0 (file-name-extension-index fname)))
(define (file-name-extension fname)
(substring fname (file-name-extension-index fname)
(string-length fname)))
(define (replace-extension fname ext)
(string-append (file-name-sans-extension fname) ext))
(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 ((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))
(len (string-length fname)))
(if (zero? len) "/"
(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)))))))
;;; - Remove leading and internal occurrences of dot. A trailing dot
;;; is left alone, in case the parent is a symlink.
;;; - Remove internal and trailing double-slashes. A leading double-slash
;;; is left alone, in accordance w/Posix. However, triple and more leading
;;; slashes are reduced to a single slash, in accordance w/Posix.
;;; - Double-dots are left alone, in case they come after symlinks.
(define (simplify-file-name fname)
;; First, we simplify leading multiple slashes:
;; 1 or >2 slashes -> /, 2 slashes -> //
(receive (slashes fname)
(let ((len (string-length fname)))
(if (and (> len 0) (char=? #\/ (string-ref fname 0)))
(let ((j (let lp ((i 1)) ; j is index of first non-slash.
(if (and (< i len)
(char=? (string-ref fname i) #\/))
(lp (+ i 1))
i))))
(if (< j 3)
(values (substring fname 0 j); One or two slashes - OK.
(substring fname j len))
(values "/" (substring fname (- j 1) len))))
(values "" fname)))
;; At this point, all leading slashes have been pulled off of FNAME.
;; Any remaining repeated slashes are fair game for removal.
(let* ((path-list (split-file-name fname))
(ans (if (pair? path-list)
(reverse (let lp ((path-list path-list)
(ans (list slashes)))
(let ((elt (car path-list))
(path-list (cdr path-list)))
(if (pair? path-list)
(lp path-list
(if (or (string=? "." elt) ; kill .
(string=? "" elt)) ; and //
ans
`("/" ,elt ,@ans)))
(cons elt ans)))))
(list slashes))))
(apply string-append ans))))
(define (expand-file-name fname . maybe-dir)
(simplify-file-name (apply resolve-file-name fname maybe-dir)))
(define (home-dir . maybe-user)
(if (pair? maybe-user)
(let ((user (car maybe-user)))
(ensure-file-name-is-nondirectory
(or (%homedir user)
(error "Cannot get user's home directory"
user))))
home-directory))
;;; (home-file [user] fname)
(define (home-file arg1 . maybe-arg2)
(receive (dir fname)
(if (pair? maybe-arg2)
(values (home-dir arg1) (car maybe-arg2))
(values home-directory arg1))
(string-append (file-name-as-directory dir) 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)))
((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 ((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 (index s #\/) len)))
(lp (cons (getenv (substring s 0 i)) ans)
(substring s i len))))))))))
(else (lp (cons s ans) ""))))))