suzanne.soy/compatibility
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

.

Browse Source 
original commit: c908ad91ac598d1628498cdc309b1e41dc4cf648
This commit is contained in:
Matthew Flatt 2002-01-05 13:43:10 +00:00
parent f0e15a15e3
commit f1f4edcc95
1 changed files with 65 additions and 31 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

74
collects/mzlib/file.ss
View File

@ -256,13 +256,33 @@
#f))
#f))]))
(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)
(print-struct #f)
(print-graph #t)
(print-box #t)
(print-vector-length #t))
(thunk)))
(define pref-box (make-weak-box #f)) ; non-weak box => need to save
(define (get-prefs flush?)
(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 ([not-break-exn? (lambda (x) null)])
(let ([pref-file (let ([f (find-system-path 'pref-file)])
(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
@ -270,9 +290,11 @@
f
;; Error here bails out through above `with-handlers'
(build-path (collection-path "defaults")
"plt-prefs.ss")))])
"plt-prefs.ss"))))])
(with-pref-params
(lambda ()
(with-input-from-file pref-file
read)))])
read)))))])
;; Make sure file content had the right shape:
(if (and (list? v)
(andmap (lambda (x)
@ -282,12 +304,13 @@
v))
v
null))])
(set! pref-box (make-weak-box f))
(unless filename
(set! pref-box (make-weak-box f)))
f))))
(define get-preference
(case-lambda
[(name fail-thunk refresh-cache?)
[(name fail-thunk refresh-cache? filename)
(unless (symbol? name)
(raise-type-error
'get-preference
@ -299,17 +322,18 @@
'get-preference
"procedure (arity 0)"
fail-thunk))
(let ([f (get-prefs refresh-cache?)])
(let ([f (get-prefs refresh-cache? filename)])
(let ([m (assq name f)])
(if m
(cadr m)
(fail-thunk))))]
[(name fail-thunk) (get-preference name fail-thunk #t)]
[(name) (get-preference name (lambda () #f) #t)]))
[(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 put-preferences
(case-lambda
[(names vals lock-there)
[(names vals lock-there filename)
(unless (and (list? names)
(andmap symbol? names))
(raise-type-error
@ -327,7 +351,15 @@
(format "the size of the name list (~a) does not match the size of the value list (~a): "
(length names) (length vals))
vals))
(let ([lock-file (build-path (find-system-path 'pref-dir) ".plt-PREFLOCK")])
(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)])
(values filename
(build-path dir (format ".LOCK~a" name))
dir))))])
(with-handlers ([(lambda (x)
(and (exn:i/o:filesystem? x)
(eq? (exn:i/o:filesystem-detail x) 'already-exists)))
@ -338,7 +370,7 @@
(dynamic-wind
void
(lambda ()
(let ([f (get-prefs #t)])
(let ([f (get-prefs #t filename)])
(for-each
(lambda (name val)
(let ([m (assq name f)])
@ -346,27 +378,29 @@
(set-car! (cdr m) val)
(set! f (cons (list name val) f)))))
names vals)
(set! pref-box (make-weak-box f))
(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 (atomically) the temp file to the normal name.
(let* ([pref-file (find-system-path 'pref-file)]
[tmp-file (make-temporary-file
(build-path (find-system-path 'pref-dir) "TMPPREF~a")
;; then move (atomicly) the temp file to the normal name.
(let* ([tmp-file (make-temporary-file
(build-path pref-dir "TMPPREF~a")
(and (file-exists? pref-file) pref-file))])
(with-output-to-file tmp-file
(lambda ()
(parameterize ([read-case-sensitive #f]
[print-struct #f])
(with-pref-params
(lambda ()
;; Poor man's pretty-print: one line per entry
(printf "(~n")
(for-each (lambda (a) (printf " ~s~n" a)) f)
(printf ")~n")))
(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