[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
02/03: Add (guix zlib).
|
From: |
Ludovic Courtès |
|
Subject: |
02/03: Add (guix zlib). |
|
Date: |
Mon, 18 Jul 2016 22:07:41 +0000 (UTC) |
civodul pushed a commit to branch master
in repository guix.
commit 721539026dda02e58addbb618f2102b31a2927f8
Author: Ludovic Courtès <address@hidden>
Date: Mon Jul 18 23:14:14 2016 +0200
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.
---
.dir-locals.el | 2 +
Makefile.am | 2 +
configure.ac | 11 +++
guix/config.scm.in | 6 +-
guix/zlib.scm | 234 ++++++++++++++++++++++++++++++++++++++++++++++++++++
m4/guix.m4 | 11 +++
tests/zlib.scm | 63 ++++++++++++++
7 files changed, 328 insertions(+), 1 deletion(-)
diff --git a/.dir-locals.el b/.dir-locals.el
index c7ceb9e..572a35f 100644
--- a/.dir-locals.el
+++ b/.dir-locals.el
@@ -41,6 +41,8 @@
(eval . (put 'with-atomic-file-output 'scheme-indent-function 1))
(eval . (put 'call-with-compressed-output-port 'scheme-indent-function 2))
(eval . (put 'call-with-decompressed-port 'scheme-indent-function 2))
+ (eval . (put 'call-with-gzip-input-port 'scheme-indent-function 1))
+ (eval . (put 'call-with-gzip-output-port 'scheme-indent-function 1))
(eval . (put 'signature-case 'scheme-indent-function 1))
(eval . (put 'emacs-batch-eval 'scheme-indent-function 0))
(eval . (put 'emacs-batch-edit-file 'scheme-indent-function 1))
diff --git a/Makefile.am b/Makefile.am
index 37a0aef..576177f 100644
--- a/Makefile.am
+++ b/Makefile.am
@@ -57,6 +57,7 @@ MODULES = \
guix/licenses.scm \
guix/graph.scm \
guix/cve.scm \
+ guix/zlib.scm \
guix/build-system.scm \
guix/build-system/ant.scm \
guix/build-system/cmake.scm \
@@ -258,6 +259,7 @@ SCM_TESTS = \
tests/graph.scm \
tests/challenge.scm \
tests/cve.scm \
+ tests/zlib.scm \
tests/file-systems.scm \
tests/system.scm \
tests/services.scm \
diff --git a/configure.ac b/configure.ac
index 7c6fcc9..8367b41 100644
--- a/configure.ac
+++ b/configure.ac
@@ -194,6 +194,17 @@ AC_SUBST([LIBGCRYPT_LIBDIR])
GUIX_ASSERT_LIBGCRYPT_USABLE
+dnl Library name of zlib suitable for 'dynamic-link'.
+GUIX_LIBZ_LIBDIR([libz_libdir])
+if test "x$libz_libdir" = "x"; then
+ LIBZ="libz"
+else
+ LIBZ="$libz_libdir/libz"
+fi
+AC_MSG_CHECKING([for zlib's shared library name])
+AC_MSG_RESULT([$LIBZ])
+AC_SUBST([LIBZ])
+
AC_CACHE_SAVE
m4_include([config-daemon.ac])
diff --git a/guix/config.scm.in b/guix/config.scm.in
index adffa0c..6d42cf2 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 <address@hidden>
+;;; Copyright © 2012, 2013, 2014, 2015, 2016 Ludovic Courtès <address@hidden>
;;;
;;; 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 0000000..51e5e9e
--- /dev/null
+++ b/guix/zlib.scm
@@ -0,0 +1,234 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2016 Ludovic Courtès <address@hidden>
+;;;
+;;; 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
diff --git a/m4/guix.m4 b/m4/guix.m4
index 2d3dfd2..a4f83f0 100644
--- a/m4/guix.m4
+++ b/m4/guix.m4
@@ -308,6 +308,17 @@ AC_DEFUN([GUIX_LIBGCRYPT_LIBDIR], [
$1="$guix_cv_libgcrypt_libdir"
])
+dnl GUIX_LIBZ_LIBDIR VAR
+dnl
+dnl Attempt to determine libz's LIBDIR; store the result in VAR.
+AC_DEFUN([GUIX_LIBZ_LIBDIR], [
+ AC_REQUIRE([PKG_PROG_PKG_CONFIG])
+ AC_CACHE_CHECK([zlib's library directory],
+ [guix_cv_libz_libdir],
+ [guix_cv_libz_libdir="`$PKG_CONFIG zlib --variable=libdir 2> /dev/null`"])
+ $1="$guix_cv_libz_libdir"
+])
+
dnl GUIX_CURRENT_LOCALSTATEDIR
dnl
dnl Determine the localstatedir of an existing Guix installation and set
diff --git a/tests/zlib.scm b/tests/zlib.scm
new file mode 100644
index 0000000..5455240
--- /dev/null
+++ b/tests/zlib.scm
@@ -0,0 +1,63 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2016 Ludovic Courtès <address@hidden>
+;;;
+;;; 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 (test-zlib)
+ #:use-module (guix zlib)
+ #:use-module (guix tests)
+ #:use-module (srfi srfi-64)
+ #:use-module (rnrs bytevectors)
+ #:use-module (rnrs io ports)
+ #:use-module (ice-9 match))
+
+;; Test the (guix zlib) module.
+
+(unless (zlib-available?)
+ (exit 77))
+
+(test-begin "zlib")
+
+(test-assert "compression/decompression pipe"
+ (let ((data (random-bytevector (+ (random 10000)
+ (* 20 1024)))))
+ (match (pipe)
+ ((parent . child)
+ (match (primitive-fork)
+ (0 ;compress
+ (dynamic-wind
+ (const #t)
+ (lambda ()
+ (close-port parent)
+ (call-with-gzip-output-port child
+ (lambda (port)
+ (put-bytevector port data))))
+ (lambda ()
+ (primitive-exit 0))))
+ (pid ;decompress
+ (begin
+ (close-port child)
+ (let ((received (call-with-gzip-input-port parent
+ (lambda (port)
+ (get-bytevector-all port))
+ #:buffer-size (* 64 1024))))
+ (match (waitpid pid)
+ ((_ . status)
+ (and (zero? status)
+ (port-closed? parent)
+ (bytevector=? received data))))))))))))
+
+(test-end)