zip: add #:path-prefix argument

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?]{

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 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

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)
+                       (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)))])
+                                (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
+  ;; build-metadata : relative-path (relative-path . -> . exact-integer?)
-  (define (build-metadata path get-timestamp)
+  ;;                     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*)]
+           [comp (if dir? 0 *compression-level*)])
-           [attr (path-attributes path dir?)])
       (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
+              (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 file get-timestamp) seekable?))
+                      (zip-one-entry (build-metadata path-prefix file get-timestamp #f #f)
-                   files)])
+                                     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))))
   
   )