495 lines
19 KiB
Scheme
495 lines
19 KiB
Scheme
(module file mzscheme
|
|
(provide find-relative-path
|
|
explode-path
|
|
normalize-path
|
|
build-absolute-path
|
|
build-relative-path
|
|
filename-extension
|
|
file-name-from-path
|
|
path-only
|
|
delete-directory/files
|
|
copy-directory/files
|
|
make-directory*
|
|
make-temporary-file
|
|
find-library
|
|
|
|
get-preference
|
|
put-preferences
|
|
|
|
call-with-input-file*
|
|
call-with-output-file*
|
|
|
|
fold-files
|
|
find-files
|
|
pathlist-closure)
|
|
|
|
(require "list.ss" "kw.ss")
|
|
|
|
(define build-relative-path
|
|
(lambda (p . args)
|
|
(if (relative-path? p)
|
|
(apply build-path p args)
|
|
(error 'build-relative-path "base path ~s is absolute" p))))
|
|
|
|
(define build-absolute-path
|
|
(lambda (p . args)
|
|
(if (relative-path? p)
|
|
(error 'build-absolute-path "base path ~s is relative" p)
|
|
(apply build-path p args))))
|
|
|
|
;; Note that normalize-path does not normalize the case
|
|
(define normalize-path
|
|
(letrec ([resolve-all
|
|
(lambda (path wrt)
|
|
(let ([orig-path (if (and wrt (not (complete-path? path)))
|
|
(path->complete-path path wrt)
|
|
path)])
|
|
(let loop ([full-path orig-path][seen-paths (list orig-path)])
|
|
(let ([resolved (resolve-path full-path)])
|
|
(if (equal? resolved full-path)
|
|
(do-normalize-path resolved #f)
|
|
(let ([path (if (relative-path? resolved)
|
|
(build-path
|
|
(let-values ([(base name dir?) (split-path full-path)])
|
|
base)
|
|
resolved)
|
|
resolved)])
|
|
(if (member path seen-paths)
|
|
(error 'normalize-path "circular reference at ~s" path)
|
|
(let ([spath
|
|
;; Use simplify-path to get rid of ..s, which can
|
|
;; allow the path to grow indefinitely in a cycle.
|
|
;; An exception must mean a cycle of links.
|
|
(with-handlers ([exn:fail:filesystem?
|
|
(lambda (x)
|
|
(error 'normalize-path "circular reference at ~s" path))])
|
|
(simplify-path path))])
|
|
(loop spath (cons path seen-paths))))))))))]
|
|
[resolve
|
|
(lambda (path)
|
|
(if (equal? path (resolve-path path))
|
|
path
|
|
(resolve-all path #f)))]
|
|
[normalize-path
|
|
(case-lambda
|
|
[(orig-path) (do-normalize-path orig-path (current-directory))]
|
|
[(orig-path wrt)
|
|
(unless (complete-path? wrt)
|
|
(raise-type-error 'normalize-path "complete path" wrt))
|
|
(do-normalize-path orig-path wrt)])]
|
|
[error-not-a-dir
|
|
(lambda (path)
|
|
(error 'normalize-path
|
|
"~s (within the input path) is not a directory or does not exist"
|
|
path))]
|
|
[do-normalize-path
|
|
(lambda (orig-path wrt)
|
|
(let normalize ([path (expand-path orig-path)])
|
|
(let-values ([(base name dir?) (split-path path)])
|
|
(cond
|
|
[(eq? name 'up)
|
|
(let up ([base (if (eq? base 'relative)
|
|
wrt
|
|
(resolve-all base wrt))])
|
|
(if (directory-exists? base)
|
|
(let-values ([(prev name dir?) (split-path base)])
|
|
(cond
|
|
[(not prev)
|
|
(error 'normalize-path
|
|
"root has no parent directory: ~s"
|
|
orig-path)]
|
|
[else
|
|
(let ([prev
|
|
(if (eq? prev 'relative)
|
|
wrt
|
|
(normalize prev))])
|
|
(cond
|
|
[(eq? name 'same) (up prev)]
|
|
[(eq? name 'up) (up (up prev))]
|
|
[else prev]))]))
|
|
(error-not-a-dir base)))]
|
|
[(eq? name 'same)
|
|
(cond
|
|
[(eq? base 'relative) wrt]
|
|
[else (let ([n (normalize base)])
|
|
(if (directory-exists? n)
|
|
n
|
|
(error-not-a-dir n)))])]
|
|
[else
|
|
(cond
|
|
[(not base) (path->complete-path path)]
|
|
[else (let* ([base (if (eq? base 'relative)
|
|
(normalize wrt)
|
|
(normalize base))]
|
|
[path (if (directory-exists? base)
|
|
(build-path base name)
|
|
(error-not-a-dir base))]
|
|
[resolved (expand-path (resolve path))])
|
|
(cond
|
|
[(relative-path? resolved)
|
|
(normalize (build-path base resolved))]
|
|
[(complete-path? resolved)
|
|
resolved]
|
|
[else (path->complete-path resolved base)]))])]))))])
|
|
normalize-path))
|
|
|
|
;; Argument must be in normal form
|
|
(define do-explode-path
|
|
(lambda (who orig-path)
|
|
(let loop ([path orig-path][rest '()])
|
|
(let-values ([(base name dir?) (split-path path)])
|
|
(when (or (and base
|
|
(not (path? base)))
|
|
(not (path? name)))
|
|
(raise-type-error who "path in normal form" orig-path))
|
|
(if base
|
|
(loop base (cons name rest))
|
|
(cons name rest))))))
|
|
|
|
(define explode-path
|
|
(lambda (orig-path)
|
|
(unless (path-string? orig-path)
|
|
(raise-type-error 'explode-path "path or string" orig-path))
|
|
(do-explode-path 'explode-path orig-path)))
|
|
|
|
;; Arguments must be in normal form
|
|
(define find-relative-path
|
|
(lambda (directory filename)
|
|
(let ([dir (do-explode-path 'find-relative-path directory)]
|
|
[file (do-explode-path 'find-relative-path filename)])
|
|
(if (equal? (car dir) (car file))
|
|
(let loop ([dir (cdr dir)]
|
|
[file (cdr file)])
|
|
(cond
|
|
[(null? dir) (if (null? file) filename (apply build-path file))]
|
|
[(null? file) (apply build-path (map (lambda (x) 'up) dir))]
|
|
[(equal? (car dir) (car file))
|
|
(loop (cdr dir) (cdr file))]
|
|
[else
|
|
(apply build-path
|
|
(append (map (lambda (x) 'up) dir)
|
|
file))]))
|
|
filename))))
|
|
|
|
(define (file-name who name)
|
|
(unless (path-string? name)
|
|
(raise-type-error who "path or string" name))
|
|
(let-values ([(base file dir?) (split-path name)])
|
|
(and (not dir?) (path? file) file)))
|
|
|
|
(define (file-name-from-path name)
|
|
(file-name 'file-name-from-path name))
|
|
|
|
(define (path-only name)
|
|
(unless (path-string? name)
|
|
(raise-type-error 'path-only "path or string" name))
|
|
(let-values ([(base file dir?) (split-path name)])
|
|
(cond [dir? name]
|
|
[(path? base) base]
|
|
[else #f])))
|
|
|
|
;; name can be any string; we just look for a dot
|
|
(define (filename-extension name)
|
|
(let* ([name (file-name 'filename-extension name)]
|
|
[name (and name (path->bytes name))])
|
|
(cond [(and name (regexp-match #rx#"[.]([^.]+)$" name)) => cadr]
|
|
[else #f])))
|
|
|
|
(define (delete-directory/files path)
|
|
(unless (path-string? path)
|
|
(raise-type-error 'delete-directory/files "path or string" path))
|
|
(cond
|
|
[(or (link-exists? path) (file-exists? path))
|
|
(delete-file path)]
|
|
[(directory-exists? path)
|
|
(for-each (lambda (e) (delete-directory/files (build-path path e)))
|
|
(directory-list path))
|
|
(delete-directory path)]
|
|
[else (error 'delete-directory/files
|
|
"encountered ~a, neither a file nor a directory"
|
|
path)]))
|
|
|
|
(define (copy-directory/files src dest)
|
|
(cond
|
|
[(file-exists? src)
|
|
(copy-file src dest)]
|
|
[(directory-exists? src)
|
|
(make-directory dest)
|
|
(for-each (lambda (e) (copy-directory/files (build-path src e)
|
|
(build-path dest e)))
|
|
(directory-list src))]
|
|
[else (error 'copy-directory/files
|
|
"encountered ~a, neither a file nor a directory"
|
|
src)]))
|
|
|
|
(define (make-directory* dir)
|
|
(let-values ([(base name dir?) (split-path dir)])
|
|
(when (and (path? base)
|
|
(not (directory-exists? base)))
|
|
(make-directory* base))
|
|
(unless (directory-exists? dir)
|
|
(make-directory dir))))
|
|
|
|
(define/kw (make-temporary-file
|
|
#:optional [template "mztmp~a"] copy-from base-dir)
|
|
(with-handlers ([exn:fail:contract?
|
|
(lambda (x)
|
|
(raise-type-error 'make-temporary-file
|
|
"format string for 1 argument"
|
|
template))])
|
|
(format template void))
|
|
(unless (or (not copy-from)
|
|
(path-string? copy-from)
|
|
(eq? copy-from 'directory))
|
|
(raise-type-error 'make-temporary-file
|
|
"path, valid-path string, 'directory, or #f"
|
|
copy-from))
|
|
(unless (or (not base-dir) (path-string? base-dir))
|
|
(raise-type-error 'make-temporary-file
|
|
"path, valid-path, string, or #f"
|
|
base-dir))
|
|
(let ([tmpdir (find-system-path 'temp-dir)])
|
|
(let loop ([s (current-seconds)][ms (current-milliseconds)])
|
|
(let ([name (let ([n (format template (format "~a~a" s ms))])
|
|
(cond
|
|
[base-dir (build-path base-dir n)]
|
|
[(relative-path? n) (build-path tmpdir n)]
|
|
[else n]))])
|
|
(with-handlers ([exn:fail:filesystem:exists?
|
|
(lambda (x)
|
|
;; try again with a new name
|
|
(loop (- s (random 10))
|
|
(+ ms (random 10))))])
|
|
(if copy-from
|
|
(if (eq? copy-from 'directory)
|
|
(make-directory name)
|
|
(copy-file copy-from name))
|
|
(close-output-port (open-output-file name)))
|
|
name)))))
|
|
|
|
(define/kw (find-library name #:optional [collection "mzlib"] #:rest cp)
|
|
(let ([dir (with-handlers ([exn:fail:filesystem? (lambda (exn) #f)])
|
|
(apply collection-path collection cp))])
|
|
(and dir
|
|
(let ([file (build-path dir name)])
|
|
(and (file-exists? file) file)))))
|
|
|
|
(define (with-pref-params thunk)
|
|
(parameterize ([read-case-sensitive #f]
|
|
[read-square-bracket-as-paren #t]
|
|
[read-curly-brace-as-paren #t]
|
|
[read-accept-box #t]
|
|
[read-accept-compiled #f]
|
|
[read-accept-bar-quote #t]
|
|
[read-accept-graph #t]
|
|
[read-decimal-as-inexact #t]
|
|
[read-accept-dot #t]
|
|
[read-accept-quasiquote #t]
|
|
[read-accept-reader #f]
|
|
[print-struct #f]
|
|
[print-graph #t]
|
|
[print-box #t]
|
|
[print-vector-length #t]
|
|
[current-readtable #f])
|
|
(thunk)))
|
|
|
|
|
|
(define pref-box (make-weak-box #f)) ; non-weak box => need to save
|
|
(define (get-prefs flush? filename)
|
|
(define (read-prefs)
|
|
(with-handlers ([exn:fail:filesystem? (lambda (x) null)])
|
|
(let* ([pref-file
|
|
(or filename
|
|
(let ([f (find-system-path 'pref-file)])
|
|
(if (file-exists? f)
|
|
;; Using `file-exists?' means there's technically a
|
|
;; race condition, but something has gone really wrong
|
|
;; if the file disappears.
|
|
f
|
|
;; Error here bails out through above `with-handlers'
|
|
(build-path (collection-path "defaults")
|
|
"plt-prefs.ss"))))]
|
|
[prefs (with-pref-params
|
|
(lambda ()
|
|
(with-input-from-file pref-file read)))])
|
|
;; Make sure file content had the right shape:
|
|
(if (and (list? prefs)
|
|
(andmap (lambda (x)
|
|
(and (pair? x) (pair? (cdr x)) (null? (cddr x))))
|
|
prefs))
|
|
prefs
|
|
null))))
|
|
(let ([f (and (not flush?) (not filename) (weak-box-value pref-box))])
|
|
(or f (let ([f (read-prefs)])
|
|
(unless filename (set! pref-box (make-weak-box f)))
|
|
f))))
|
|
|
|
(define/kw (get-preference name #:optional [fail-thunk (lambda () #f)]
|
|
[refresh-cache? #t]
|
|
filename)
|
|
(unless (symbol? name)
|
|
(raise-type-error 'get-preference "symbol" name))
|
|
(unless (and (procedure? fail-thunk)
|
|
(procedure-arity-includes? fail-thunk 0))
|
|
(raise-type-error 'get-preference "procedure (arity 0)" fail-thunk))
|
|
(let ([f (get-prefs refresh-cache? filename)])
|
|
(let ([m (assq name f)])
|
|
(if m (cadr m) (fail-thunk)))))
|
|
|
|
(define/kw (put-preferences names vals #:optional lock-there filename)
|
|
(unless (and (list? names) (andmap symbol? names))
|
|
(raise-type-error 'put-preferences "list of symbols" names))
|
|
(unless (list? vals)
|
|
(raise-type-error 'put-preferences "list" vals))
|
|
(unless (= (length names) (length vals))
|
|
(raise-mismatch-error
|
|
'put-preferences
|
|
(format "the size of the name list (~a) does not match the size of the value list (~a): "
|
|
(length names) (length vals))
|
|
vals))
|
|
(let-values ([(pref-file lock-file pref-dir)
|
|
(let ([filename (or filename (find-system-path 'pref-file))])
|
|
(let-values ([(base name dir?) (split-path filename)])
|
|
(let ([dir (if (symbol? base)
|
|
(current-directory)
|
|
base)])
|
|
(unless (directory-exists? dir)
|
|
(make-directory* dir))
|
|
(values
|
|
filename
|
|
(build-path dir
|
|
(bytes->path-element
|
|
(bytes-append
|
|
(if (eq? 'windows (system-type))
|
|
#"_"
|
|
#".")
|
|
#"LOCK"
|
|
(path-element->bytes name))))
|
|
dir))))])
|
|
(with-handlers ([exn:fail:filesystem:exists?
|
|
(lambda (x)
|
|
(if lock-there
|
|
(lock-there lock-file)
|
|
(error 'put-preferences
|
|
"some other process has the preference-file lock, as indicated by the existence of the lock file: ~e"
|
|
lock-file)))])
|
|
;; Grab lock:
|
|
(close-output-port (open-output-file lock-file 'error))
|
|
(dynamic-wind
|
|
void
|
|
(lambda ()
|
|
(let ([f (get-prefs #t filename)])
|
|
(for-each
|
|
(lambda (name val)
|
|
(let ([m (assq name f)])
|
|
(if m
|
|
(set-car! (cdr m) val)
|
|
(set! f (cons (list name val) f)))))
|
|
names vals)
|
|
(unless filename
|
|
(set! pref-box (make-weak-box f)))
|
|
;; To write the file, copy the old one to a temporary name
|
|
;; (preserves permissions, etc), write to the temp file,
|
|
;; then move (atomicly) the temp file to the normal name.
|
|
(let ([tmp-file (make-temporary-file
|
|
"TMPPREF~a"
|
|
(and (file-exists? pref-file) pref-file)
|
|
pref-dir)])
|
|
;; If something goes wrong, try to delete the temp file.
|
|
(with-handlers ([exn:fail? (lambda (exn)
|
|
(with-handlers ([exn:fail:filesystem? void])
|
|
(delete-file tmp-file))
|
|
(raise exn))])
|
|
;; Write to temp file...
|
|
(with-output-to-file tmp-file
|
|
(lambda ()
|
|
(with-pref-params
|
|
(lambda ()
|
|
;; If a pref value turns out to be unreadable, raise
|
|
;; an exception instead of creating a bad pref file.
|
|
(parameterize ([print-unreadable #f])
|
|
;; Poor man's pretty-print: one line per entry.
|
|
(printf "(\n")
|
|
(for-each (lambda (a)
|
|
(if (and (list? (cadr a))
|
|
(< 4 (length (cadr a))))
|
|
(begin
|
|
(printf " (~s\n (\n" (car a))
|
|
(for-each (lambda (i) (printf " ~s\n" i)) (cadr a))
|
|
(printf " ))\n"))
|
|
(printf " ~s\n" a)))
|
|
f)
|
|
(printf ")\n")))))
|
|
'truncate/replace)
|
|
(rename-file-or-directory tmp-file pref-file #t)))))
|
|
(lambda ()
|
|
;; Release lock:
|
|
(delete-file lock-file))))))
|
|
|
|
(define call-with-input-file*
|
|
(lambda (file thunk . flags)
|
|
(let ([p (apply open-input-file file flags)])
|
|
(dynamic-wind
|
|
void
|
|
(lambda () (thunk p))
|
|
(lambda () (close-input-port p))))))
|
|
|
|
(define call-with-output-file*
|
|
(lambda (file thunk . flags)
|
|
(let ([p (apply open-output-file file flags)])
|
|
(dynamic-wind
|
|
void
|
|
(lambda () (thunk p))
|
|
(lambda () (close-output-port p))))))
|
|
|
|
;; fold-files : (pathname sym alpha -> alpha) alpha pathname/#f -> alpha
|
|
(define/kw (fold-files f init #:optional [path #f] [follow-links? #t])
|
|
(define (do-path path acc)
|
|
(cond [(and (not follow-links?) (link-exists? path)) (f path 'link acc)]
|
|
[(directory-exists? path)
|
|
(call-with-values (lambda () (f path 'dir acc))
|
|
(letrec ([descend
|
|
(case-lambda
|
|
[(acc)
|
|
(do-paths (map (lambda (p) (build-path path p))
|
|
(sort
|
|
(directory-list path) void))
|
|
acc)]
|
|
[(acc descend?)
|
|
(if descend? (descend acc) acc)])])
|
|
descend))]
|
|
[(file-exists? path) (f path 'file acc)]
|
|
[(link-exists? path) (f path 'link acc)] ; dangling links
|
|
[else (error 'fold-files "path disappeared: ~e" path)]))
|
|
(define (do-paths paths acc)
|
|
(cond [(null? paths) acc]
|
|
[else (do-paths (cdr paths) (do-path (car paths) acc))]))
|
|
(if path (do-path path init) (do-paths (directory-list) init)))
|
|
|
|
(define/kw (find-files f #:optional [path #f])
|
|
(reverse!
|
|
(fold-files (lambda (path kind acc) (if (f path) (cons path acc) acc))
|
|
null path)))
|
|
|
|
(define (pathlist-closure paths)
|
|
(let loop ([paths (map (lambda (p) (simplify-path (resolve-path p) #f))
|
|
paths)]
|
|
[r '()])
|
|
(if (null? paths)
|
|
(reverse! r)
|
|
(let loop2 ([path (car paths)]
|
|
[new (cond [(file-exists? (car paths))
|
|
(list (car paths))]
|
|
[(directory-exists? (car paths))
|
|
(find-files void (car paths))]
|
|
[else (error 'pathlist-closure
|
|
"file/directory not found: ~a"
|
|
(car paths))])])
|
|
(let-values ([(base name dir?) (split-path path)])
|
|
(if (path? base)
|
|
(loop2 base (if (or (member base r) (member base paths))
|
|
new (cons base new)))
|
|
(loop (cdr paths) (append! (reverse! new) r))))))))
|
|
|
|
)
|