ryan77627/guix
1
0
Fork 0
mirror of https://git.in.rschanz.org/ryan77627/guix.git synced 2024-12-23 21:17:11 -05:00
Code Issues Projects Releases Packages Wiki Activity Actions

Add (guix zlib).

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.
This commit is contained in:
Ludovic Courtès 2016-07-18 23:14:14 +02:00
parent 2c2ec261a8
commit 721539026d
No known key found for this signature in database
GPG key ID: 090B11993D9AEBB5
7 changed files with 328 additions and 1 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

2
.dir-locals.el
View file

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

2
Makefile.am
View file

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

11
configure.ac
View file

@ -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])

6
guix/config.scm.in
View file

@ -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 @@ (define-module (guix config)
%guix-register-program
%system
%libgcrypt
%libz
%nix-instantiate
%gzip
%bzip2
@ -72,6 +73,9 @@ (define %system
(define %libgcrypt
"@LIBGCRYPT@")
(define %libz
"@LIBZ@")
(define %nix-instantiate
"@NIX_INSTANTIATE@")

234
guix/zlib.scm Normal file
View file

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

11
m4/guix.m4
View file

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

63
tests/zlib.scm Normal file
View file

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