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

added pathlist-closure to file.ss

Browse Source 
svn: r3160
This commit is contained in:
Eli Barzilay 2006-05-31 20:55:21 +00:00
parent ce0c03c60f
commit 436c36cc1e
2 changed files with 26 additions and 18 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

26
collects/mzlib/file.ss
View File

@ -20,7 +20,8 @@
call-with-output-file*
fold-files
find-files)
find-files
pathlist-closure)
(require "list.ss"
"etc.ss")
@ -496,4 +497,25 @@
(reverse! (fold-files (lambda (path kind acc)
(if (f path) (cons path acc) acc))
null
path)))))
path))))
(define (pathlist-closure paths)
(let loop ([paths (map (lambda (p) (simplify-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))))))))
)

18
collects/mzlib/zip.ss
View File

@ -262,21 +262,7 @@
(provide zip)
(define (zip zip-file . paths)
(when (null? paths) (error 'zip "no paths specified"))
(let loop ([paths (map (lambda (p) (simplify-path p #f)) paths)]
[r '()])
(if (null? paths)
(with-output-to-file zip-file (lambda () (zip->output (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 'zip "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))))))))
(with-output-to-file zip-file
(lambda () (zip->output (pathlist-closure paths)))))
)