From 97c30012ed709d895e6c34797f4f240146cceebb Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Thu, 28 Sep 2006 16:13:32 +0000 Subject: [PATCH] Mainly reformatting and using kw.ss instead of opt-lambda and case-lambda svn: r4453 --- collects/mzlib/file.ss | 470 +++++++++++++++++++---------------------- 1 file changed, 218 insertions(+), 252 deletions(-) diff --git a/collects/mzlib/file.ss b/collects/mzlib/file.ss index ebd10ada6a..d8583d0bc4 100644 --- a/collects/mzlib/file.ss +++ b/collects/mzlib/file.ss @@ -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))