From ce6b8b8d5c8a69cea977a04944ae8f698058d675 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Mon, 10 Mar 2014 13:57:07 -0600 Subject: [PATCH] file/zip, file/tar: add #:get-timestamp argument Allows the recorded timestamp to be adjusted in a general way. --- .../distro-build-server/pack-and-catalog.rkt | 3 +- .../racket-doc/file/scribblings/tar.scrbl | 38 ++++++++++++--- .../racket-doc/file/scribblings/zip.scrbl | 30 +++++++++--- racket/collects/file/tar.rkt | 13 +++-- racket/collects/file/zip.rkt | 47 +++++++++++-------- 5 files changed, 94 insertions(+), 37 deletions(-) diff --git a/pkgs/distro-build-pkgs/distro-build-server/pack-and-catalog.rkt b/pkgs/distro-build-pkgs/distro-build-server/pack-and-catalog.rkt index 7d1b45611e..3713a613d4 100644 --- a/pkgs/distro-build-pkgs/distro-build-server/pack-and-catalog.rkt +++ b/pkgs/distro-build-pkgs/distro-build-server/pack-and-catalog.rkt @@ -100,7 +100,8 @@ (apply zip dest-zip (directory-list) ;; Use a constant timestamp so that the checksum does ;; not depend on timestamps: - #:timestamp 1359788400)) + #:timestamp 1359788400 + #:system-type 'unix)) (delete-directory/files tmp-dir) (call-with-output-file* dest-sum diff --git a/pkgs/racket-pkgs/racket-doc/file/scribblings/tar.scrbl b/pkgs/racket-pkgs/racket-doc/file/scribblings/tar.scrbl index eb1f57c370..82ee7ab22b 100644 --- a/pkgs/racket-pkgs/racket-doc/file/scribblings/tar.scrbl +++ b/pkgs/racket-pkgs/racket-doc/file/scribblings/tar.scrbl @@ -14,9 +14,15 @@ is always ``root.'' Symbolic links (on Unix and Mac OS X) are not followed, and the path in a link must be less than 100 bytes.} + @defproc[(tar [tar-file path-string?] [path path-string?] ... - [#:path-prefix path-prefix (or/c #f path-string?) #f]) + [#:path-prefix path-prefix (or/c #f path-string?) #f] + [#:get-timestamp get-timestamp + (path? . -> . exact-integer?) + (if timestamp + (lambda (p) timestamp) + file-or-directory-modify-seconds)]) exact-nonnegative-integer?]{ Creates @racket[tar-file], which holds the complete content of all @@ -28,23 +34,43 @@ resulting tar file, up to the current directory (using @racket[pathlist-closure]). If @racket[path-prefix] is not @racket[#f], then it is prefixed to -each path in the archive.} +each path in the archive. + +The @racket[get-timestamp] function is used to obtain the modification +date to record in the archive for each file or directory. + +@history[#:changed "6.0.0.3" @elem{Added the @racket[#:get-timestamp] argument.}]} + @defproc[(tar->output [paths (listof path?)] [out output-port? (current-output-port)] - [#:path-prefix path-prefix (or/c #f path-string?) #f]) + [#:path-prefix path-prefix (or/c #f path-string?) #f] + [#:get-timestamp get-timestamp + (path? . -> . exact-integer?) + (if timestamp + (lambda (p) timestamp) + file-or-directory-modify-seconds)]) exact-nonnegative-integer?]{ Packages each of the given @racket[paths] in a @exec{tar} format archive that is written directly to the @racket[out]. The specified @racket[paths] are included as-is (except for adding @racket[path-prefix], if any); if a directory is specified, its content is not automatically added, and nested directories are added -without parent directories.} +without parent directories. + +@history[#:changed "6.0.0.3" @elem{Added the @racket[#:get-timestamp] argument.}]} + @defproc[(tar-gzip [tar-file path-string?] [paths path-string?] ... - [#:path-prefix path-prefix (or/c #f path-string?) #f]) + [#:path-prefix path-prefix (or/c #f path-string?) #f] + [#:get-timestamp get-timestamp + (path? . -> . exact-integer?) + (if timestamp + (lambda (p) timestamp) + file-or-directory-modify-seconds)]) void?]{ Like @racket[tar], but compresses the resulting file with @racket[gzip]. -} + +@history[#:changed "6.0.0.3" @elem{Added the @racket[#:get-timestamp] argument.}]} diff --git a/pkgs/racket-pkgs/racket-doc/file/scribblings/zip.scrbl b/pkgs/racket-pkgs/racket-doc/file/scribblings/zip.scrbl index 0a831ebf94..83e4bb05a3 100644 --- a/pkgs/racket-pkgs/racket-doc/file/scribblings/zip.scrbl +++ b/pkgs/racket-pkgs/racket-doc/file/scribblings/zip.scrbl @@ -9,7 +9,13 @@ with both Windows and Unix (including Mac OS X) unpacking. The actual compression is implemented by @racket[deflate].} @defproc[(zip [zip-file path-string?] [path path-string?] ... - [#:timestamp timestamp (or/c #f exact-integer?) #f]) + [#:timestamp timestamp (or/c #f exact-integer?) #f] + [#:get-timestamp get-timestamp + (path? . -> . exact-integer?) + (if timestamp + (lambda (p) timestamp) + file-or-directory-modify-seconds)] + [#:system-type sys-type symbol? (system-type)]) void?]{ Creates @racket[zip-file], which holds the complete content of all @@ -29,21 +35,33 @@ Files are packaged as usual for distinction between owner/group/other permissions. Also, symbolic links are always followed. -If @racket[timestamp] is not @racket[#f], it is used as the -modification date for each file, instead of the result of -@racket[file-or-directory-modify-seconds].} +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. + +@history[#:changed "6.0.0.3" + @elem{Added the @racket[#:get-timestamp] and @racket[#:system-type] arguments.}]} @defproc[(zip->output [paths (listof path-string?)] [out output-port? (current-output-port)] - [#:timestamp timestamp (or/c #f exact-integer?) #f]) + [#:timestamp timestamp (or/c #f exact-integer?) #f] + [#:get-timestamp get-timestamp + (path? . -> . exact-integer?) + (if timestamp + (lambda (p) timestamp) + file-or-directory-modify-seconds)] + [#: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 directory is specified, its content is not automatically added, and -nested directories are added without parent directories.} +nested directories are added without parent directories. + +@history[#:changed "6.0.0.3" + @elem{Added the @racket[#:get-timestamp] and @racket[#:system-type] arguments.}]} @defboolparam[zip-verbose on?]{ diff --git a/racket/collects/file/tar.rkt b/racket/collects/file/tar.rkt index 7192aec60a..98bd639dec 100644 --- a/racket/collects/file/tar.rkt +++ b/racket/collects/file/tar.rkt @@ -43,7 +43,7 @@ (define 0-byte (char->integer #\0)) -(define ((tar-one-entry buf prefix) path) +(define ((tar-one-entry buf prefix get-timestamp) path) (let* ([link? (link-exists? path)] [dir? (and (not link?) (directory-exists? path))] [size (if (or dir? link?) 0 (file-size path))] @@ -82,7 +82,7 @@ (write-octal 8 0) ; always root (uid) (write-octal 8 0) ; always root (gid) (write-octal 12 size) - (write-octal 12 (file-or-directory-modify-seconds path)) + (write-octal 12 (get-timestamp path)) ;; set checksum later, consider it "all blanks" for cksum (set! cksum-p p) (set! cksum (+ cksum (* 8 32))) (advance 8) (write-block* 1 (if link? #"2" (if dir? #"5" #"0"))) ; type-flag: dir/file (no symlinks) @@ -130,9 +130,10 @@ ;; writes a tar file to current-output-port (provide tar->output) (define (tar->output files [out (current-output-port)] + #:get-timestamp [get-timestamp file-or-directory-modify-seconds] #:path-prefix [prefix #f]) (parameterize ([current-output-port out]) - (let* ([buf (new-block)] [entry (tar-one-entry buf prefix)]) + (let* ([buf (new-block)] [entry (tar-one-entry buf prefix get-timestamp)]) (for-each entry files) ;; two null blocks end-marker (write-bytes buf) (write-bytes buf)))) @@ -141,16 +142,19 @@ (provide tar) (define (tar tar-file #:path-prefix [prefix #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 (lambda () (tar->output (pathlist-closure paths #:follow-links? #f) + #:get-timestamp get-timestamp #:path-prefix prefix)))) ;; tar-gzip : output-file paths -> (provide tar-gzip) (define (tar-gzip tgz-file #:path-prefix [prefix #f] + #:get-timestamp [get-timestamp file-or-directory-modify-seconds] . paths) (when (null? paths) (error 'tar-gzip "no paths specified")) (with-output-to-file tgz-file @@ -158,7 +162,8 @@ (let-values ([(i o) (make-pipe (* 1024 1024 32))]) (thread (lambda () (tar->output (pathlist-closure paths #:follow-links? #f) o - #:path-prefix prefix) + #:path-prefix prefix + #:get-timestamp get-timestamp) (close-output-port o))) (gzip-through-ports i (current-output-port) diff --git a/racket/collects/file/zip.rkt b/racket/collects/file/zip.rkt index 6341e3af1b..c44174f8f4 100644 --- a/racket/collects/file/zip.rkt +++ b/racket/collects/file/zip.rkt @@ -39,12 +39,12 @@ (define *zip64-end-of-central-directory-locator* #x07064b50) (define *end-of-central-directory-record* #x06054b50) - (define *system* - (case (system-type) - [(unix oskit) 3] + (define (get-system-id type) + (case type [(windows) 0] [(macos) 7] - [(macosx) 19])) + [(macosx) 19] + [else 3])) (define *os-specific-separator-regexp* (case (system-type) [(unix macosx oskit) #rx"/"] @@ -142,8 +142,8 @@ (write-int comment-length 2) (write-bytes *zip-comment*))) - ;; write-central-directory : (listof header) (or/c #f exact-integer?) -> - (define (write-central-directory headers timestamp) + ;; write-central-directory : (listof header) symbol? -> + (define (write-central-directory headers sys-type) (let ([count (length headers)]) (let loop ([headers headers] [offset 0] [size 0]) (if (null? headers) @@ -155,9 +155,7 @@ [attributes (metadata-attributes metadata)] [compression (metadata-compression metadata)] [version (bitwise-ior *spec-version* - (arithmetic-shift (if timestamp - 3 - *system*) + (arithmetic-shift (get-system-id sys-type) 8))]) (write-int #x02014b50 4) (write-int version 2) @@ -227,10 +225,9 @@ (define (with-slash-separator bytes) (regexp-replace* *os-specific-separator-regexp* bytes #"/")) - ;; build-metadata : relative-path (or/c #f exact-integer?) -> metadata - (define (build-metadata path timestamp) - (let* ([mod (seconds->date (or timestamp - (file-or-directory-modify-seconds path)))] + ;; build-metadata : relative-path (relative-path . -> . exact-integer?) -> metadata + (define (build-metadata path get-timestamp) + (let* ([mod (seconds->date (get-timestamp path))] [dir? (directory-exists? path)] [path (cond [(path? path) path] [(string? path) (string->path path)] @@ -251,26 +248,36 @@ ;; writes a zip file to current-output-port (provide zip->output) (define (zip->output files [out (current-output-port)] - #:timestamp [timestamp #f]) + #:timestamp [timestamp #f] + #:get-timestamp [get-timestamp (if timestamp + (lambda (p) timestamp) + file-or-directory-modify-seconds)] + #: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 timestamp) seekable?)) + (zip-one-entry (build-metadata file get-timestamp) seekable?)) files)]) (when (zip-verbose) (eprintf "zip: writing headers...\n")) - (write-central-directory headers timestamp)) + (write-central-directory headers get-timestamp)) (when (zip-verbose) (eprintf "zip: done.\n")))) ;; zip : output-file paths -> (provide zip) - (define (zip zip-file #:timestamp [timestamp #f] + (define (zip zip-file + #:timestamp [timestamp #f] + #:get-timestamp [get-timestamp (if timestamp + (lambda (p) timestamp) + file-or-directory-modify-seconds)] + #: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) - #:timestamp timestamp)))) - + (lambda () (zip->output (pathlist-closure paths) + #:get-timestamp get-timestamp + #:system-type sys-type)))) + )