Browse Source
* 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.version-0.11.0
Ludovic Courtès
6 years ago
7 changed files with 328 additions and 1 deletions
@ -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 |
|||
@ -0,0 +1,63 @@ |
|||
;;; 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 (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) |
|||
Loading…
Reference in new issue