Mainly reformatting and using kw.ss instead of opt-lambda and case-lambda
svn: r4453
This commit is contained in:
Eli Barzilay
parent
6210b79f2b
commit
97c30012ed
|
|
@ -23,8 +23,7 @@
|
|||
find-files
|
||||
pathlist-closure)
|
||||
|
||||
(require "list.ss"
|
||||
"etc.ss")
|
||||
(require "list.ss" "kw.ss")
|
||||
|
||||
(define build-relative-path
|
||||
(lambda (p . args)
|
||||
|
|
@ -72,15 +71,15 @@
|
|||
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)])]
|
||||
(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
|
||||
(error 'normalize-path
|
||||
"~s (within the input path) is not a directory or does not exist"
|
||||
path))]
|
||||
[do-normalize-path
|
||||
|
|
@ -231,230 +230,199 @@
|
|||
(unless (directory-exists? dir)
|
||||
(make-directory dir))))
|
||||
|
||||
(define make-temporary-file
|
||||
(case-lambda
|
||||
[(template 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))))]
|
||||
[(template copy-from) (make-temporary-file template copy-from #f)]
|
||||
[(template) (make-temporary-file template #f #f)]
|
||||
[() (make-temporary-file "mztmp~a" #f #f)]))
|
||||
|
||||
(define find-library
|
||||
(case-lambda
|
||||
[(name) (find-library name "mzlib")]
|
||||
[(name collection . cp)
|
||||
(let ([dir (with-handlers ([exn:fail:filesystem? (lambda (exn) #f)])
|
||||
(apply collection-path collection cp))])
|
||||
(if dir
|
||||
(let ([file (build-path dir name)])
|
||||
(if (file-exists? file)
|
||||
file
|
||||
#f))
|
||||
#f))]))
|
||||
(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))
|
||||
(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)
|
||||
(let ([f (and (not flush?)
|
||||
(not filename)
|
||||
(weak-box-value pref-box))])
|
||||
(or f
|
||||
(let ([f (let ([v (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"))))])
|
||||
(with-pref-params
|
||||
(lambda ()
|
||||
(with-input-from-file pref-file
|
||||
read)))))])
|
||||
;; Make sure file content had the right shape:
|
||||
(if (and (list? v)
|
||||
(andmap (lambda (x)
|
||||
(and (pair? x)
|
||||
(pair? (cdr x))
|
||||
(null? (cddr x))))
|
||||
v))
|
||||
v
|
||||
null))])
|
||||
(unless filename
|
||||
(set! pref-box (make-weak-box f)))
|
||||
f))))
|
||||
(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 get-preference
|
||||
(case-lambda
|
||||
[(name fail-thunk refresh-cache? 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))))]
|
||||
[(name fail-thunk refresh-cache?) (get-preference name fail-thunk refresh-cache? #f)]
|
||||
[(name fail-thunk) (get-preference name fail-thunk #t #f)]
|
||||
[(name) (get-preference name (lambda () #f) #t #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 put-preferences
|
||||
(case-lambda
|
||||
[(names vals 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
|
||||
(bytes-append
|
||||
(if (eq? 'windows (system-type))
|
||||
#"_"
|
||||
#".")
|
||||
#"LOCK"
|
||||
(path->bytes name))))
|
||||
dir))))])
|
||||
(with-handlers ([exn:fail:filesystem:exists?
|
||||
(lambda (x)
|
||||
(lock-there 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 (list? (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)))))]
|
||||
[(names vals lock-there)
|
||||
(put-preferences names vals lock-there #f)]
|
||||
[(names vals)
|
||||
(put-preferences
|
||||
names vals
|
||||
(lambda (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)))]))
|
||||
(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
|
||||
(bytes-append
|
||||
(if (eq? 'windows (system-type))
|
||||
#"_"
|
||||
#".")
|
||||
#"LOCK"
|
||||
(path->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)
|
||||
|
|
@ -473,35 +441,33 @@
|
|||
(lambda () (close-output-port p))))))
|
||||
|
||||
;; fold-files : (pathname sym alpha -> alpha) alpha pathname/#f -> alpha
|
||||
(define fold-files
|
||||
(opt-lambda (f init [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 (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 find-files
|
||||
(opt-lambda (f [path #f])
|
||||
(reverse!
|
||||
(fold-files (lambda (path kind acc) (if (f path) (cons path acc) acc))
|
||||
null path))))
|
||||
(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))
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user