From 374742e9051ddb055296329687aeae8920629a5f Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Wed, 4 Jun 2014 13:16:58 +0100 Subject: [PATCH] zip: add `#:path-prefix` argument --- .../racket-doc/file/scribblings/zip.scrbl | 18 +++- .../racket-test/tests/file/packers.rkt | 92 +++++++++++++++++++ racket/collects/file/zip.rkt | 57 ++++++++---- 3 files changed, 148 insertions(+), 19 deletions(-) create mode 100644 pkgs/racket-pkgs/racket-test/tests/file/packers.rkt diff --git a/pkgs/racket-pkgs/racket-doc/file/scribblings/zip.scrbl b/pkgs/racket-pkgs/racket-doc/file/scribblings/zip.scrbl index 83e4bb05a3..c9d10b29a6 100644 --- a/pkgs/racket-pkgs/racket-doc/file/scribblings/zip.scrbl +++ b/pkgs/racket-pkgs/racket-doc/file/scribblings/zip.scrbl @@ -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?]{ diff --git a/pkgs/racket-pkgs/racket-test/tests/file/packers.rkt b/pkgs/racket-pkgs/racket-test/tests/file/packers.rkt new file mode 100644 index 0000000000..2255970721 --- /dev/null +++ b/pkgs/racket-pkgs/racket-test/tests/file/packers.rkt @@ -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 bytesbytes))] + [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 diff --git a/racket/collects/file/zip.rkt b/racket/collects/file/zip.rkt index 3e53f03bad..2102493c4c 100644 --- a/racket/collects/file/zip.rkt +++ b/racket/collects/file/zip.rkt @@ -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)))) )