me
/
guix
Archived
1
0
Fork 0
Code

Use "guile-zlib" and "guile-lzlib" instead of (guix config). 

* Makefile.am (MODULES): Remove guix/zlib.scm and guix/lzlib.scm,
(SCM_TESTS): remove tests/zlib.scm, tests/lzlib.scm.
* build-aux/build-self.scm (make-config.scm): Remove unused %libz variable.
* configure.ac: Remove LIBZ and LIBLZ variables and check instead for
Guile-zlib and Guile-lzlib.
* doc/guix.texi ("Requirements"): Remove zlib requirement and add Guile-zlib
and Guile-lzlib instead.
* gnu/packages/package-management.scm (guix)[native-inputs]: Add "guile-zlib"
and "guile-lzlib",
[inputs]: remove "zlib" and "lzlib",
[propagated-inputs]: ditto,
[arguments]: add "guile-zlib" and "guile-lzlib" to Guile load path.
* guix/config.scm.in (%libz, %liblz): Remove them.
* guix/lzlib.scm: Remove it.
* guix/man-db.scm: Use (zlib) instead of (guix zlib).
* guix/profiles.scm (manual-database): Do not stub (guix config) in imported
modules list, instead add "guile-zlib" to the extension list.
* guix/scripts/publish.scm: Use (zlib) instead of (guix zlib) and (lzlib)
instead of (guix lzlib),
(string->compression-type, effective-compression): do not check for zlib and
lzlib availability.
* guix/scripts/substitute.scm (%compression-methods): Do not check for lzlib
availability.
* guix/self.scm (specification->package): Add "guile-zlib" and "guile-lzlib"
and remove "zlib" and "lzlib",
(compiled-guix): remove "zlib" and "lzlib" arguments and add guile-zlib and
guile-lzlib to the dependencies, also do not pass "zlib" and "lzlib" to
"make-config.scm" procedure,
(make-config.scm): remove "zlib" and "lzlib" arguments as well as %libz and
%liblz variables.
* guix/utils.scm (lzip-port): Use (lzlib) instead of (guix lzlib) and do not
check for lzlib availability.
* guix/zlib.scm: Remove it.
* m4/guix.m4 (GUIX_LIBZ_LIBDIR, GUIX_LIBLZ_FILE_NAME): Remove them.
* tests/lzlib.scm: Use (zlib) instead of (guix zlib) and (lzlib)
instead of (guix lzlib), and do not check for zlib and lzlib availability.
* tests/publish.scm: Ditto.
* tests/substitute.scm: Do not check for lzlib availability.
* tests/utils.scm: Ditto.
* tests/zlib.scm: Remove it.
master
Mathieu Othacehe 2020-07-27 16:36:39 +02:00
parent 5abbf435fc
commit 4c0c65acfa
No known key found for this signature in database
GPG Key ID: 8354763531769CA6
21 changed files with 60 additions and 1290 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

6
Makefile.am
View File

@ -109,8 +109,6 @@ MODULES = \
guix/cache.scm \ guix/cache.scm \
guix/cve.scm \ guix/cve.scm \
guix/workers.scm \ guix/workers.scm \
guix/zlib.scm \
guix/lzlib.scm \
guix/build-system.scm \ guix/build-system.scm \
guix/build-system/android-ndk.scm \ guix/build-system/android-ndk.scm \
guix/build-system/ant.scm \ guix/build-system/ant.scm \
@ -431,7 +429,6 @@ SCM_TESTS = \
tests/import-utils.scm \ tests/import-utils.scm \
tests/inferior.scm \ tests/inferior.scm \
tests/lint.scm \ tests/lint.scm \
tests/lzlib.scm \
tests/modules.scm \ tests/modules.scm \
tests/monads.scm \ tests/monads.scm \
tests/nar.scm \ tests/nar.scm \
@ -470,8 +467,7 @@ SCM_TESTS = \
tests/upstream.scm \ tests/upstream.scm \
tests/utils.scm \ tests/utils.scm \
tests/uuid.scm \ tests/uuid.scm \
tests/workers.scm \ tests/workers.scm
tests/zlib.scm
SH_TESTS = \ SH_TESTS = \
tests/guix-build.sh \ tests/guix-build.sh \

8
build-aux/build-self.scm
View File

@ -71,7 +71,7 @@
(variables rest ...)))))) (variables rest ...))))))
(variables %localstatedir %storedir %sysconfdir %system))) (variables %localstatedir %storedir %sysconfdir %system)))
(define* (make-config.scm #:key zlib gzip xz bzip2 (define* (make-config.scm #:key gzip xz bzip2
(package-name "GNU Guix") (package-name "GNU Guix")
(package-version "0") (package-version "0")
(bug-report-address "bug-guix@gnu.org") (bug-report-address "bug-guix@gnu.org")
@ -133,11 +133,7 @@
(define %bzip2 (define %bzip2
#+(and bzip2 (file-append bzip2 "/bin/bzip2"))) #+(and bzip2 (file-append bzip2 "/bin/bzip2")))
(define %xz (define %xz
#+(and xz (file-append xz "/bin/xz"))) #+(and xz (file-append xz "/bin/xz")))))))
(define %libz
#+(and zlib
(file-append zlib "/lib/libz")))))))
;;; ;;;

33
configure.ac
View File

@ -141,6 +141,18 @@ if test "x$guix_cv_have_recent_guile_gcrypt" != "xyes"; then
AC_MSG_ERROR([A recent Guile-Gcrypt could not be found; please install it.]) AC_MSG_ERROR([A recent Guile-Gcrypt could not be found; please install it.])
fi fi
dnl Check for Guile-zlib.
GUILE_MODULE_AVAILABLE([have_guile_zlib], [(zlib)])
if test "x$have_guile_zlib" != "xyes"; then
AC_MSG_ERROR([Guile-zlib is missing; please install it.])
fi
dnl Check for Guile-lzlib.
GUILE_MODULE_AVAILABLE([have_guile_lzlib], [(lzlib)])
if test "x$have_guile_lzlib" != "xyes"; then
AC_MSG_ERROR([Guile-lzlib is missing; please install it.])
fi
dnl Guile-newt is used by the graphical installer. dnl Guile-newt is used by the graphical installer.
GUILE_MODULE_AVAILABLE([have_guile_newt], [(newt)]) GUILE_MODULE_AVAILABLE([have_guile_newt], [(newt)])
@ -245,27 +257,6 @@ esac
AC_SUBST([LIBGCRYPT_PREFIX]) AC_SUBST([LIBGCRYPT_PREFIX])
AC_SUBST([LIBGCRYPT_LIBDIR]) AC_SUBST([LIBGCRYPT_LIBDIR])
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])
dnl Library name of lzlib suitable for 'dynamic-link'.
GUIX_LIBLZ_FILE_NAME([LIBLZ])
if test "x$LIBLZ" = "x"; then
LIBLZ="liblz"
else
# Strip the .so or .so.1 extension since that's what 'dynamic-link' expects.
LIBLZ="`echo $LIBLZ | sed -es'/\.so\(\.[[0-9.]]\+\)\?//g'`"
fi
AC_SUBST([LIBLZ])
dnl Check for Guile-SSH, for the (guix ssh) module. dnl Check for Guile-SSH, for the (guix ssh) module.
GUIX_CHECK_GUILE_SSH GUIX_CHECK_GUILE_SSH
AM_CONDITIONAL([HAVE_GUILE_SSH], AM_CONDITIONAL([HAVE_GUILE_SSH],

3
doc/guix.texi
View File

@ -778,12 +778,13 @@ Guile,, gnutls-guile, GnuTLS-Guile});
@item @item
@uref{https://notabug.org/guile-sqlite3/guile-sqlite3, Guile-SQLite3}, version 0.1.0 @uref{https://notabug.org/guile-sqlite3/guile-sqlite3, Guile-SQLite3}, version 0.1.0
or later; or later;
@item @uref{https://notabug.org/guile-zlib/guile-zlib, Guile-zlib};
@item @uref{https://notabug.org/guile-lzlib/guile-lzlib, Guile-lzlib};
@item @item
@c FIXME: Specify a version number once a release has been made. @c FIXME: Specify a version number once a release has been made.
@uref{https://gitlab.com/guile-git/guile-git, Guile-Git}, from August @uref{https://gitlab.com/guile-git/guile-git, Guile-Git}, from August
2017 or later; 2017 or later;
@item @uref{https://savannah.nongnu.org/projects/guile-json/, Guile-JSON} 3.x; @item @uref{https://savannah.nongnu.org/projects/guile-json/, Guile-JSON} 3.x;
@item @url{https://zlib.net, zlib};
@item @url{https://www.gnu.org/software/make/, GNU Make}. @item @url{https://www.gnu.org/software/make/, GNU Make}.
@end itemize @end itemize

13
gnu/packages/package-management.scm
View File

@ -279,6 +279,8 @@ $(prefix)/etc/init.d\n")))
(gcrypt (assoc-ref inputs "guile-gcrypt")) (gcrypt (assoc-ref inputs "guile-gcrypt"))
(json (assoc-ref inputs "guile-json")) (json (assoc-ref inputs "guile-json"))
(sqlite (assoc-ref inputs "guile-sqlite3")) (sqlite (assoc-ref inputs "guile-sqlite3"))
(zlib (assoc-ref inputs "guile-zlib"))
(lzlib (assoc-ref inputs "guile-lzlib"))
(git (assoc-ref inputs "guile-git")) (git (assoc-ref inputs "guile-git"))
(bs (assoc-ref inputs (bs (assoc-ref inputs
"guile-bytestructures")) "guile-bytestructures"))
@ -286,7 +288,7 @@ $(prefix)/etc/init.d\n")))
(gnutls (assoc-ref inputs "gnutls")) (gnutls (assoc-ref inputs "gnutls"))
(locales (assoc-ref inputs "glibc-utf8-locales")) (locales (assoc-ref inputs "glibc-utf8-locales"))
(deps (list gcrypt json sqlite gnutls (deps (list gcrypt json sqlite gnutls
git bs ssh)) git bs ssh zlib lzlib))
(effective (effective
(read-line (read-line
(open-pipe* OPEN_READ (open-pipe* OPEN_READ
@ -326,6 +328,8 @@ $(prefix)/etc/init.d\n")))
("guile-gcrypt" ,guile-gcrypt) ("guile-gcrypt" ,guile-gcrypt)
("guile-json" ,guile-json-4) ("guile-json" ,guile-json-4)
("guile-sqlite3" ,guile-sqlite3) ("guile-sqlite3" ,guile-sqlite3)
("guile-zlib" ,guile-zlib)
("guile-lzlib" ,guile-lzlib)
("guile-ssh" ,guile-ssh) ("guile-ssh" ,guile-ssh)
("guile-git" ,guile-git) ("guile-git" ,guile-git)
@ -342,9 +346,6 @@ $(prefix)/etc/init.d\n")))
(inputs (inputs
`(("bzip2" ,bzip2) `(("bzip2" ,bzip2)
("gzip" ,gzip) ("gzip" ,gzip)
("zlib" ,zlib) ;for 'guix publish'
("lzlib" ,lzlib) ;for 'guix publish' and 'guix substitute'
("sqlite" ,sqlite) ("sqlite" ,sqlite)
("libgcrypt" ,libgcrypt) ("libgcrypt" ,libgcrypt)
@ -378,7 +379,9 @@ $(prefix)/etc/init.d\n")))
("guile-json" ,guile-json-4) ("guile-json" ,guile-json-4)
("guile-sqlite3" ,guile-sqlite3) ("guile-sqlite3" ,guile-sqlite3)
("guile-ssh" ,guile-ssh) ("guile-ssh" ,guile-ssh)
("guile-git" ,guile-git))) ("guile-git" ,guile-git)
("guile-zlib" ,guile-zlib)
("guile-lzlib" ,guile-lzlib)))
(home-page "https://www.gnu.org/software/guix/") (home-page "https://www.gnu.org/software/guix/")
(synopsis "Functional package manager for installed software packages and versions") (synopsis "Functional package manager for installed software packages and versions")

8
guix/config.scm.in
View File

@ -33,8 +33,6 @@
%config-directory %config-directory
%system %system
%libz
%liblz
%gzip %gzip
%bzip2 %bzip2
%xz)) %xz))
@ -88,12 +86,6 @@
(define %system (define %system
"@guix_system@") "@guix_system@")
(define %libz
"@LIBZ@")
(define %liblz
"@LIBLZ@")
(define %gzip (define %gzip
"@GZIP@") "@GZIP@")

2
guix/gnu-maintenance.scm
View File

@ -36,7 +36,7 @@
#:use-module (guix records) #:use-module (guix records)
#:use-module (guix upstream) #:use-module (guix upstream)
#:use-module (guix packages) #:use-module (guix packages)
#:use-module (guix zlib) #:use-module (zlib)
#:export (gnu-package-name #:export (gnu-package-name
gnu-package-mundane-name gnu-package-mundane-name
gnu-package-copyright-holder gnu-package-copyright-holder

709
guix/lzlib.scm
View File

@ -1,709 +0,0 @@
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2019 Pierre Neidhardt <mail@ambrevar.xyz>
;;; Copyright © 2019, 2020 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 lzlib)
#:use-module (rnrs bytevectors)
#:use-module (rnrs arithmetic bitwise)
#:use-module (ice-9 binary-ports)
#:use-module (ice-9 match)
#:use-module (system foreign)
#:use-module (guix config)
#:use-module (srfi srfi-11)
#:export (lzlib-available?
make-lzip-input-port
make-lzip-output-port
make-lzip-input-port/compressed
call-with-lzip-input-port
call-with-lzip-output-port
%default-member-length-limit
%default-compression-level
dictionary-size+match-length-limit))
;;; Commentary:
;;;
;;; Bindings to the lzlib / liblz API. Some convenience functions are also
;;; provided (see the export).
;;;
;;; While the bindings are complete, the convenience functions only support
;;; single member archives. To decompress single member archives, we loop
;;; until lz-decompress-read returns 0. This is simpler. To support multiple
;;; members properly, we need (among others) to call lz-decompress-finish and
;;; loop over lz-decompress-read until lz-decompress-finished? returns #t.
;;; Otherwise a multi-member archive starting with an empty member would only
;;; decompress the empty member and stop there, resulting in truncated output.
;;; Code:
(define %lzlib
;; File name of lzlib's shared library. When updating via 'guix pull',
;; '%liblz' might be undefined so protect against it.
(delay (dynamic-link (if (defined? '%liblz)
%liblz
"liblz"))))
(define (lzlib-available?)
"Return true if lzlib is available, #f otherwise."
(false-if-exception (force %lzlib)))
(define (lzlib-procedure ret name parameters)
"Return a procedure corresponding to C function NAME in liblz, or #f if
either lzlib or the function could not be found."
(match (false-if-exception (dynamic-func name (force %lzlib)))
((? pointer? ptr)
(pointer->procedure ret ptr parameters))
(#f
#f)))
(define-wrapped-pointer-type <lz-decoder>
;; Scheme counterpart of the 'LZ_Decoder' opaque type.
lz-decoder?
pointer->lz-decoder
lz-decoder->pointer
(lambda (obj port)
(format port "#<lz-decoder ~a>"
(number->string (object-address obj) 16))))
(define-wrapped-pointer-type <lz-encoder>
;; Scheme counterpart of the 'LZ_Encoder' opaque type.
lz-encoder?
pointer->lz-encoder
lz-encoder->pointer
(lambda (obj port)
(format port "#<lz-encoder ~a>"
(number->string (object-address obj) 16))))
;; From lzlib.h
(define %error-number-ok 0)
(define %error-number-bad-argument 1)
(define %error-number-mem-error 2)
(define %error-number-sequence-error 3)
(define %error-number-header-error 4)
(define %error-number-unexpected-eof 5)
(define %error-number-data-error 6)
(define %error-number-library-error 7)
;; Compression bindings.
(define lz-compress-open
(let ((proc (lzlib-procedure '* "LZ_compress_open" (list int int uint64)))
;; member-size is an "unsigned long long", and the C standard guarantees
;; a minimum range of 0..2^64-1.
(unlimited-size (- (expt 2 64) 1)))
(lambda* (dictionary-size match-length-limit #:optional (member-size unlimited-size))
"Initialize the internal stream state for compression and returns a
pointer that can only be used as the encoder argument for the other
lz-compress functions, or a null pointer if the encoder could not be
allocated.
See the manual: (lzlib) Compression functions."
(let ((encoder-ptr (proc dictionary-size match-length-limit member-size)))
(if (not (= (lz-compress-error encoder-ptr) -1))
(pointer->lz-encoder encoder-ptr)
(throw 'lzlib-error 'lz-compress-open))))))
(define lz-compress-close
(let ((proc (lzlib-procedure int "LZ_compress_close" '(*))))
(lambda (encoder)
"Close encoder. ENCODER can no longer be used as an argument to any
lz-compress function. "
(let ((ret (proc (lz-encoder->pointer encoder))))
(if (= ret -1)
(throw 'lzlib-error 'lz-compress-close ret)
ret)))))
(define lz-compress-finish
(let ((proc (lzlib-procedure int "LZ_compress_finish" '(*))))
(lambda (encoder)
"Tell that all the data for this member have already been written (with
the `lz-compress-write' function). It is safe to call `lz-compress-finish' as
many times as needed. After all the produced compressed data have been read
with `lz-compress-read' and `lz-compress-member-finished?' returns #t, a new
member can be started with 'lz-compress-restart-member'."
(let ((ret (proc (lz-encoder->pointer encoder))))
(if (= ret -1)
(throw 'lzlib-error 'lz-compress-finish (lz-compress-error encoder))
ret)))))
(define lz-compress-restart-member
(let ((proc (lzlib-procedure int "LZ_compress_restart_member" (list '* uint64))))
(lambda (encoder member-size)
"Start a new member in a multimember data stream.
Call this function only after `lz-compress-member-finished?' indicates that the
current member has been fully read (with the `lz-compress-read' function)."
(let ((ret (proc (lz-encoder->pointer encoder) member-size)))
(if (= ret -1)
(throw 'lzlib-error 'lz-compress-restart-member
(lz-compress-error encoder))
ret)))))
(define lz-compress-sync-flush
(let ((proc (lzlib-procedure int "LZ_compress_sync_flush" (list '*))))
(lambda (encoder)
"Make available to `lz-compress-read' all the data already written with
the `LZ-compress-write' function. First call `lz-compress-sync-flush'. Then
call 'lz-compress-read' until it returns 0.
Repeated use of `LZ-compress-sync-flush' may degrade compression ratio,
so use it only when needed. "
(let ((ret (proc (lz-encoder->pointer encoder))))
(if (= ret -1)
(throw 'lzlib-error 'lz-compress-sync-flush
(lz-compress-error encoder))
ret)))))
(define lz-compress-read
(let ((proc (lzlib-procedure int "LZ_compress_read" (list '* '* int))))
(lambda* (encoder lzfile-bv #:optional (start 0) (count (bytevector-length lzfile-bv)))
"Read up to COUNT bytes from the encoder stream, storing the results in LZFILE-BV.
Return the number of uncompressed bytes written, a positive integer."
(let ((ret (proc (lz-encoder->pointer encoder)
(bytevector->pointer lzfile-bv start)
count)))
(if (= ret -1)
(throw 'lzlib-error 'lz-compress-read (lz-compress-error encoder))
ret)))))
(define lz-compress-write
(let ((proc (lzlib-procedure int "LZ_compress_write" (list '* '* int))))
(lambda* (encoder bv #:optional (start 0) (count (bytevector-length bv)))
"Write up to COUNT bytes from BV to the encoder stream. Return the
number of uncompressed bytes written, a strictly positive integer."
(let ((ret (proc (lz-encoder->pointer encoder)
(bytevector->pointer bv start)
count)))
(if (< ret 0)
(throw 'lzlib-error 'lz-compress-write (lz-compress-error encoder))
ret)))))
(define lz-compress-write-size
(let ((proc (lzlib-procedure int "LZ_compress_write_size" '(*))))
(lambda (encoder)
"The maximum number of bytes that can be immediately written through the
`lz-compress-write' function.
It is guaranteed that an immediate call to `lz-compress-write' will accept a
SIZE up to the returned number of bytes. "
(let ((ret (proc (lz-encoder->pointer encoder))))
(if (= ret -1)
(throw 'lzlib-error 'lz-compress-write-size (lz-compress-error encoder))
ret)))))
(define lz-compress-error
(let ((proc (lzlib-procedure int "LZ_compress_errno" '(*))))
(lambda (encoder)
"ENCODER can be a Scheme object or a pointer."
(let* ((error-number (proc (if (lz-encoder? encoder)
(lz-encoder->pointer encoder)
encoder))))
error-number))))
(define lz-compress-finished?
(let ((proc (lzlib-procedure int "LZ_compress_finished" '(*))))
(lambda (encoder)
"Return #t if all the data have been read and `lz-compress-close' can
be safely called. Otherwise return #f."
(let ((ret (proc (lz-encoder->pointer encoder))))
(match ret
(1 #t)
(0 #f)
(_ (throw 'lzlib-error 'lz-compress-finished? (lz-compress-error encoder))))))))
(define lz-compress-member-finished?
(let ((proc (lzlib-procedure int "LZ_compress_member_finished" '(*))))
(lambda (encoder)
"Return #t if the current member, in a multimember data stream, has
been fully read and 'lz-compress-restart-member' can be safely called.
Otherwise return #f."
(let ((ret (proc (lz-encoder->pointer encoder))))
(match ret
(1 #t)
(0 #f)
(_ (throw 'lzlib-error 'lz-compress-member-finished? (lz-compress-error encoder))))))))
(define lz-compress-data-position
(let ((proc (lzlib-procedure uint64 "LZ_compress_data_position" '(*))))
(lambda (encoder)
"Return the number of input bytes already compressed in the current
member."
(let ((ret (proc (lz-encoder->pointer encoder))))
(if (= ret -1)
(throw 'lzlib-error 'lz-compress-data-position
(lz-compress-error encoder))
ret)))))
(define lz-compress-member-position
(let ((proc (lzlib-procedure uint64 "LZ_compress_member_position" '(*))))
(lambda (encoder)
"Return the number of compressed bytes already produced, but perhaps
not yet read, in the current member."
(let ((ret (proc (lz-encoder->pointer encoder))))
(if (= ret -1)
(throw 'lzlib-error 'lz-compress-member-position
(lz-compress-error encoder))
ret)))))
(define lz-compress-total-in-size
(let ((proc (lzlib-procedure uint64 "LZ_compress_total_in_size" '(*))))
(lambda (encoder)
"Return the total number of input bytes already compressed."
(let ((ret (proc (lz-encoder->pointer encoder))))
(if (= ret -1)
(throw 'lzlib-error 'lz-compress-total-in-size
(lz-compress-error encoder))
ret)))))
(define lz-compress-total-out-size
(let ((proc (lzlib-procedure uint64 "LZ_compress_total_out_size" '(*))))
(lambda (encoder)
"Return the total number of compressed bytes already produced, but
perhaps not yet read."
(let ((ret (proc (lz-encoder->pointer encoder))))
(if (= ret -1)
(throw 'lzlib-error 'lz-compress-total-out-size
(lz-compress-error encoder))
ret)))))
;; Decompression bindings.
(define lz-decompress-open
(let ((proc (lzlib-procedure '* "LZ_decompress_open" '())))
(lambda ()
"Initializes the internal stream state for decompression and returns a
pointer that can only be used as the decoder argument for the other
lz-decompress functions, or a null pointer if the decoder could not be
allocated.
See the manual: (lzlib) Decompression functions."
(let ((decoder-ptr (proc)))
(if (not (= (lz-decompress-error decoder-ptr) -1))
(pointer->lz-decoder decoder-ptr)
(throw 'lzlib-error 'lz-decompress-open))))))
(define lz-decompress-close
(let ((proc (lzlib-procedure int "LZ_decompress_close" '(*))))
(lambda (decoder)
"Close decoder. DECODER can no longer be used as an argument to any
lz-decompress function. "
(let ((ret (proc (lz-decoder->pointer decoder))))
(if (= ret -1)
(throw 'lzlib-error 'lz-decompress-close ret)
ret)))))
(define lz-decompress-finish
(let ((proc (lzlib-procedure int "LZ_decompress_finish" '(*))))
(lambda (decoder)
"Tell that all the data for this stream have already been written (with
the `lz-decompress-write' function). It is safe to call
`lz-decompress-finish' as many times as needed."
(let ((ret (proc (lz-decoder->pointer decoder))))
(if (= ret -1)
(throw 'lzlib-error 'lz-decompress-finish (lz-decompress-error decoder))
ret)))))
(define lz-decompress-reset
(let ((proc (lzlib-procedure int "LZ_decompress_reset" '(*))))
(lambda (decoder)
"Reset the internal state of DECODER as it was just after opening it
with the `lz-decompress-open' function. Data stored in the internal buffers
is discarded. Position counters are set to 0."
(let ((ret (proc (lz-decoder->pointer decoder))))
(if (= ret -1)
(throw 'lzlib-error 'lz-decompress-reset
(lz-decompress-error decoder))
ret)))))
(define lz-decompress-sync-to-member
(let ((proc (lzlib-procedure int "LZ_decompress_sync_to_member" '(*))))
(lambda (decoder)
"Reset the error state of DECODER and enters a search state that lasts
until a new member header (or the end of the stream) is found. After a
successful call to `lz-decompress-sync-to-member', data written with
`lz-decompress-write' will be consumed and 'lz-decompress-read' will return 0
until a header is found.
This function is useful to discard any data preceding the first member, or to
discard the rest of the current member, for example in case of a data
error. If the decoder is already at the beginning of a member, this function
does nothing."
(let ((ret (proc (lz-decoder->pointer decoder))))
(if (= ret -1)
(throw 'lzlib-error 'lz-decompress-sync-to-member
(lz-decompress-error decoder))
ret)))))
(define lz-decompress-read
(let ((proc (lzlib-procedure int "LZ_decompress_read" (list '* '* int))))
(lambda* (decoder file-bv #:optional (start 0) (count (bytevector-length file-bv)))
"Read up to COUNT bytes from the decoder stream, storing the results in FILE-BV.
Return the number of uncompressed bytes written, a non-negative positive integer."
(let ((ret (proc (lz-decoder->pointer decoder)
(bytevector->pointer file-bv start)
count)))
(if (< ret 0)
(throw 'lzlib-error 'lz-decompress-read (lz-decompress-error decoder))
ret)))))
(define lz-decompress-write
(let ((proc (lzlib-procedure int "LZ_decompress_write" (list '* '* int))))
(lambda* (decoder bv #:optional (start 0) (count (bytevector-length bv)))
"Write up to COUNT bytes from BV to the decoder stream. Return the
number of uncompressed bytes written, a non-negative integer."
(let ((ret (proc (lz-decoder->pointer decoder)
(bytevector->pointer bv start)
count)))
(if (< ret 0)
(throw 'lzlib-error 'lz-decompress-write (lz-decompress-error decoder))
ret)))))
(define lz-decompress-write-size
(let ((proc (lzlib-procedure int "LZ_decompress_write_size" '(*))))
(lambda (decoder)
"Return the maximum number of bytes that can be immediately written
through the `lz-decompress-write' function.
It is guaranteed that an immediate call to `lz-decompress-write' will accept a
SIZE up to the returned number of bytes. "
(let ((ret (proc (lz-decoder->pointer decoder))))
(if (= ret -1)
(throw 'lzlib-error 'lz-decompress-write-size (lz-decompress-error decoder))
ret)))))
(define lz-decompress-error
(let ((proc (lzlib-procedure int "LZ_decompress_errno" '(*))))
(lambda (decoder)
"DECODER can be a Scheme object or a pointer."
(let* ((error-number (proc (if (lz-decoder? decoder)
(lz-decoder->pointer decoder)
decoder))))
error-number))))
(define lz-decompress-finished?
(let ((proc (lzlib-procedure int "LZ_decompress_finished" '(*))))
(lambda (decoder)
"Return #t if all the data have been read and `lz-decompress-close' can
be safely called. Otherwise return #f."
(let ((ret (proc (lz-decoder->pointer decoder))))
(match ret
(1 #t)
(0 #f)
(_ (throw 'lzlib-error 'lz-decompress-finished? (lz-decompress-error decoder))))))))
(define lz-decompress-member-finished?
(let ((proc (lzlib-procedure int "LZ_decompress_member_finished" '(*))))
(lambda (decoder)
"Return #t if the current member, in a multimember data stream, has
been fully read and `lz-decompress-restart-member' can be safely called.
Otherwise return #f."
(let ((ret (proc (lz-decoder->pointer decoder))))
(match ret
(1 #t)
(0 #f)
(_ (throw 'lzlib-error 'lz-decompress-member-finished? (lz-decompress-error decoder))))))))
(define lz-decompress-member-version
(let ((proc (lzlib-procedure int "LZ_decompress_member_version" '(*))))
(lambda (decoder)
(let ((ret (proc (lz-decoder->pointer decoder))))
"Return the version of current member from member header."
(if (= ret -1)
(throw 'lzlib-error 'lz-decompress-data-position
(lz-decompress-error decoder))
ret)))))
(define lz-decompress-dictionary-size
(let ((proc (lzlib-procedure int "LZ_decompress_dictionary_size" '(*))))
(lambda (decoder)
(let ((ret (proc (lz-decoder->pointer decoder))))
"Return the dictionary size of current member from member header."
(if (= ret -1)
(throw 'lzlib-error 'lz-decompress-member-position
(lz-decompress-error decoder))
ret)))))
(define lz-decompress-data-crc
(let ((proc (lzlib-procedure unsigned-int "LZ_decompress_data_crc" '(*))))
(lambda (decoder)
(let ((ret (proc (lz-decoder->pointer decoder))))
"Return the 32 bit Cyclic Redundancy Check of the data decompressed
from the current member. The returned value is valid only when
`lz-decompress-member-finished' returns #t. "
(if (= ret -1)
(throw 'lzlib-error 'lz-decompress-member-position
(lz-decompress-error decoder))
ret)))))
(define lz-decompress-data-position
(let ((proc (lzlib-procedure uint64 "LZ_decompress_data_position" '(*))))
(lambda (decoder)
"Return the number of decompressed bytes already produced, but perhaps
not yet read, in the current member."
(let ((ret (proc (lz-decoder->pointer decoder))))
(if (= ret -1)
(throw 'lzlib-error 'lz-decompress-data-position
(lz-decompress-error decoder))
ret)))))
(define lz-decompress-member-position
(let ((proc (lzlib-procedure uint64 "LZ_decompress_member_position" '(*))))
(lambda (decoder)
"Return the number of input bytes already decompressed in the current
member."
(let ((ret (proc (lz-decoder->pointer decoder))))
(if (= ret -1)
(throw 'lzlib-error 'lz-decompress-member-position
(lz-decompress-error decoder))
ret)))))
(define lz-decompress-total-in-size
(let ((proc (lzlib-procedure uint64 "LZ_decompress_total_in_size" '(*))))
(lambda (decoder)
(let ((ret (proc (lz-decoder->pointer decoder))))
"Return the total number of input bytes already compressed."
(if (= ret -1)
(throw 'lzlib-error 'lz-decompress-total-in-size
(lz-decompress-error decoder))
ret)))))
(define lz-decompress-total-out-size
(let ((proc (lzlib-procedure uint64 "LZ_decompress_total_out_size" '(*))))
(lambda (decoder)
(let ((ret (proc (lz-decoder->pointer decoder))))
"Return the total number of compressed bytes already produced, but
perhaps not yet read."
(if (= ret -1)
(throw 'lzlib-error 'lz-decompress-total-out-size
(lz-decompress-error decoder))
ret)))))
;; High level functions.
(define* (lzread! decoder port bv
#:optional (start 0) (count (bytevector-length bv)))
"Read up to COUNT bytes from PORT into BV at offset START. Return the
number of uncompressed bytes actually read; it is zero if COUNT is zero or if
the end-of-stream has been reached."
(define (feed-decoder! decoder)
;; Feed DECODER with data read from PORT.
(match (get-bytevector-n port (lz-decompress-write-size decoder))
((? eof-object? eof) eof)
(bv (lz-decompress-write decoder bv))))
(let loop ((read 0)
(start start))
(cond ((< read count)
(match (lz-decompress-read decoder bv start (- count read))
(0 (cond ((lz-decompress-finished? decoder)
read)
((eof-object? (feed-decoder! decoder))
(lz-decompress-finish decoder)
(loop read start))
(else ;read again
(loop read start))))
(n (loop (+ read n) (+ start n)))))
(else
read))))
(define (lzwrite! encoder source source-offset source-count
target target-offset target-count)
"Write up to SOURCE-COUNT bytes from SOURCE to ENCODER, and read up to
TARGET-COUNT bytes into TARGET at TARGET-OFFSET. Return two values: the
number of bytes read from SOURCE, and the number of bytes written to TARGET,
possibly zero."
(define read
(if (> (lz-compress-write-size encoder) 0)
(match (lz-compress-write encoder source source-offset source-count)
(0 (lz-compress-finish encoder) 0)
(n n))
0))
(define written
(lz-compress-read encoder target target-offset target-count))
(values read written))
(define* (lzwrite encoder bv lz-port
#:optional (start 0) (count (bytevector-length bv)))
"Write up to COUNT bytes from BV at offset START into LZ-PORT. Return
the number of uncompressed bytes written, a non-negative integer."
(let ((written 0)
(read 0))
(while (and (< 0 (lz-compress-write-size encoder))
(< written count))
(set! written (+ written
(lz-compress-write encoder bv (+ start written) (- count written)))))
(when (= written 0)
(lz-compress-finish encoder))
(let ((lz-bv (make-bytevector written)))
(let loop ((rd 0))
(set! rd (lz-compress-read encoder lz-bv 0 (bytevector-length lz-bv)))
(put-bytevector lz-port lz-bv 0 rd)
(set! read (+ read rd))
(unless (= rd 0)
(loop rd))))
;; `written' is the total byte count of uncompressed data.
written))
;;;
;;; Port interface.
;;;
;; Alist of (levels (dictionary-size match-length-limit)). 0 is the fastest.
;; See bbexample.c in lzlib's source.
(define %compression-levels
`((0 65535 16)
(1 ,(bitwise-arithmetic-shift-left 1 20) 5)
(2 ,(bitwise-arithmetic-shift-left 3 19) 6)
(3 ,(bitwise-arithmetic-shift-left 1 21) 8)
(4 ,(bitwise-arithmetic-shift-left 3 20) 12)
(5 ,(bitwise-arithmetic-shift-left 1 22) 20)
(6 ,(bitwise-arithmetic-shift-left 1 23) 36)
(7 ,(bitwise-arithmetic-shift-left 1 24) 68)
(8 ,(bitwise-arithmetic-shift-left 3 23) 132)
(9 ,(bitwise-arithmetic-shift-left 1 25) 273)))
(define %default-compression-level
6)
(define (dictionary-size+match-length-limit level)
"Return two values: the dictionary size for LEVEL, and its match-length
limit. LEVEL must be a compression level, an integer between 0 and 9."
(match (assv-ref %compression-levels level)
((dictionary-size match-length-limit)
(values dictionary-size match-length-limit))))
(define* (make-lzip-input-port port)
"Return an input port that decompresses data read from PORT, a file port.
PORT is automatically closed when the resulting port is closed."
(define decoder (lz-decompress-open))
(define (read! bv start count)
(lzread! decoder port bv start count))
(make-custom-binary-input-port "lzip-input" read! #f #f
(lambda ()
(lz-decompress-close decoder)
(close-port port))))
(define* (make-lzip-output-port port
#:key
(level %default-compression-level))
"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 encoder
(call-with-values (lambda () (dictionary-size+match-length-limit level))
lz-compress-open))
(define (write! bv start count)
(lzwrite encoder bv port start count))
(make-custom-binary-output-port "lzip-output" write! #f #f
(lambda ()
(lz-compress-finish encoder)
;; "lz-read" the trailing metadata added by `lz-compress-finish'.
(let ((lz-bv (make-bytevector (* 64 1024))))
(let loop ((rd 0))
(set! rd (lz-compress-read encoder lz-bv 0 (bytevector-length lz-bv)))
(put-bytevector port lz-bv 0 rd)
(unless (= rd 0)
(loop rd))))
(lz-compress-close encoder)
(close-port port))))
(define* (make-lzip-input-port/compressed port
#:key
(level %default-compression-level))
"Return an input port that compresses data read from PORT, with the given LEVEL.
PORT is automatically closed when the resulting port is closed."
(define encoder
(call-with-values (lambda () (dictionary-size+match-length-limit level))
lz-compress-open))
(define input-buffer (make-bytevector 8192))
(define input-len 0)
(define input-offset 0)
(define input-eof? #f)
(define (read! bv start count)
(cond
(input-eof?
(match (lz-compress-read encoder bv start count)
(0 (if (lz-compress-finished? encoder)
0
(read! bv start count)))
(n n)))
((= input-offset input-len)
(match (get-bytevector-n! port input-buffer 0
(bytevector-length input-buffer))
((? eof-object?)
(set! input-eof? #t)
(lz-compress-finish encoder))
(count
(set! input-offset 0)
(set! input-len count)))
(read! bv start count))
(else
(let-values (((read written)
(lzwrite! encoder
input-buffer input-offset
(- input-len input-offset)
bv start count)))
(set! input-offset (+ input-offset read))
;; Make sure we don't return zero except on EOF.
(if (= 0 written)
(read! bv start count)
written)))))
(make-custom-binary-input-port "lzip-input/compressed"
read! #f #f
(lambda ()
(close-port port))))
(define* (call-with-lzip-input-port port proc)
"Call PROC with a port that wraps PORT and decompresses data read from it.
PORT is closed upon completion."
(let ((lzip (make-lzip-input-port port)))
(dynamic-wind
(const #t)
(lambda ()
(proc lzip))
(lambda ()
(close-port lzip)))))
(define* (call-with-lzip-output-port port proc
#:key
(level %default-compression-level))
"Call PROC with an output port that wraps PORT and compresses data. PORT is
close upon completion."
(let ((lzip (make-lzip-output-port port
#:level level)))
(dynamic-wind
(const #t)
(lambda ()
(proc lzip))
(lambda ()
(close-port lzip)))))
;;; lzlib.scm ends here

2
guix/man-db.scm
View File

@ -17,7 +17,7 @@
;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>. ;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
(define-module (guix man-db) (define-module (guix man-db)
#:use-module (guix zlib) #:use-module (zlib)
#:use-module ((guix build utils) #:select (find-files)) #:use-module ((guix build utils) #:select (find-files))
#:use-module (gdbm) ;gdbm-ffi #:use-module (gdbm) ;gdbm-ffi
#:use-module (srfi srfi-9) #:use-module (srfi srfi-9)

23
guix/profiles.scm
View File

@ -1412,27 +1412,18 @@ the entries in MANIFEST."
(module-ref (resolve-interface '(gnu packages guile)) (module-ref (resolve-interface '(gnu packages guile))
'guile-gdbm-ffi)) 'guile-gdbm-ffi))
(define zlib (define guile-zlib
(module-ref (resolve-interface '(gnu packages compression)) 'zlib)) (module-ref (resolve-interface '(gnu packages guile)) 'guile-zlib))
(define config.scm
(scheme-file "config.scm"
#~(begin
(define-module #$'(guix config) ;placate Geiser
#:export (%libz))
(define %libz
#+(file-append zlib "/lib/libz")))))
(define modules (define modules
(cons `((guix config) => ,config.scm) (delete '(guix config)
(delete '(guix config) (source-module-closure `((guix build utils)
(source-module-closure `((guix build utils) (guix man-db)))))
(guix man-db))))))
(define build (define build
(with-imported-modules modules (with-imported-modules modules
(with-extensions (list gdbm-ffi) ;for (guix man-db) (with-extensions (list gdbm-ffi ;for (guix man-db)
guile-zlib)
#~(begin #~(begin
(use-modules (guix man-db) (use-modules (guix man-db)
(guix build utils) (guix build utils)

15
guix/scripts/publish.scm
View File

@ -50,10 +50,9 @@
#:use-module (guix workers) #:use-module (guix workers)
#:use-module (guix store) #:use-module (guix store)
#:use-module ((guix serialization) #:select (write-file)) #:use-module ((guix serialization) #:select (write-file))
#:use-module (guix zlib) #:use-module (zlib)
#:autoload (guix lzlib) (lzlib-available? #:autoload (lzlib) (call-with-lzip-output-port
call-with-lzip-output-port make-lzip-output-port)
make-lzip-output-port)
#:use-module (guix cache) #:use-module (guix cache)
#:use-module (guix ui) #:use-module (guix ui)
#:use-module (guix scripts) #:use-module (guix scripts)
@ -880,8 +879,8 @@ blocking."
"Return a symbol denoting the compression method expressed by STRING; return "Return a symbol denoting the compression method expressed by STRING; return
#f if STRING doesn't match any supported method." #f if STRING doesn't match any supported method."
(match string (match string
("gzip" (and (zlib-available?) 'gzip)) ("gzip" 'gzip)
("lzip" (and (lzlib-available?) 'lzip)) ("lzip" 'lzip)
(_ #f))) (_ #f)))
(define (effective-compression requested-type compressions) (define (effective-compression requested-type compressions)
@ -1032,9 +1031,7 @@ methods, return the applicable compression."
opts) opts)
(() (()
;; Default to fast & low compression. ;; Default to fast & low compression.
(list (if (zlib-available?) (list %default-gzip-compression))
%default-gzip-compression
%no-compression)))
(lst (reverse lst)))) (lst (reverse lst))))
(address (let ((addr (assoc-ref opts 'address))) (address (let ((addr (assoc-ref opts 'address)))
(make-socket-address (sockaddr:fam addr) (make-socket-address (sockaddr:fam addr)

3
guix/scripts/substitute.scm
View File

@ -41,7 +41,6 @@
#:use-module (guix progress) #:use-module (guix progress)
#:use-module ((guix build syscalls) #:use-module ((guix build syscalls)
#:select (set-thread-name)) #:select (set-thread-name))
#:autoload (guix lzlib) (lzlib-available?)
#:use-module (ice-9 rdelim) #:use-module (ice-9 rdelim)
#:use-module (ice-9 regex) #:use-module (ice-9 regex)
#:use-module (ice-9 match) #:use-module (ice-9 match)
@ -912,7 +911,7 @@ authorized substitutes."
;; Known compression methods and a thunk to determine whether they're ;; Known compression methods and a thunk to determine whether they're
;; supported. See 'decompressed-port' in (guix utils). ;; supported. See 'decompressed-port' in (guix utils).
`(("gzip" . ,(const #t)) `(("gzip" . ,(const #t))
("lzip" . ,lzlib-available?) ("lzip" . ,(const #t))
("xz" . ,(const #t)) ("xz" . ,(const #t))
("bzip2" . ,(const #t)) ("bzip2" . ,(const #t))
("none" . ,(const #t)))) ("none" . ,(const #t))))

32
guix/self.scm
View File

@ -53,10 +53,10 @@
("guile-ssh" (ref '(gnu packages ssh) 'guile-ssh)) ("guile-ssh" (ref '(gnu packages ssh) 'guile-ssh))
("guile-git" (ref '(gnu packages guile) 'guile-git)) ("guile-git" (ref '(gnu packages guile) 'guile-git))
("guile-sqlite3" (ref '(gnu packages guile) 'guile-sqlite3)) ("guile-sqlite3" (ref '(gnu packages guile) 'guile-sqlite3))
("guile-zlib" (ref '(gnu packages guile) 'guile-zlib))
("guile-lzlib" (ref '(gnu packages guile) 'guile-lzlib))
("guile-gcrypt" (ref '(gnu packages gnupg) 'guile-gcrypt)) ("guile-gcrypt" (ref '(gnu packages gnupg) 'guile-gcrypt))
("gnutls" (ref '(gnu packages tls) 'guile3.0-gnutls)) ("gnutls" (ref '(gnu packages tls) 'guile3.0-gnutls))
("zlib" (ref '(gnu packages compression) 'zlib))
("lzlib" (ref '(gnu packages compression) 'lzlib))
("gzip" (ref '(gnu packages compression) 'gzip)) ("gzip" (ref '(gnu packages compression) 'gzip))
("bzip2" (ref '(gnu packages compression) 'bzip2)) ("bzip2" (ref '(gnu packages compression) 'bzip2))
("xz" (ref '(gnu packages compression) 'xz)) ("xz" (ref '(gnu packages compression) 'xz))
@ -727,8 +727,6 @@ Info manual."
(name (string-append "guix-" version)) (name (string-append "guix-" version))
(guile-version (effective-version)) (guile-version (effective-version))
(guile-for-build (default-guile)) (guile-for-build (default-guile))
(zlib (specification->package "zlib"))
(lzlib (specification->package "lzlib"))
(gzip (specification->package "gzip")) (gzip (specification->package "gzip"))
(bzip2 (specification->package "bzip2")) (bzip2 (specification->package "bzip2"))
(xz (specification->package "xz")) (xz (specification->package "xz"))
@ -746,6 +744,12 @@ Info manual."
(define guile-sqlite3 (define guile-sqlite3
(specification->package "guile-sqlite3")) (specification->package "guile-sqlite3"))
(define guile-zlib
(specification->package "guile-zlib"))
(define guile-lzlib
(specification->package "guile-lzlib"))
(define guile-gcrypt (define guile-gcrypt
(specification->package "guile-gcrypt")) (specification->package "guile-gcrypt"))
@ -757,7 +761,7 @@ Info manual."
(cons (list "x" package) (cons (list "x" package)
(package-transitive-propagated-inputs package))) (package-transitive-propagated-inputs package)))
(list guile-gcrypt gnutls guile-git guile-json (list guile-gcrypt gnutls guile-git guile-json
guile-ssh guile-sqlite3)) guile-ssh guile-sqlite3 guile-zlib guile-lzlib))
(((labels packages _ ...) ...) (((labels packages _ ...) ...)
packages))) packages)))
@ -884,9 +888,7 @@ Info manual."
'() '()
#:extra-modules #:extra-modules
`(((guix config) `(((guix config)
=> ,(make-config.scm #:zlib zlib => ,(make-config.scm #:gzip gzip
#:lzlib lzlib
#:gzip gzip
#:bzip2 bzip2 #:bzip2 bzip2
#:xz xz #:xz xz
#:package-name #:package-name
@ -983,7 +985,7 @@ Info manual."
(variables rest ...)))))) (variables rest ...))))))
(variables %localstatedir %storedir %sysconfdir))) (variables %localstatedir %storedir %sysconfdir)))
(define* (make-config.scm #:key zlib lzlib gzip xz bzip2 (define* (make-config.scm #:key gzip xz bzip2
(package-name "GNU Guix") (package-name "GNU Guix")
(package-version "0") (package-version "0")
(bug-report-address "bug-guix@gnu.org") (bug-report-address "bug-guix@gnu.org")
@ -1004,8 +1006,6 @@ Info manual."
%state-directory %state-directory
%store-database-directory %store-database-directory
%config-directory %config-directory
%libz
%liblz
%gzip %gzip
%bzip2 %bzip2
%xz)) %xz))
@ -1048,15 +1048,7 @@ Info manual."
(define %bzip2 (define %bzip2
#+(and bzip2 (file-append bzip2 "/bin/bzip2"))) #+(and bzip2 (file-append bzip2 "/bin/bzip2")))
(define %xz (define %xz
#+(and xz (file-append xz "/bin/xz"))) #+(and xz (file-append xz "/bin/xz"))))
(define %libz
#+(and zlib
(file-append zlib "/lib/libz")))
(define %liblz
#+(and lzlib
(file-append lzlib "/lib/liblz"))))
;; Guile 2.0 *requires* the 'define-module' to be at the ;; Guile 2.0 *requires* the 'define-module' to be at the
;; top-level or the 'toplevel-ref' in the resulting .go file are ;; top-level or the 'toplevel-ref' in the resulting .go file are

9
guix/utils.scm
View File

@ -208,13 +208,8 @@ buffered data is lost."
(define (lzip-port proc port . args) (define (lzip-port proc port . args)
"Return the lzip port produced by calling PROC (a symbol) on PORT and ARGS. "Return the lzip port produced by calling PROC (a symbol) on PORT and ARGS.
Raise an error if lzlib support is missing." Raise an error if lzlib support is missing."
(let* ((lzlib (false-if-exception (resolve-interface '(guix lzlib)))) (let ((make-port (module-ref (resolve-interface '(lzlib)) proc)))
(supported? (and lzlib (values (make-port port) '())))
((module-ref lzlib 'lzlib-available?)))))
(if supported?
(let ((make-port (module-ref lzlib proc)))
(values (make-port port) '()))
(error "lzip compression not supported" lzlib))))
(define (decompressed-port compression input) (define (decompressed-port compression input)
"Return an input port where INPUT is decompressed according to COMPRESSION, "Return an input port where INPUT is decompressed according to COMPRESSION,

241
guix/zlib.scm
View File

@ -1,241 +0,0 @@
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2016, 2017 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; it is zero if COUNT is zero or if
the end-of-stream has been reached."
(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* (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. An error is thrown if PORT contains
buffered input, which would be lost (and is lost anyway)."
(define gzfile
(match (drain-input port)
("" ;PORT's buffer is empty
;; 'gzclose' will eventually close the file descriptor beneath PORT.
;; 'close-port' on PORT would get EBADF if 'gzclose' already closed it,
;; so that's no good; revealed ports are no good either because they
;; leak (see <https://bugs.gnu.org/28784>); calling 'close-port' after
;; 'gzclose' doesn't work either because it leads to a race condition
;; (see <https://bugs.gnu.org/29335>). So we dup and close PORT right
;; away.
(gzdopen (dup (fileno port)) "r"))
(_
;; This is unrecoverable but it's better than having the buffered input
;; be lost, leading to unclear end-of-file or corrupt-data errors down
;; the path.
(throw 'zlib-error 'make-gzip-input-port
"port contains buffered input" port))))
(define (read! bv start count)
(gzread! gzfile bv start count))
(unless (= buffer-size %default-buffer-size)
(gzbuffer! gzfile buffer-size))
(close-port port) ;we no longer need it
(make-custom-binary-input-port "gzip-input" read! #f #f
(lambda ()
(gzclose gzfile))))
(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
(begin
(force-output port) ;empty PORT's buffer
(gzdopen (dup (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))
(close-port port)
(make-custom-binary-output-port "gzip-output" write! #f #f
(lambda ()
(gzclose gzfile))))
(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

26
m4/guix.m4
View File

@ -342,32 +342,6 @@ AC_DEFUN([GUIX_LIBGCRYPT_LIBDIR], [
$1="$guix_cv_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_LIBLZ_FILE_NAME VAR
dnl
dnl Attempt to determine liblz's absolute file name; store the result in VAR.
AC_DEFUN([GUIX_LIBLZ_FILE_NAME], [
AC_REQUIRE([PKG_PROG_PKG_CONFIG])
AC_CACHE_CHECK([lzlib's file name],
[guix_cv_liblz_libdir],
[old_LIBS="$LIBS"
LIBS="-llz"
AC_LINK_IFELSE([AC_LANG_SOURCE([int main () { return LZ_decompress_open(); }])],
[guix_cv_liblz_libdir="`ldd conftest$EXEEXT | grep liblz | sed '-es/.*=> \(.*\) .*$/\1/g'`"])
LIBS="$old_LIBS"])
$1="$guix_cv_liblz_libdir"
])
dnl GUIX_CURRENT_LOCALSTATEDIR dnl GUIX_CURRENT_LOCALSTATEDIR
dnl dnl
dnl Determine the localstatedir of an existing Guix installation and set dnl Determine the localstatedir of an existing Guix installation and set

120
tests/lzlib.scm
View File

@ -1,120 +0,0 @@
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2019 Pierre Neidhardt <mail@ambrevar.xyz>
;;;
;;; 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-lzlib)
#:use-module (guix lzlib)
#: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 lzlib) module.
(define-syntax-rule (test-assert* description exp)
(begin
(unless (lzlib-available?)
(test-skip 1))
(test-assert description exp)))
(test-begin "lzlib")
(define (compress-and-decompress data)
"DATA must be a bytevector."
(pk "Uncompressed bytes:" (bytevector-length data))
(match (pipe)
((parent . child)
(match (primitive-fork)
(0 ;compress
(dynamic-wind
(const #t)
(lambda ()
(close-port parent)
(call-with-lzip-output-port child
(lambda (port)
(put-bytevector port data))))
(lambda ()
(primitive-exit 0))))
(pid ;decompress
(begin
(close-port child)
(let ((received (call-with-lzip-input-port parent
(lambda (port)
(get-bytevector-all port)))))
(match (waitpid pid)
((_ . status)
(pk "Status" status)
(pk "Length data" (bytevector-length data) "received" (bytevector-length received))
;; The following loop is a debug helper.
(let loop ((i 0))
(if (and (< i (bytevector-length received))
(= (bytevector-u8-ref received i)
(bytevector-u8-ref data i)))
(loop (+ 1 i))
(pk "First diff at index" i)))
(and (zero? status)
(port-closed? parent)
(bytevector=? received data)))))))))))
(test-assert* "null bytevector"
(compress-and-decompress (make-bytevector (+ (random 100000)
(* 20 1024)))))
(test-assert* "random bytevector"
(compress-and-decompress (random-bytevector (+ (random 100000)
(* 20 1024)))))
(test-assert* "small bytevector"
(compress-and-decompress (random-bytevector 127)))
(test-assert* "1 bytevector"
(compress-and-decompress (random-bytevector 1)))
(test-assert* "Bytevector of size relative to Lzip internal buffers (2 * dictionary)"
(compress-and-decompress
(random-bytevector
(* 2 (dictionary-size+match-length-limit %default-compression-level)))))
(test-assert* "Bytevector of size relative to Lzip internal buffers (64KiB)"
(compress-and-decompress (random-bytevector (* 64 1024))))
(test-assert* "Bytevector of size relative to Lzip internal buffers (64KiB-1)"
(compress-and-decompress (random-bytevector (1- (* 64 1024)))))
(test-assert* "Bytevector of size relative to Lzip internal buffers (64KiB+1)"
(compress-and-decompress (random-bytevector (1+ (* 64 1024)))))
(test-assert* "Bytevector of size relative to Lzip internal buffers (1MiB)"
(compress-and-decompress (random-bytevector (* 1024 1024))))
(test-assert* "Bytevector of size relative to Lzip internal buffers (1MiB-1)"
(compress-and-decompress (random-bytevector (1- (* 1024 1024)))))
(test-assert* "Bytevector of size relative to Lzip internal buffers (1MiB+1)"
(compress-and-decompress (random-bytevector (1+ (* 1024 1024)))))
(test-assert* "make-lzip-input-port/compressed"
(let* ((len (pk 'len (+ 10 (random 4000 %seed))))
(data (random-bytevector len))
(compressed (make-lzip-input-port/compressed
(open-bytevector-input-port data)))
(result (call-with-lzip-input-port compressed
get-bytevector-all)))
(pk (bytevector-length result) (bytevector-length data))
(bytevector=? result data)))
(test-end)

28
tests/publish.scm
View File

@ -35,8 +35,8 @@
#:use-module ((guix serialization) #:select (restore-file)) #:use-module ((guix serialization) #:select (restore-file))
#:use-module (gcrypt pk-crypto) #:use-module (gcrypt pk-crypto)
#:use-module ((guix pki) #:select (%public-key-file %private-key-file)) #:use-module ((guix pki) #:select (%public-key-file %private-key-file))
#:use-module (guix zlib) #:use-module (zlib)
#:use-module (guix lzlib) #:use-module (lzlib)
#:use-module (web uri) #:use-module (web uri)
#:use-module (web client) #:use-module (web client)
#:use-module (web response) #:use-module (web response)
@ -204,8 +204,6 @@ References: ~%"
(call-with-input-string nar (cut restore-file <> temp))) (call-with-input-string nar (cut restore-file <> temp)))
(call-with-input-file temp read-string)))) (call-with-input-file temp read-string))))
(unless (zlib-available?)
(test-skip 1))
(test-equal "/nar/gzip/*" (test-equal "/nar/gzip/*"
"bar" "bar"
(call-with-temporary-output-file (call-with-temporary-output-file
@ -217,8 +215,6 @@ References: ~%"
(cut restore-file <> temp))) (cut restore-file <> temp)))
(call-with-input-file temp read-string)))) (call-with-input-file temp read-string))))
(unless (zlib-available?)
(test-skip 1))
(test-equal "/nar/gzip/* is really gzip" (test-equal "/nar/gzip/* is really gzip"
%gzip-magic-bytes %gzip-magic-bytes
;; Since 'gzdopen' (aka. 'call-with-gzip-input-port') transparently reads ;; Since 'gzdopen' (aka. 'call-with-gzip-input-port') transparently reads
@ -229,8 +225,6 @@ References: ~%"
(string-append "/nar/gzip/" (basename %item)))))) (string-append "/nar/gzip/" (basename %item))))))
(get-bytevector-n nar (bytevector-length %gzip-magic-bytes)))) (get-bytevector-n nar (bytevector-length %gzip-magic-bytes))))
(unless (lzlib-available?)
(test-skip 1))
(test-equal "/nar/lzip/*" (test-equal "/nar/lzip/*"
"bar" "bar"
(call-with-temporary-output-file (call-with-temporary-output-file
@ -242,8 +236,6 @@ References: ~%"
(cut restore-file <> temp))) (cut restore-file <> temp)))
(call-with-input-file temp read-string)))) (call-with-input-file temp read-string))))
(unless (zlib-available?)
(test-skip 1))
(test-equal "/*.narinfo with compression" (test-equal "/*.narinfo with compression"
`(("StorePath" . ,%item) `(("StorePath" . ,%item)
("URL" . ,(string-append "nar/gzip/" (basename %item))) ("URL" . ,(string-append "nar/gzip/" (basename %item)))
@ -264,8 +256,6 @@ References: ~%"
(_ #f))) (_ #f)))
(recutils->alist body))))) (recutils->alist body)))))
(unless (lzlib-available?)
(test-skip 1))
(test-equal "/*.narinfo with lzip compression" (test-equal "/*.narinfo with lzip compression"
`(("StorePath" . ,%item) `(("StorePath" . ,%item)
("URL" . ,(string-append "nar/lzip/" (basename %item))) ("URL" . ,(string-append "nar/lzip/" (basename %item)))
@ -286,8 +276,6 @@ References: ~%"
(_ #f))) (_ #f)))
(recutils->alist body))))) (recutils->alist body)))))
(unless (zlib-available?)
(test-skip 1))
(test-equal "/*.narinfo for a compressed file" (test-equal "/*.narinfo for a compressed file"
'("none" "nar") ;compression-less nar '("none" "nar") ;compression-less nar
;; Assume 'guix publish -C' is already running on port 6799. ;; Assume 'guix publish -C' is already running on port 6799.
@ -300,8 +288,6 @@ References: ~%"
(list (assoc-ref info "Compression") (list (assoc-ref info "Compression")
(dirname (assoc-ref info "URL"))))) (dirname (assoc-ref info "URL")))))
(unless (and (zlib-available?) (lzlib-available?))
(test-skip 1))
(test-equal "/*.narinfo with lzip + gzip" (test-equal "/*.narinfo with lzip + gzip"
`((("StorePath" . ,%item) `((("StorePath" . ,%item)
("URL" . ,(string-append "nar/gzip/" (basename %item))) ("URL" . ,(string-append "nar/gzip/" (basename %item)))
@ -411,8 +397,6 @@ References: ~%"
(call-with-input-string "" port-sha256)))))) (call-with-input-string "" port-sha256))))))
(response-code (http-get uri)))) (response-code (http-get uri))))
(unless (zlib-available?)
(test-skip 1))
(test-equal "with cache" (test-equal "with cache"
(list #t (list #t
`(("StorePath" . ,%item) `(("StorePath" . ,%item)
@ -469,8 +453,6 @@ References: ~%"
(stat:size (stat nar))) (stat:size (stat nar)))
(response-code uncompressed))))))))) (response-code uncompressed)))))))))
(unless (and (zlib-available?) (lzlib-available?))
(test-skip 1))
(test-equal "with cache, lzip + gzip" (test-equal "with cache, lzip + gzip"
'(200 200 404) '(200 200 404)
(call-with-temporary-directory (call-with-temporary-directory
@ -515,8 +497,6 @@ References: ~%"
(response-code (response-code
(http-get uncompressed)))))))))) (http-get uncompressed))))))))))
(unless (zlib-available?)
(test-skip 1))
(let ((item (add-text-to-store %store "fake-compressed-thing.tar.gz" (let ((item (add-text-to-store %store "fake-compressed-thing.tar.gz"
(random-text)))) (random-text))))
(test-equal "with cache, uncompressed" (test-equal "with cache, uncompressed"
@ -596,9 +576,7 @@ References: ~%"
(item (add-text-to-store %store "random" (random-text))) (item (add-text-to-store %store "random" (random-text)))
(part (store-path-hash-part item)) (part (store-path-hash-part item))
(url (string-append base part ".narinfo")) (url (string-append base part ".narinfo"))
(cached (string-append cache (cached (string-append cache "/gzip/"
(if (zlib-available?)
"/gzip/" "/none/")
(basename item) (basename item)
".narinfo")) ".narinfo"))
(response (http-get url))) (response (http-get url)))

4
tests/substitute.scm
View File

@ -29,7 +29,6 @@
#:use-module ((guix store) #:select (%store-prefix)) #:use-module ((guix store) #:select (%store-prefix))
#:use-module ((guix ui) #:select (guix-warning-port)) #:use-module ((guix ui) #:select (guix-warning-port))
#:use-module ((guix utils) #:select (call-with-compressed-output-port)) #:use-module ((guix utils) #:select (call-with-compressed-output-port))
#:use-module ((guix lzlib) #:select (lzlib-available?))
#:use-module ((guix build utils) #:use-module ((guix build utils)
#:select (mkdir-p delete-file-recursively dump-port)) #:select (mkdir-p delete-file-recursively dump-port))
#:use-module (guix tests http) #:use-module (guix tests http)
@ -508,8 +507,7 @@ System: mips64el-linux\n")))
(let ((nar (string-append %main-substitute-directory (let ((nar (string-append %main-substitute-directory
"/example.nar"))) "/example.nar")))
(compress nar (string-append nar ".gz") 'gzip) (compress nar (string-append nar ".gz") 'gzip)
(when (lzlib-available?) (compress nar (string-append nar ".lz") 'lzip))
(compress nar (string-append nar ".lz") 'lzip)))
(parameterize ((substitute-urls (parameterize ((substitute-urls
(list (string-append "file://" (list (string-append "file://"

3
tests/utils.scm
View File

@ -23,7 +23,6 @@
#:use-module (guix utils) #:use-module (guix utils)
#:use-module ((guix store) #:select (%store-prefix store-path-package-name)) #:use-module ((guix store) #:select (%store-prefix store-path-package-name))
#:use-module ((guix search-paths) #:select (string-tokenize*)) #:use-module ((guix search-paths) #:select (string-tokenize*))
#:use-module ((guix lzlib) #:select (lzlib-available?))
#:use-module (srfi srfi-1) #:use-module (srfi srfi-1)
#:use-module (srfi srfi-11) #:use-module (srfi srfi-11)
#:use-module (srfi srfi-64) #:use-module (srfi srfi-64)
@ -215,7 +214,7 @@ skip these tests."
(for-each test-compression/decompression (for-each test-compression/decompression
'(gzip xz lzip) '(gzip xz lzip)
(list (const #t) (const #t) lzlib-available?)) (list (const #t) (const #t) (const #t)))
;; This is actually in (guix store). ;; This is actually in (guix store).
(test-equal "store-path-package-name" (test-equal "store-path-package-name"

62
tests/zlib.scm
View File

@ -1,62 +0,0 @@
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2016, 2019 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.
(test-begin "zlib")
(unless (zlib-available?)
(test-skip 1))
(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)