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

pathlist-closure, tar, and tar-gzip: add #:path-filter

Browse Source 
Also, add `#:skip-filtered-directory?` to `find-files`.

Less significantly, adjust `pathlist-closure` to be consistent in the
way that it includes a separator at the end of a directory path.
This commit is contained in:
Matthew Flatt 2016-01-01 12:44:18 -07:00
parent c9a1dc781e
commit c0915b02b0
6 changed files with 214 additions and 27 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

8
pkgs/racket-doc/file/scribblings/tar.scrbl
View File

@ -20,6 +20,7 @@ in a link must be less than 100 bytes.}
[#:follow-links? follow-links? any/c #f]
[#:exists-ok? exists-ok? any/c #f]
[#:path-prefix path-prefix (or/c #f path-string?) #f]
[#:path-filter path-filter (or/c #f (path? . -> . any/c)) #f]
[#:get-timestamp get-timestamp
(path? . -> . exact-integer?)
(if timestamp
@ -48,13 +49,15 @@ date to record in the archive for each file or directory.
@history[#:changed "6.0.0.3" @elem{Added the @racket[#:get-timestamp] argument.}
#:changed "6.1.1.1" @elem{Added the @racket[#:exists-ok?] argument.}
#:changed "6.3.0.3" @elem{Added the @racket[#:follow-links?] argument.}]}
#:changed "6.3.0.3" @elem{Added the @racket[#:follow-links?] argument.}
#:changed "6.3.0.11" @elem{Added the @racket[#:path-filter] argument.}]}
@defproc[(tar->output [paths (listof path?)]
[out output-port? (current-output-port)]
[#:follow-links? follow-links? any/c #f]
[#:path-prefix path-prefix (or/c #f path-string?) #f]
[#:path-filter path-filter (or/c #f (path? . -> . any/c)) #f]
[#:get-timestamp get-timestamp
(path? . -> . exact-integer?)
(if timestamp
@ -69,7 +72,8 @@ content is not automatically added, and nested directories are added
without parent directories.
@history[#:changed "6.0.0.3" @elem{Added the @racket[#:get-timestamp] argument.}
#:changed "6.3.0.3" @elem{Added the @racket[#:follow-links?] argument.}]}
#:changed "6.3.0.3" @elem{Added the @racket[#:follow-links?] argument.}
#:changed "6.3.0.11" @elem{Added the @racket[#:path-filter] argument.}]}
@defproc[(tar-gzip [tar-file path-string?]

30
pkgs/racket-doc/scribblings/reference/filesystem.scrbl
View File

@ -979,6 +979,7 @@ exists and is removed by another thread or process before
@defproc[(find-files [predicate (path? . -> . any/c)]
[start-path (or/c path-string? #f) #f]
[#:skip-filtered-directory? skip-filtered-directory? #f]
[#:follow-links? follow-links? #f])
(listof path?)]{
@ -999,6 +1000,10 @@ paths in the former case and relative paths in the latter. Another
difference is that @racket[predicate] is not called for the current
directory when @racket[start-path] is @racket[#f].
If @racket[skip-filtered-directory?] is true, then when
@racket[predicate] returns @racket[#f] for a directory, the
directory's content is not traversed.
If @racket[follow-links?] is true, the @racket[find-files] traversal
follows links, and links are not included in the result. If
@racket[follow-links?] is @racket[#f], then links are not followed,
@ -1009,10 +1014,15 @@ directory, then @racket[predicate] will be called exactly once with
@racket[start-path] as the argument.
The @racket[find-files] procedure raises an exception if it encounters
a directory for which @racket[directory-list] fails.}
a directory for which @racket[directory-list] fails.
@history[#:changed "6.3.0.11" @elem{Added the
@racket[#:skip-filtered-directory?]
argument.}]}
@defproc[(pathlist-closure [path-list (listof path-string?)]
[#:follow-links? follow-links? #f])
[#:path-filter path-filter (or/c #f (path? . -> . any/c)) #f]
[#:follow-links? follow-links? any/c #f])
(listof path?)]{
Given a list of paths, either absolute or relative to the current
@ -1025,17 +1035,25 @@ directory, returns a list such that
twice);}
@item{if a path refers to directory, all of its descendants are also
included in the result;}
included in the result, except as omitted by @racket[path-filter];}
@item{ancestor directories appear before their descendants in the
result list.}
result list, as long as they are not misordered in the given
@racket[path-list].}
]
If @racket[path-filter] is a procedure, then it is applied to each
descendant of a directory. If @racket[path-filter] returns
@racket[#f], then the descendant (and any of its descendants, in the
case of a subdirectory) are omitted from the result.
If @racket[follow-links?] is true, then the traversal of directories
and files follows links, and the link paths are not included in the
result. If @racket[follow-links?] is @racket[#f], then he result list
includes paths to link and the links are not followed.}
result. If @racket[follow-links?] is @racket[#f], then the result list
includes paths to link and the links are not followed.
@history[#:changed "6.3.0.11" @elem{Added the @racket[#:path-filter] argument.}]}
@defproc[(fold-files [proc (or/c (path? (or/c 'file 'dir 'link) any/c

126
pkgs/racket-test-core/tests/racket/filelib.rktl
View File

@ -223,4 +223,130 @@
;; ----------------------------------------
(let ([dir (make-temporary-file "pathlist~a" 'directory)])
(define parents
(let loop ([dir dir])
(define-values (base name dir?) (split-path dir))
(if (path? base)
(append (loop base) (list (path->directory-path dir)))
(list dir))))
(define (p . args)
(maybe-as-directory
args
(apply build-path dir args)))
(define (maybe-as-directory args p)
(if (regexp-match? #rx"^d" (last args))
(path->directory-path p)
p))
(define (touch f)
(call-with-output-file* f void))
(touch (p "f1"))
(make-directory (p "d1"))
(make-directory (p "d2"))
(touch (p "d1" "f1"))
(touch (p "d2" "f1"))
(touch (p "d2" "f2"))
(unless (eq? 'windows (system-type))
(make-file-or-directory-link "d1" (p "l3"))
(make-file-or-directory-link "l3" (p "l4"))
(make-directory (p "d5"))
(make-file-or-directory-link (build-path 'up "d2" "f1") (p "d5" "l5")))
(make-directory (p "d6"))
(touch (p "d6" "f1"))
(make-directory (p "d6" "d7"))
(touch (p "d6" "d7" "f1"))
(touch (p "d6" "d7" "f2"))
(define (check p parents)
(test (append
parents
(list (p "d1")
(p "d1" "f1")))
pathlist-closure
(list (p "d1")))
(test (append
parents
(list (p "d1")
(p "d1" "f1")
(p "f1")))
pathlist-closure
(list (p "d1")
(p "f1")))
(test (append
parents
(list (p "d1")
(p "d2")
(p "d2" "f2")))
pathlist-closure
(list (p "d1")
(p "d2"))
#:path-filter (lambda (f) (not (regexp-match? #rx"f1$" f))))
(test (append
parents
(list (p "d1")
(p "d1" "f1")
(p "d2")
(p "d2" "f2")))
pathlist-closure
(list (p "d1")
(p "d1" "f1")
(p "d2"))
#:path-filter (lambda (f) (not (regexp-match? #rx"f1$" f))))
(test (append
parents
(list (p "d6")
(p "d6" "f1")))
pathlist-closure
(list (p "d6"))
#:path-filter (lambda (f) (not (regexp-match? #rx"d7$" f))))
(unless (eq? 'windows (system-type))
(test (append
parents
(list (p "l3")))
pathlist-closure
(list (p "l3")))
(test (append
parents
(list (p "l4")))
pathlist-closure
(list (p "l4")))
(test (append
parents
(list (p "d5")
(p "d5" "l5")))
pathlist-closure
(list (p "d5" "l5")))
(test (append
parents
(list (p "d1")
(p "d1" "f1")))
pathlist-closure
(list (p "l3"))
#:follow-links? #t)
(test (append
parents
(list (p "d1")
(p "d1" "f1")))
pathlist-closure
(list (p "l4"))
#:follow-links? #t)
(test (append
parents
(list (p "d2")
(p "d2" "f1")))
pathlist-closure
(list (p "d5" "l5"))
#:follow-links? #t)))
(parameterize ([current-directory dir])
(check (lambda args (maybe-as-directory args (apply build-path args))) null))
(check p parents)
(delete-directory/files dir))
;; ----------------------------------------
(report-errs)

26
pkgs/racket-test/tests/file/packers.rkt
View File

@ -49,7 +49,9 @@
(and (directory-exists? dest)
(compare-attributes src dest)
(let* ([sort-paths (λ (l) (sort l bytes<? #:key path->bytes))]
[srcs (sort-paths (directory-list src))]
[srcs (sort-paths (for/list ([p (in-list (directory-list src))]
#:unless (regexp-match? #rx"skip" p))
p))]
[dests (sort-paths (directory-list dest))])
(and (equal? srcs dests)
(for/and ([src-item (in-list srcs)]
@ -64,7 +66,8 @@
(define (zip-tests zip unzip timestamps?
#:dir-name [ex1 "ex1"]
#:file-name [f2 "f2"]
#:links? [links? #f])
#:links? [links? #f]
#:filter-path? [filter-path? #f])
(make-directory* ex1)
(make-file (build-path ex1 "f1"))
(make-file (build-path ex1 f2))
@ -76,6 +79,10 @@
(make-file-or-directory-link "f1" (build-path ex1 "f1-link"))
(make-file-or-directory-link "more" (build-path ex1 "more-link"))
(make-file-or-directory-link "no" (build-path ex1 "no-link")))
(when filter-path?
(make-file (build-path ex1 "skip1"))
(make-directory (build-path ex1 "skip2"))
(make-file (build-path ex1 "skip2" "nope")))
(zip "a.zip" ex1)
(when timestamps? (sleep 3)) ; at least 2 seconds, plus 1 to likely change parity
@ -116,11 +123,20 @@
(zip-tests zip unzip #f)
(zip-tests (make-zip #f) (make-unzip #f) 'file)
(zip-tests (make-zip #t) (make-unzip #t) 'file)
(zip-tests tar untar #t #:links? #t)
(zip-tests tar untar #t #:links? (not (eq? 'windows (system-type))))
(zip-tests tar untar #t
#:links? #t
#:links? (not (eq? 'windows (system-type)))
#:dir-name (make-string 64 #\d)
#:file-name (make-string 64 #\f)))
#:file-name (make-string 64 #\f))
(zip-tests (lambda (#:path-prefix [prefix #f] . args)
(apply
tar
args
#:path-prefix prefix
#:path-filter (lambda (p)
(define-values (base name dir?) (split-path p))
(not (regexp-match? #rx"skip" name)))))
untar #t #:filter-path? #t))
(delete-directory/files work-dir)

11
racket/collects/file/tar.rkt
View File

@ -152,13 +152,16 @@
(define (tar tar-file
#:exists-ok? [exists-ok? #f]
#:path-prefix [prefix #f]
#:path-filter [path-filter #f]
#:follow-links? [follow-links? #f]
#:get-timestamp [get-timestamp file-or-directory-modify-seconds]
. paths)
(when (null? paths) (error 'tar "no paths specified"))
(with-output-to-file tar-file
#:exists (if exists-ok? 'truncate/replace 'error)
(lambda () (tar->output (pathlist-closure paths #:follow-links? follow-links?)
(lambda () (tar->output (pathlist-closure paths
#:follow-links? follow-links?
#:path-filter path-filter)
#:get-timestamp get-timestamp
#:path-prefix prefix
#:follow-links? follow-links?))))
@ -168,6 +171,7 @@
(define (tar-gzip tgz-file
#:exists-ok? [exists-ok? #f]
#:path-prefix [prefix #f]
#:path-filter [path-filter #f]
#:follow-links? [follow-links? #f]
#:get-timestamp [get-timestamp file-or-directory-modify-seconds]
. paths)
@ -177,7 +181,10 @@
(lambda ()
(let-values ([(i o) (make-pipe (* 1024 1024 32))])
(thread (lambda ()
(tar->output (pathlist-closure paths #:follow-links? follow-links?) o
(tar->output (pathlist-closure paths
#:follow-links? follow-links?
#:path-filter path-filter)
o
#:path-prefix prefix
#:follow-links? follow-links?
#:get-timestamp get-timestamp)

40
racket/collects/racket/file.rkt
View File

@ -639,24 +639,37 @@
(define (to-path s) (if (path? s) s (string->path s)))
(if path (do-path (to-path path) init) (do-paths (directory-list) init)))
(define (find-files f [path #f] #:follow-links? [follow-links? #t])
(define (find-files f [path #f]
#:follow-links? [follow-links? #t]
#:skip-filtered-directory? [skip-filtered-directory? #f])
(reverse
(fold-files (lambda (path kind acc) (if (f path) (cons path acc) acc))
(fold-files (lambda (path kind acc) (if (f path)
(cons path acc)
(if (and skip-filtered-directory?
(eq? kind 'dir))
(values acc #f)
acc)))
null path
follow-links?)))
(define (pathlist-closure paths #:follow-links? [follow-links? #f])
(define (pathlist-closure paths
#:follow-links? [follow-links? #f]
#:path-filter [path-filter #f])
(let loop ([paths
(map (lambda (p)
(simplify-path
(if (and follow-links?
(link-exists? p))
(let ([p2 (resolve-path p)])
(if (relative-path? p2)
(let-values ([(base name dir?) (split-path p)])
(build-path base p2))
p2))
p)
(let loop ([p p])
(if (and follow-links?
(link-exists? p))
(let ([p2 (resolve-path p)])
(if (relative-path? p2)
(let-values ([(base name dir?) (split-path p)])
(loop ((if dir? path->directory-path values)
(if (path? base)
(build-path base p2)
p2))))
(loop p2)))
p))
#f))
paths)]
[r '()])
@ -669,7 +682,10 @@
[(file-exists? (car paths))
(list (car paths))]
[(directory-exists? (car paths))
(find-files void (car paths) #:follow-links? follow-links?)]
(find-files (or path-filter void)
(path->directory-path (car paths))
#:skip-filtered-directory? #t
#:follow-links? follow-links?)]
[else (error 'pathlist-closure
"file/directory not found: ~a"
(car paths))])])