scsh-0.6/scsh/fname.scm

200 lines
6.3 KiB
Scheme
Raw Normal View History

;;; 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)
2003-04-16 09:01:32 -04:00
(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)))
2003-04-16 09:01:32 -04:00
(if (zero? len)
"." ; "" -> "."
;; Trim trailing slashes.
(cond ((last-non-slash fname) =>
(lambda (i)
2003-04-16 09:01:32 -04:00
(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)
2003-04-16 09:01:32 -04:00
(if (string=? fname "")
""
(file-name-as-directory fname)))
(define (ensure-file-name-is-nondirectory fname)
2003-04-16 09:01:32 -04:00
(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)
1999-09-23 13:46:46 -04:00
(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)
1999-09-23 13:46:46 -04:00
(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) '())
1999-09-23 13:46:46 -04:00
((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))))