200 lines
6.3 KiB
Scheme
200 lines
6.3 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 ((string-index-right 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 ((string-index-right 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) '())
|
|
((string-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 (string-index-right fname #\.))
|
|
(slash (string-index-right fname #\/)))
|
|
(if (and dot
|
|
(> dot 0)
|
|
(if slash (> dot slash) #t)
|
|
(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))
|
|
|
|
;;; - 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))))
|
|
|
|
|
|
|
|
|
|
|