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

some code reformatting

Browse Source 
svn: r6929
This commit is contained in:
Eli Barzilay 2007-07-17 09:16:30 +00:00
parent 062da57e00
commit e198aa3c29
1 changed files with 104 additions and 116 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

220
collects/mzlib/file.ss
View File

@ -25,17 +25,15 @@
(require "list.ss" "kw.ss") (require "list.ss" "kw.ss")
(define build-relative-path (define (build-relative-path p . args)
(lambda (p . args) (if (relative-path? p)
(if (relative-path? p) (apply build-path p args)
(apply build-path p args) (error 'build-relative-path "base path ~s is absolute" p)))
(error 'build-relative-path "base path ~s is absolute" p))))
(define build-absolute-path (define (build-absolute-path p . args)
(lambda (p . args) (if (relative-path? p)
(if (relative-path? p) (error 'build-absolute-path "base path ~s is relative" p)
(error 'build-absolute-path "base path ~s is relative" p) (apply build-path p args)))
(apply build-path p args))))
;; Note that normalize-path does not normalize the case ;; Note that normalize-path does not normalize the case
(define normalize-path (define normalize-path
@ -87,13 +85,13 @@
(let normalize ([path (expand-path orig-path)]) (let normalize ([path (expand-path orig-path)])
(let-values ([(base name dir?) (split-path path)]) (let-values ([(base name dir?) (split-path path)])
(cond (cond
[(eq? name 'up) [(eq? name 'up)
(let up ([base (if (eq? base 'relative) (let up ([base (if (eq? base 'relative)
wrt wrt
(resolve-all base wrt))]) (resolve-all base wrt))])
(if (directory-exists? base) (if (directory-exists? base)
(let-values ([(prev name dir?) (split-path base)]) (let-values ([(prev name dir?) (split-path base)])
(cond (cond
[(not prev) [(not prev)
(error 'normalize-path (error 'normalize-path
"root has no parent directory: ~s" "root has no parent directory: ~s"
@ -101,75 +99,67 @@
[else [else
(let ([prev (let ([prev
(if (eq? prev 'relative) (if (eq? prev 'relative)
wrt wrt
(normalize prev))]) (normalize prev))])
(cond (cond
[(eq? name 'same) (up prev)] [(eq? name 'same) (up prev)]
[(eq? name 'up) (up (up prev))] [(eq? name 'up) (up (up prev))]
[else prev]))])) [else prev]))]))
(error-not-a-dir base)))] (error-not-a-dir base)))]
[(eq? name 'same) [(eq? name 'same)
(cond (cond
[(eq? base 'relative) wrt] [(eq? base 'relative) wrt]
[else (let ([n (normalize base)]) [else (let ([n (normalize base)])
(if (directory-exists? n) (if (directory-exists? n)
n n
(error-not-a-dir n)))])] (error-not-a-dir n)))])]
[else [(not base) (path->complete-path path)]
(cond [else
[(not base) (path->complete-path path)] (let* ([base (if (eq? base 'relative)
[else (let* ([base (if (eq? base 'relative) (normalize wrt)
(normalize wrt) (normalize base))]
(normalize base))] [path (if (directory-exists? base)
[path (if (directory-exists? base) (build-path base name)
(build-path base name) (error-not-a-dir base))]
(error-not-a-dir base))] [resolved (expand-path (resolve path))])
[resolved (expand-path (resolve path))]) (cond
(cond [(relative-path? resolved)
[(relative-path? resolved) (normalize (build-path base resolved))]
(normalize (build-path base resolved))] [(complete-path? resolved)
[(complete-path? resolved) resolved]
resolved] [else (path->complete-path resolved base)]))]))))])
[else (path->complete-path resolved base)]))])]))))])
normalize-path)) normalize-path))
;; Argument must be in normal form ;; Argument must be in normal form
(define do-explode-path (define (do-explode-path who orig-path)
(lambda (who orig-path) (let loop ([path orig-path][rest '()])
(let loop ([path orig-path][rest '()]) (let-values ([(base name dir?) (split-path path)])
(let-values ([(base name dir?) (split-path path)]) (when (or (and base (not (path? base)))
(when (or (and base (not (path? name)))
(not (path? base))) (raise-type-error who "path in normal form" orig-path))
(not (path? name))) (if base
(raise-type-error who "path in normal form" orig-path)) (loop base (cons name rest))
(if base (cons name rest)))))
(loop base (cons name rest))
(cons name rest))))))
(define explode-path (define (explode-path orig-path)
(lambda (orig-path) (unless (path-string? orig-path)
(unless (path-string? orig-path) (raise-type-error 'explode-path "path or string" orig-path))
(raise-type-error 'explode-path "path or string" orig-path)) (do-explode-path 'explode-path orig-path))
(do-explode-path 'explode-path orig-path)))
;; Arguments must be in normal form ;; Arguments must be in normal form
(define find-relative-path (define (find-relative-path directory filename)
(lambda (directory filename) (let ([dir (do-explode-path 'find-relative-path directory)]
(let ([dir (do-explode-path 'find-relative-path directory)] [file (do-explode-path 'find-relative-path filename)])
[file (do-explode-path 'find-relative-path filename)]) (if (equal? (car dir) (car file))
(if (equal? (car dir) (car file)) (let loop ([dir (cdr dir)]
(let loop ([dir (cdr dir)] [file (cdr file)])
[file (cdr file)]) (cond [(null? dir) (if (null? file) filename (apply build-path file))]
(cond [(null? file) (apply build-path (map (lambda (x) 'up) dir))]
[(null? dir) (if (null? file) filename (apply build-path file))] [(equal? (car dir) (car file))
[(null? file) (apply build-path (map (lambda (x) 'up) dir))] (loop (cdr dir) (cdr file))]
[(equal? (car dir) (car file)) [else
(loop (cdr dir) (cdr file))] (apply build-path (append (map (lambda (x) 'up) dir) file))]))
[else filename)))
(apply build-path
(append (map (lambda (x) 'up) dir)
file))]))
filename))))
(define (file-name who name) (define (file-name who name)
(unless (path-string? name) (unless (path-string? name)
@ -199,28 +189,29 @@
(unless (path-string? path) (unless (path-string? path)
(raise-type-error 'delete-directory/files "path or string" path)) (raise-type-error 'delete-directory/files "path or string" path))
(cond (cond
[(or (link-exists? path) (file-exists? path)) [(or (link-exists? path) (file-exists? path))
(delete-file path)] (delete-file path)]
[(directory-exists? path) [(directory-exists? path)
(for-each (lambda (e) (delete-directory/files (build-path path e))) (for-each (lambda (e) (delete-directory/files (build-path path e)))
(directory-list path)) (directory-list path))
(delete-directory path)] (delete-directory path)]
[else (error 'delete-directory/files [else (error 'delete-directory/files
"encountered ~a, neither a file nor a directory" "encountered ~a, neither a file nor a directory"
path)])) path)]))
(define (copy-directory/files src dest) (define (copy-directory/files src dest)
(cond (cond
[(file-exists? src) [(file-exists? src)
(copy-file src dest)] (copy-file src dest)]
[(directory-exists? src) [(directory-exists? src)
(make-directory dest) (make-directory dest)
(for-each (lambda (e) (copy-directory/files (build-path src e) (for-each (lambda (e)
(build-path dest e))) (copy-directory/files (build-path src e)
(directory-list src))] (build-path dest e)))
[else (error 'copy-directory/files (directory-list src))]
"encountered ~a, neither a file nor a directory" [else (error 'copy-directory/files
src)])) "encountered ~a, neither a file nor a directory"
src)]))
(define (make-directory* dir) (define (make-directory* dir)
(let-values ([(base name dir?) (split-path dir)]) (let-values ([(base name dir?) (split-path dir)])
@ -251,10 +242,9 @@
(let ([tmpdir (find-system-path 'temp-dir)]) (let ([tmpdir (find-system-path 'temp-dir)])
(let loop ([s (current-seconds)][ms (current-milliseconds)]) (let loop ([s (current-seconds)][ms (current-milliseconds)])
(let ([name (let ([n (format template (format "~a~a" s ms))]) (let ([name (let ([n (format template (format "~a~a" s ms))])
(cond (cond [base-dir (build-path base-dir n)]
[base-dir (build-path base-dir n)] [(relative-path? n) (build-path tmpdir n)]
[(relative-path? n) (build-path tmpdir n)] [else n]))])
[else n]))])
(with-handlers ([exn:fail:filesystem:exists? (with-handlers ([exn:fail:filesystem:exists?
(lambda (x) (lambda (x)
;; try again with a new name ;; try again with a new name
@ -459,21 +449,19 @@
;; Release lock: ;; Release lock:
(delete-file lock-file)))))) (delete-file lock-file))))))
(define call-with-input-file* (define (call-with-input-file* file thunk . flags)
(lambda (file thunk . flags) (let ([p (apply open-input-file file flags)])
(let ([p (apply open-input-file file flags)]) (dynamic-wind
(dynamic-wind void
void (lambda () (thunk p))
(lambda () (thunk p)) (lambda () (close-input-port p)))))
(lambda () (close-input-port p))))))
(define call-with-output-file* (define (call-with-output-file* file thunk . flags)
(lambda (file thunk . flags) (let ([p (apply open-output-file file flags)])
(let ([p (apply open-output-file file flags)]) (dynamic-wind
(dynamic-wind void
void (lambda () (thunk p))
(lambda () (thunk p)) (lambda () (close-output-port p)))))
(lambda () (close-output-port p))))))
;; fold-files : (pathname sym alpha -> alpha) alpha pathname/#f -> alpha ;; fold-files : (pathname sym alpha -> alpha) alpha pathname/#f -> alpha
(define/kw (fold-files f init #:optional [path #f] [follow-links? #t]) (define/kw (fold-files f init #:optional [path #f] [follow-links? #t])