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

zip: add #:path-prefix argument

Browse Source
This commit is contained in:
Matthew Flatt 2014-06-04 13:16:58 +01:00
parent 8792c52e1d
commit 374742e905
3 changed files with 148 additions and 19 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

18
pkgs/racket-pkgs/racket-doc/file/scribblings/zip.scrbl
View File

@ -15,6 +15,7 @@ compression is implemented by @racket[deflate].}
(if timestamp
(lambda (p) timestamp)
file-or-directory-modify-seconds)]
[#:path-prefix path-prefix (or/c #f path-string?) #f]
[#:system-type sys-type symbol? (system-type)])
void?]{
@ -39,8 +40,15 @@ The @racket[get-timestamp] function is used to obtain the modification
date to record in the archive for a file or directory, while
@racket[sys-type] determines the system type recorded in the archive.
If @racket[path-prefix] is not @racket[#f], then it prefixes the name
of each path as it is written in the @exec{zip} file, and directory
entries are added for each element of @racket[path-prefix].
@history[#:changed "6.0.0.3"
@elem{Added the @racket[#:get-timestamp] and @racket[#:system-type] arguments.}]}
@elem{Added the @racket[#:get-timestamp] and @racket[#:system-type] arguments.}
#:changed "6.0.1.12"
@elem{Added the @racket[#:path-prefix] argument.}]}
@defproc[(zip->output [paths (listof path-string?)]
@ -51,17 +59,21 @@ date to record in the archive for a file or directory, while
(if timestamp
(lambda (p) timestamp)
file-or-directory-modify-seconds)]
[#:path-prefix path-prefix (or/c #f path-string?) #f]
[#:system-type sys-type symbol? (system-type)])
void?]{
Zips each of the given @racket[paths], and packages it as a zip
``file'' that is written directly to @racket[out]. Unlike
@racket[zip], the specified @racket[paths] are included as-is; if a
@racket[zip], the specified @racket[paths] are included without
closing over directories: if a
directory is specified, its 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] and @racket[#:system-type] arguments.}]}
@elem{Added the @racket[#:get-timestamp] and @racket[#:system-type] arguments.}
#:changed "6.0.1.12"
@elem{Added the @racket[#:path-prefix] argument.}]}
@defboolparam[zip-verbose on?]{

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

@ -0,0 +1,92 @@
#lang racket/base
(require file/tar file/zip
file/untar file/unzip
racket/file racket/system racket/set
tests/eli-tester)
(define (make-file path)
(with-output-to-file path
(lambda ()
(for ([i (in-range (random 1000))])
(write-bytes (make-bytes (random 100) (+ 32 (random 96))))))))
(define (file-or-directory-permissions* path permissions)
(file-or-directory-permissions
path
(for/fold ([n 0]) ([p '(["r" #o400] ["w" #o200] ["x" #o100])])
(if (regexp-match? (car p) permissions) (bitwise-ior n (cadr p)) n))))
(define (diff src dest check-attributes?)
(define (compare-attributes p1 p2)
(or (not check-attributes?)
(and (= (file-or-directory-modify-seconds p1)
(file-or-directory-modify-seconds p2))
(equal? (file-or-directory-permissions p1)
(file-or-directory-permissions p2)))))
(cond
[(link-exists? src)
(and (link-exists? dest)
(diff (resolve-path src) (resolve-path dest) check-attributes?))]
[(file-exists? src)
(and (file-exists? dest)
(= (file-size src) (file-size dest))
(compare-attributes src dest)
(equal? (file->bytes src) (file->bytes dest)))]
[(directory-exists? src)
(and (directory-exists? dest)
(compare-attributes src dest)
(let* ([sort-paths (λ (l) (sort l bytes<? #:key path->bytes))]
[srcs (sort-paths (directory-list src))]
[dests (sort-paths (directory-list dest))])
(and (equal? srcs dests)
(for/and ([src-item (in-list srcs)]
[dest-item (in-list dests)])
(diff (build-path src src-item)
(build-path dest dest-item)
check-attributes?))
;; make dest writable to simplify clean-up:
(begin (file-or-directory-permissions* dest "rwx") #t))))]
[else #t]))
(define (zip-tests zip unzip)
(make-directory* "ex1")
(make-file (build-path "ex1" "f1"))
(make-file (build-path "ex1" "f2"))
(make-file (build-path "ex1" "f3"))
(define more-dir (build-path "ex1" "more"))
(make-directory* more-dir)
(make-file (build-path more-dir "f4"))
(zip "a.zip" "ex1")
(make-directory* "sub")
(parameterize ([current-directory "sub"])
(unzip "../a.zip"))
(unless (diff "ex1" (build-path "sub" "ex1") #t)
(eprintf "changed! ~s" zip))
(delete-directory/files "sub")
(delete-file "a.zip")
(zip "a.zip" #:path-prefix "inside" "ex1")
(make-directory* "sub")
(parameterize ([current-directory "sub"])
(unzip "../a.zip"))
(unless (diff "ex1" (build-path "sub" "inside" "ex1") #t)
(eprintf "changed! ~s" zip))
(delete-file "a.zip")
(delete-directory/files "sub")
(delete-directory/files "ex1"))
(define work-dir (make-temporary-file "packer~a" 'directory))
(parameterize ([current-directory work-dir])
(zip-tests zip unzip)
(zip-tests tar untar))
(delete-directory/files work-dir)
'ok

57
racket/collects/file/zip.rkt
View File

@ -207,15 +207,17 @@
;; (define *unix:other-read* #o00004)
;; (define *unix:other-write* #o00002)
;; (define *unix:other-exe* #o00001)
(define (path-attributes path dir?)
(define (path-attributes path dir? permissions)
(let ([dos (if dir? #x10 0)]
[unix (apply bitwise-ior (if dir? #o40000 0)
(map (lambda (p)
(case p
[(read) #o444]
[(write) #o200] ; mask out write bits
[(execute) #o111]))
(file-or-directory-permissions path)))])
(or (and permissions
(list permissions))
(map (lambda (p)
(case p
[(read) #o444]
[(write) #o200] ; mask out write bits
[(execute) #o111]))
(file-or-directory-permissions path))))])
(bitwise-ior dos (arithmetic-shift unix 16))))
;; with-trailing-slash : bytes -> bytes
@ -226,19 +228,24 @@
(define (with-slash-separator bytes)
(regexp-replace* *os-specific-separator-regexp* bytes #"/"))
;; build-metadata : relative-path (relative-path . -> . exact-integer?) -> metadata
(define (build-metadata path get-timestamp)
;; build-metadata : relative-path (relative-path . -> . exact-integer?)
;; boolean (or/c #f integer?) -> metadata
(define (build-metadata path-prefix path get-timestamp
force-dir? permissions)
(let* ([mod (seconds->date (get-timestamp path))]
[dir? (directory-exists? path)]
[dir? (or force-dir? (directory-exists? path))]
[attr (path-attributes path dir? permissions)]
[path (cond [(path? path) path]
[(string? path) (string->path path)]
[(bytes? path) (bytes->path path)])]
[name (with-slash-separator (path->bytes path))]
[name-path (if path-prefix
(build-path path-prefix path)
path)]
[name (with-slash-separator (path->bytes name-path))]
[name (if dir? (with-trailing-slash name) name)]
[time (date->msdos-time mod)]
[date (date->msdos-date mod)]
[comp (if dir? 0 *compression-level*)]
[attr (path-attributes path dir?)])
[comp (if dir? 0 *compression-level*)])
(make-metadata path name dir? time date comp attr)))
;; ===========================================================================
@ -253,13 +260,29 @@
#:get-timestamp [get-timestamp (if timestamp
(lambda (p) timestamp)
file-or-directory-modify-seconds)]
#:path-prefix [path-prefix #f]
#:system-type [sys-type (system-type)])
(parameterize ([current-output-port out])
(let* ([seekable? (seekable-port? (current-output-port))]
[headers ; note: Racket's `map' is always left-to-right
(map (lambda (file)
(zip-one-entry (build-metadata file get-timestamp) seekable?))
files)])
(append
;; synthesize directories for `path-prefix` as needed:
(reverse
(let loop ([path-prefix path-prefix])
(cond
[(not path-prefix) null]
[else
(define-values (base name dir?) (split-path path-prefix))
(define r (loop (and (path? base) base)))
(cons
(zip-one-entry (build-metadata #f path-prefix (lambda (x) (current-seconds)) #t #o755)
seekable?)
r)])))
;; add normal files:
(map (lambda (file)
(zip-one-entry (build-metadata path-prefix file get-timestamp #f #f)
seekable?))
files))])
(when (zip-verbose)
(eprintf "zip: writing headers...\n"))
(write-central-directory headers get-timestamp))
@ -273,12 +296,14 @@
#:get-timestamp [get-timestamp (if timestamp
(lambda (p) timestamp)
file-or-directory-modify-seconds)]
#:path-prefix [path-prefix #f]
#:system-type [sys-type (system-type)]
. paths)
;; (when (null? paths) (error 'zip "no paths specified"))
(with-output-to-file zip-file
(lambda () (zip->output (pathlist-closure paths)
#:get-timestamp get-timestamp
#:path-prefix path-prefix
#:system-type sys-type))))
)