Add (guix zlib).

* guix/zlib.scm, tests/zlib.scm: New files.
* Makefile.am (MODULES): Add guix/zlib.scm.
(SCM_TESTS): Add tests/zlib.scm.
* m4/guix.m4 (GUIX_LIBGCRYPT_LIBDIR): New macro.
* configure.ac (LIBGCRYPT_LIBDIR): Use it.  Define and substitute
'LIBZ'.
* guix/config.scm.in (%libz): New variable.

2 files changed, 239 insertions, 1 deletions

diff --git a/guix/config.scm.in b/guix/config.scm.in
index adffa0cfec..6d42cf233c 100644
--- a/guix/config.scm.in
+++ b/guix/config.scm.in
@@ -1,5 +1,5 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2012, 2013, 2014, 2015 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2012, 2013, 2014, 2015, 2016 Ludovic Courtès <ludo@gnu.org>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -27,6 +27,7 @@
             %guix-register-program
             %system
             %libgcrypt
+            %libz
             %nix-instantiate
             %gzip
             %bzip2
@@ -72,6 +73,9 @@
 (define %libgcrypt
   "@LIBGCRYPT@")
 
+(define %libz
+  "@LIBZ@")
+
 (define %nix-instantiate
   "@NIX_INSTANTIATE@")
 
diff --git a/guix/zlib.scm b/guix/zlib.scm
new file mode 100644
index 0000000000..51e5e9e426
--- /dev/null
+++ b/guix/zlib.scm
@@ -0,0 +1,234 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2016 Ludovic Courtès <ludo@gnu.org>
+;;;
+;;; This file is part of GNU Guix.
+;;;
+;;; GNU Guix is free software; you can redistribute it and/or modify it
+;;; under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 3 of the License, or (at
+;;; your option) any later version.
+;;;
+;;; GNU Guix is distributed in the hope that it will be useful, but
+;;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;;; GNU General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
+
+(define-module (guix zlib)
+  #:use-module (rnrs bytevectors)
+  #:use-module (ice-9 binary-ports)
+  #:use-module (ice-9 match)
+  #:use-module (system foreign)
+  #:use-module (guix config)
+  #:export (zlib-available?
+            make-gzip-input-port
+            make-gzip-output-port
+            call-with-gzip-input-port
+            call-with-gzip-output-port
+            %default-buffer-size
+            %default-compression-level))
+
+;;; Commentary:
+;;;
+;;; Bindings to the gzip-related part of zlib's API.  The main limitation of
+;;; this API is that it requires a file descriptor as the source or sink.
+;;;
+;;; Code:
+
+(define %zlib
+  ;; File name of zlib's shared library.  When updating via 'guix pull',
+  ;; '%libz' might be undefined so protect against it.
+  (delay (dynamic-link (if (defined? '%libz)
+                           %libz
+                           "libz"))))
+
+(define (zlib-available?)
+  "Return true if zlib is available, #f otherwise."
+  (false-if-exception (force %zlib)))
+
+(define (zlib-procedure ret name parameters)
+  "Return a procedure corresponding to C function NAME in libz, or #f if
+either zlib or the function could not be found."
+  (match (false-if-exception (dynamic-func name (force %zlib)))
+    ((? pointer? ptr)
+     (pointer->procedure ret ptr parameters))
+    (#f
+     #f)))
+
+(define-wrapped-pointer-type <gzip-file>
+  ;; Scheme counterpart of the 'gzFile' opaque type.
+  gzip-file?
+  pointer->gzip-file
+  gzip-file->pointer
+  (lambda (obj port)
+    (format port "#<gzip-file ~a>"
+            (number->string (object-address obj) 16))))
+
+(define gzerror
+  (let ((proc (zlib-procedure '* "gzerror" '(* *))))
+    (lambda (gzfile)
+      (let* ((errnum* (make-bytevector (sizeof int)))
+             (ptr     (proc (gzip-file->pointer gzfile)
+                            (bytevector->pointer errnum*))))
+        (values (bytevector-sint-ref errnum* 0
+                                     (native-endianness) (sizeof int))
+                (pointer->string ptr))))))
+
+(define gzdopen
+  (let ((proc (zlib-procedure '* "gzdopen" (list int '*))))
+    (lambda (fd mode)
+      "Open file descriptor FD as a gzip stream with the given MODE.  MODE must
+be a string denoting the how FD is to be opened, such as \"r\" for reading or
+\"w9\" for writing data compressed at level 9 to FD.  Calling 'gzclose' also
+closes FD."
+      (let ((result (proc fd (string->pointer mode))))
+        (if (null-pointer? result)
+            (throw 'zlib-error 'gzdopen)
+            (pointer->gzip-file result))))))
+
+(define gzread!
+  (let ((proc (zlib-procedure int "gzread" (list '* '* unsigned-int))))
+    (lambda* (gzfile bv #:optional (start 0) (count (bytevector-length bv)))
+      "Read up to COUNT bytes from GZFILE into BV at offset START.  Return the
+number of uncompressed bytes actually read."
+      (let ((ret (proc (gzip-file->pointer gzfile)
+                       (bytevector->pointer bv start)
+                       count)))
+        (if (< ret 0)
+            (throw 'zlib-error 'gzread! ret)
+            ret)))))
+
+(define gzwrite
+  (let ((proc (zlib-procedure int "gzwrite" (list '* '* unsigned-int))))
+    (lambda* (gzfile bv #:optional (start 0) (count (bytevector-length bv)))
+      "Write up to COUNT bytes from BV at offset START into GZFILE.  Return
+the number of uncompressed bytes written, a strictly positive integer."
+      (let ((ret (proc (gzip-file->pointer gzfile)
+                       (bytevector->pointer bv start)
+                       count)))
+        (if (<= ret 0)
+            (throw 'zlib-error 'gzwrite ret)
+            ret)))))
+
+(define gzbuffer!
+  (let ((proc (zlib-procedure int "gzbuffer" (list '* unsigned-int))))
+    (lambda (gzfile size)
+      "Change the internal buffer size of GZFILE to SIZE bytes."
+      (let ((ret (proc (gzip-file->pointer gzfile) size)))
+        (unless (zero? ret)
+          (throw 'zlib-error 'gzbuffer! ret))))))
+
+(define gzeof?
+  (let ((proc (zlib-procedure int "gzeof" '(*))))
+    (lambda (gzfile)
+      "Return true if the end-of-file has been reached on GZFILE."
+      (not (zero? (proc (gzip-file->pointer gzfile)))))))
+
+(define gzclose
+  (let ((proc (zlib-procedure int "gzclose" '(*))))
+    (lambda (gzfile)
+      "Close GZFILE."
+      (let ((ret (proc (gzip-file->pointer gzfile))))
+        (unless (zero? ret)
+          (throw 'zlib-error 'gzclose ret (gzerror gzfile)))))))
+
+
+
+;;;
+;;; Port interface.
+;;;
+
+(define %default-buffer-size
+  ;; Default buffer size, as documented in <zlib.h>.
+  8192)
+
+(define %default-compression-level
+  ;; Z_DEFAULT_COMPRESSION.
+  -1)
+
+(define (close-procedure gzfile port)
+  "Return a procedure that closes GZFILE, ensuring its underlying PORT is
+closed even if closing GZFILE triggers an exception."
+  (lambda ()
+    (catch 'zlib-error
+      (lambda ()
+        ;; 'gzclose' closes the underlying file descriptor.  'close-port'
+        ;; calls close(2), gets EBADF, which is ignores.
+        (gzclose gzfile)
+        (close-port port))
+      (lambda args
+        ;; Make sure PORT is closed despite the zlib error.
+        (close-port port)
+        (apply throw args)))))
+
+(define* (make-gzip-input-port port #:key (buffer-size %default-buffer-size))
+  "Return an input port that decompresses data read from PORT, a file port.
+PORT is automatically closed when the resulting port is closed.  BUFFER-SIZE
+is the size in bytes of the internal buffer, 8 KiB by default; using a larger
+buffer increases decompression speed."
+  (define gzfile
+    (gzdopen (fileno port) "r"))
+
+  (define (read! bv start count)
+    ;; XXX: Can 'gzread!' return zero even though we haven't reached the EOF?
+    (gzread! gzfile bv start count))
+
+  (unless (= buffer-size %default-buffer-size)
+    (gzbuffer! gzfile buffer-size))
+
+  (make-custom-binary-input-port "gzip-input" read! #f #f
+                                 (close-procedure gzfile port)))
+
+(define* (make-gzip-output-port port
+                                #:key
+                                (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."
+  (define gzfile
+    (gzdopen (fileno port)
+             (string-append "w" (number->string level))))
+
+  (define (write! bv start count)
+    (gzwrite gzfile bv start count))
+
+  (unless (= buffer-size %default-buffer-size)
+    (gzbuffer! gzfile buffer-size))
+
+  (make-custom-binary-output-port "gzip-output" write! #f #f
+                                  (close-procedure gzfile port)))
+
+(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."
+  (let ((gzip (make-gzip-input-port port #:buffer-size buffer-size)))
+    (dynamic-wind
+      (const #t)
+      (lambda ()
+        (proc gzip))
+      (lambda ()
+        (close-port gzip)))))
+
+(define* (call-with-gzip-output-port port proc
+                                     #: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."
+  (let ((gzip (make-gzip-output-port port
+                                     #:level level
+                                     #:buffer-size buffer-size)))
+    (dynamic-wind
+      (const #t)
+      (lambda ()
+        (proc gzip))
+      (lambda ()
+        (close-port gzip)))))
+
+;;; zlib.scm ends here