2 Commits b899ac2fec ... 7311a8fe18

Author SHA1 Message Date
  Ludovic Courtès 7311a8fe18 Add 'call-with-zlib-input-port' and 'call-with-zlib-output-port'. 8 months ago
  Ludovic Courtès c4fdcd8fa4 Support the deflate, zlib, and gzip formats. 8 months ago
2 changed files with 108 additions and 26 deletions
  1. 13 7
      tests/zlib.scm
  2. 95 19
      zlib.scm

+ 13 - 7
tests/zlib.scm

@@ -80,26 +80,32 @@
          (ucdata (uncompress cdata)))
     (equal? data ucdata)))
 
-(define (test-zlib n level)
-  (test-assert (format #f "zlib ports [size: ~a, level: ~a]" n level)
+(define (test-zlib n fmt level)
+  (test-assert (format #f "zlib ports [size: ~a, format: ~a, level: ~a]"
+                       n fmt level)
     (let* ((size (pk 'size (+ (random n %seed) n)))
            (data (random-bytevector size)))
       (let*-values (((port get)
                      (open-bytevector-output-port))
                     ((compressed)
-                     (make-zlib-output-port port #:level level)))
+                     (make-zlib-output-port port
+                                            #:level level
+                                            #:format fmt)))
         (put-bytevector compressed data)
         (close-port compressed)
         (let ((data2 (get-bytevector-all
                       (make-zlib-input-port
-                       (open-bytevector-input-port (get))))))
+                       (open-bytevector-input-port (get))
+                       #:format fmt))))
           (pk 'sizes size 'vs (bytevector-length data2))
           (bytevector=? data2 data))))))
 
 (for-each (lambda (n)
-            (for-each (lambda (level)
-                        (test-zlib n level))
-                      (iota 9 1)))
+            (for-each (lambda (format)
+                        (for-each (lambda (level)
+                                    (test-zlib n format level))
+                                  (iota 9 1)))
+                      '(deflate zlib gzip)))
           (list (expt 2 8) (expt 2 10) (expt 2 12)
                 (expt 2 14) (expt 2 18)))
 

+ 95 - 19
zlib.scm

@@ -39,7 +39,9 @@
             crc32
 
             make-zlib-input-port
-            make-zlib-output-port))
+            make-zlib-output-port
+            call-with-zlib-input-port
+            call-with-zlib-output-port))
 
 ;;; Commentary:
 ;;;
@@ -193,8 +195,8 @@ buffered input, which would be lost (and is lost anyway)."
                                 (level %default-compression-level)
                                 (buffer-size %default-buffer-size))
   "Return an output port that compresses data at the given LEVEL, using PORT,
-a file port, as its sink.  PORT is automatically closed when the resulting
-port is closed."
+a file port, as its sink.  PORT must be a file port; it is automatically
+closed when the resulting port is closed."
   (define gzfile
     (begin
       (force-output port)                         ;empty PORT's buffer
@@ -215,8 +217,11 @@ port is closed."
 (define* (call-with-gzip-input-port port proc
                                     #:key (buffer-size %default-buffer-size))
   "Call PROC with a port that wraps PORT and decompresses data read from it.
-PORT is closed upon completion.  The gzip internal buffer size is set to
-BUFFER-SIZE bytes."
+PORT must be a file port; it is closed upon completion.  The gzip internal
+buffer size is set to BUFFER-SIZE bytes.
+
+See 'call-with-zlib-input-port' for a slightly slower variant that does not
+require PORT to be a file port."
   (let ((gzip (make-gzip-input-port port #:buffer-size buffer-size)))
     (dynamic-wind
       (const #t)
@@ -229,9 +234,12 @@ BUFFER-SIZE bytes."
                                      #:key
                                      (level %default-compression-level)
                                      (buffer-size %default-buffer-size))
-  "Call PROC with an output port that wraps PORT and compresses data.  PORT is
-close upon completion.  The gzip internal buffer size is set to BUFFER-SIZE
-bytes."
+  "Call PROC with an output port that wraps PORT and compresses data.  PORT
+must be a file port; it is closed upon completion.  The gzip internal buffer
+size is set to BUFFER-SIZE bytes.
+
+See 'call-with-zlib-output-port' for a slightly slower variant that does not
+require PORT to be a file port."
   (let ((gzip (make-gzip-output-port port
                                      #:level level
                                      #:buffer-size buffer-size)))
@@ -500,19 +508,33 @@ struct's fields."
     (lambda (stream flush)
       (proc stream flush))))
 
+(define (window-bits-for-format format)
+  ;; Search for "windowBits" in <zlib.h>.
+  (define MAX_WBITS 15)                           ;<zconf.h>
+  (match format
+    ('deflate (- MAX_WBITS))                      ;raw deflate
+    ('zlib    MAX_WBITS)                          ;zlib header
+    ('gzip    (+ MAX_WBITS 16))))                 ;gzip header
+
 (define inflate-init!
-  (let ((proc (zlib-procedure int "inflateInit_" `(* * ,int))))
-    (lambda (stream)
-      (let ((ret (proc stream
+  (let ((proc (zlib-procedure int "inflateInit2_" `(* ,int * ,int))))
+    (lambda (stream window-bits)
+      (let ((ret (proc stream window-bits
                        (string->pointer %zlib-version)
                        (sizeof %stream-struct))))
         (unless (zero? ret)
           (throw 'zlib-error 'inflate-init! ret))))))
 
 (define deflate-init!
-  (let ((proc (zlib-procedure int "deflateInit_" `(* ,int * ,int))))
-    (lambda (stream level)
-      (let ((ret (proc stream level
+  (let ((proc (zlib-procedure int "deflateInit2_" `(* ,int ,int ,int ,int
+                                                      ,int * ,int))))
+    (lambda* (stream level
+                     #:key
+                     (window-bits (window-bits-for-format 'zlib))
+                     (memory-level 8)
+                     (strategy Z_DEFAULT_STRATEGY))
+      (let ((ret (proc stream level Z_DEFLATED
+                       window-bits memory-level strategy
                        (string->pointer %zlib-version)
                        (sizeof %stream-struct))))
         (unless (zero? ret)
@@ -549,12 +571,19 @@ struct's fields."
 (define Z_FULL_FLUSH 3)
 (define Z_FINISH 4)
 
+;; 'deflate-init!' flags.
+(define Z_DEFLATED 8)
+(define Z_DEFAULT_STRATEGY 0)
 
 (define* (make-zlib-input-port port
                                #:key
+                               (format 'zlib)
                                (buffer-size %default-buffer-size)
                                (close? #t))
-  "Return an input port that decompresses data read from PORT.
+  "Return an input port that decompresses data read from PORT.  FORMAT is a
+symbol denoting the header format; it must be one of 'deflate (RFC 1950),
+'zlib (RFC 1951), or 'gzip (RFC 1952).
+
 When CLOSE? is true, PORT is automatically closed when the resulting port is
 closed."
   (define input-buffer (make-bytevector buffer-size))
@@ -632,18 +661,26 @@ closed."
   ;; No need for extra buffering.
   (setvbuf result 'none)
 
-  (inflate-init! (pointer stream))
+  (inflate-init! (pointer stream)
+                 (window-bits-for-format format))
   (set-stream-avail-in! stream 0)
   result)
 
 (define* (make-zlib-output-port port
                                 #:key
+                                (format 'zlib)
                                 (buffer-size %default-buffer-size)
                                 (level %default-compression-level)
                                 (close? #t))
   "Return an output port that compresses data at the given LEVEL, using PORT
-as its sink.  When CLOSE? is true, PORT is automatically closed when the
-resulting port is closed."
+as its sink.  FORMAT is a symbol denoting the header format; it must be one
+of 'deflate (RFC 1950), 'zlib (RFC 1951), or 'gzip (RFC 1952).
+
+When FORMAT is 'gzip, the gzip header takes default values, and in particular
+no modification time and no file name.
+
+When CLOSE? is true, PORT is automatically closed when the resulting port is
+closed."
   (define output-buffer (make-bytevector buffer-size))
   (define stream (make-bytevector (sizeof %stream-struct)))
 
@@ -696,7 +733,8 @@ resulting port is closed."
     (when close?
       (close-port port)))
 
-  (deflate-init! (pointer stream) level)
+  (deflate-init! (pointer stream) level
+    #:window-bits (window-bits-for-format format))
 
   (set-stream-avail-out! stream buffer-size)
   (set-stream-next-out! stream
@@ -704,4 +742,42 @@ resulting port is closed."
 
   (make-custom-binary-output-port "zlib-output" write! #f #f close))
 
+(define* (call-with-zlib-input-port port proc
+                                    #:key
+                                    (format 'zlib)
+                                    (buffer-size %default-buffer-size))
+  "Call PROC with a port that wraps PORT and decompresses data read from it.
+PORT is closed upon completion.  The zlib internal buffer size is set to
+BUFFER-SIZE bytes."
+  (let ((zlib (make-zlib-input-port port
+                                    #:format format
+                                    #:buffer-size buffer-size
+                                    #:close? #t)))
+    (dynamic-wind
+      (const #t)
+      (lambda ()
+        (proc zlib))
+      (lambda ()
+        (close-port zlib)))))
+
+(define* (call-with-zlib-output-port port proc
+                                     #:key
+                                     (format 'zlib)
+                                     (level %default-compression-level)
+                                     (buffer-size %default-buffer-size))
+  "Call PROC with an output port that wraps PORT and compresses data in the
+given FORMAT, with the given LEVEL.  PORT is closed upon completion.  The
+zlib internal buffer size is set to BUFFER-SIZE bytes."
+  (let ((zlib (make-zlib-output-port port
+                                     #:format format
+                                     #:level level
+                                     #:buffer-size buffer-size
+                                     #:close? #t)))
+    (dynamic-wind
+      (const #t)
+      (lambda ()
+        (proc zlib))
+      (lambda ()
+        (close-port zlib)))))
+
 ;;; zlib.scm ends here