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

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

@ -71,7 +71,7 @@
(variables rest ...))))))
(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-version "0")
(bug-report-address "bug-guix@gnu.org")
@ -133,11 +133,7 @@
(define %bzip2
#+(and bzip2 (file-append bzip2 "/bin/bzip2")))
(define %xz
#+(and xz (file-append xz "/bin/xz")))
(define %libz
#+(and zlib
(file-append zlib "/lib/libz")))))))
#+(and xz (file-append xz "/bin/xz")))))))
;;;

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.])
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.
GUILE_MODULE_AVAILABLE([have_guile_newt], [(newt)])
@ -245,27 +257,6 @@ esac
AC_SUBST([LIBGCRYPT_PREFIX])
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.
GUIX_CHECK_GUILE_SSH
AM_CONDITIONAL([HAVE_GUILE_SSH],

3
doc/guix.texi
View File

@ -778,12 +778,13 @@ Guile,, gnutls-guile, GnuTLS-Guile});
@item
@uref{https://notabug.org/guile-sqlite3/guile-sqlite3, Guile-SQLite3}, version 0.1.0
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
@c FIXME: Specify a version number once a release has been made.
@uref{https://gitlab.com/guile-git/guile-git, Guile-Git}, from August
2017 or later;
@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}.
@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"))
(json (assoc-ref inputs "guile-json"))
(sqlite (assoc-ref inputs "guile-sqlite3"))
(zlib (assoc-ref inputs "guile-zlib"))
(lzlib (assoc-ref inputs "guile-lzlib"))
(git (assoc-ref inputs "guile-git"))
(bs (assoc-ref inputs
"guile-bytestructures"))
@ -286,7 +288,7 @@ $(prefix)/etc/init.d\n")))
(gnutls (assoc-ref inputs "gnutls"))
(locales (assoc-ref inputs "glibc-utf8-locales"))
(deps (list gcrypt json sqlite gnutls
git bs ssh))
git bs ssh zlib lzlib))
(effective
(read-line
(open-pipe* OPEN_READ
@ -326,6 +328,8 @@ $(prefix)/etc/init.d\n")))
("guile-gcrypt" ,guile-gcrypt)
("guile-json" ,guile-json-4)
("guile-sqlite3" ,guile-sqlite3)
("guile-zlib" ,guile-zlib)
("guile-lzlib" ,guile-lzlib)
("guile-ssh" ,guile-ssh)
("guile-git" ,guile-git)
@ -342,9 +346,6 @@ $(prefix)/etc/init.d\n")))
(inputs
`(("bzip2" ,bzip2)
("gzip" ,gzip)
("zlib" ,zlib) ;for 'guix publish'
("lzlib" ,lzlib) ;for 'guix publish' and 'guix substitute'
("sqlite" ,sqlite)
("libgcrypt" ,libgcrypt)
@ -378,7 +379,9 @@ $(prefix)/etc/init.d\n")))
("guile-json" ,guile-json-4)
("guile-sqlite3" ,guile-sqlite3)
("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/")
(synopsis "Functional package manager for installed software packages and versions")

8
guix/config.scm.in
View File

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

2
guix/gnu-maintenance.scm
View File

@ -36,7 +36,7 @@
#:use-module (guix records)
#:use-module (guix upstream)
#:use-module (guix packages)
#:use-module (guix zlib)
#:use-module (zlib)
#:export (gnu-package-name
gnu-package-mundane-name
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/>.
(define-module (guix man-db)
#:use-module (guix zlib)
#:use-module (zlib)
#:use-module ((guix build utils) #:select (find-files))
#:use-module (gdbm) ;gdbm-ffi
#:use-module (srfi srfi-9)

19
guix/profiles.scm
View File

@ -1412,27 +1412,18 @@ the entries in MANIFEST."
(module-ref (resolve-interface '(gnu packages guile))
'guile-gdbm-ffi))
(define zlib
(module-ref (resolve-interface '(gnu packages compression)) '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 guile-zlib
(module-ref (resolve-interface '(gnu packages guile)) 'guile-zlib))
(define modules
(cons `((guix config) => ,config.scm)
(delete '(guix config)
(source-module-closure `((guix build utils)
(guix man-db))))))
(guix man-db)))))
(define build
(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
(use-modules (guix man-db)
(guix build utils)

13
guix/scripts/publish.scm
View File

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

3
guix/scripts/substitute.scm
View File

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

32
guix/self.scm
View File

@ -53,10 +53,10 @@
("guile-ssh" (ref '(gnu packages ssh) 'guile-ssh))
("guile-git" (ref '(gnu packages guile) 'guile-git))
("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))
("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))
("bzip2" (ref '(gnu packages compression) 'bzip2))
("xz" (ref '(gnu packages compression) 'xz))
@ -727,8 +727,6 @@ Info manual."
(name (string-append "guix-" version))
(guile-version (effective-version))
(guile-for-build (default-guile))
(zlib (specification->package "zlib"))
(lzlib (specification->package "lzlib"))
(gzip (specification->package "gzip"))
(bzip2 (specification->package "bzip2"))
(xz (specification->package "xz"))
@ -746,6 +744,12 @@ Info manual."
(define guile-sqlite3
(specification->package "guile-sqlite3"))
(define guile-zlib
(specification->package "guile-zlib"))
(define guile-lzlib
(specification->package "guile-lzlib"))
(define guile-gcrypt
(specification->package "guile-gcrypt"))
@ -757,7 +761,7 @@ Info manual."
(cons (list "x" package)
(package-transitive-propagated-inputs package)))
(list guile-gcrypt gnutls guile-git guile-json
guile-ssh guile-sqlite3))
guile-ssh guile-sqlite3 guile-zlib guile-lzlib))
(((labels packages _ ...) ...)
packages)))
@ -884,9 +888,7 @@ Info manual."
'()
#:extra-modules
`(((guix config)
=> ,(make-config.scm #:zlib zlib
#:lzlib lzlib
#:gzip gzip
=> ,(make-config.scm #:gzip gzip
#:bzip2 bzip2
#:xz xz
#:package-name
@ -983,7 +985,7 @@ Info manual."
(variables rest ...))))))
(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-version "0")
(bug-report-address "bug-guix@gnu.org")
@ -1004,8 +1006,6 @@ Info manual."
%state-directory
%store-database-directory
%config-directory
%libz
%liblz
%gzip
%bzip2
%xz))
@ -1048,15 +1048,7 @@ Info manual."
(define %bzip2
#+(and bzip2 (file-append bzip2 "/bin/bzip2")))
(define %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"))))
#+(and xz (file-append xz "/bin/xz"))))
;; Guile 2.0 *requires* the 'define-module' to be at the
;; 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)
"Return the lzip port produced by calling PROC (a symbol) on PORT and ARGS.
Raise an error if lzlib support is missing."
(let* ((lzlib (false-if-exception (resolve-interface '(guix lzlib))))
(supported? (and lzlib
((module-ref lzlib 'lzlib-available?)))))
(if supported?
(let ((make-port (module-ref lzlib proc)))
(values (make-port port) '()))
(error "lzip compression not supported" lzlib))))
(let ((make-port (module-ref (resolve-interface '(lzlib)) proc)))
(values (make-port port) '())))
(define (decompressed-port compression input)
"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"
])
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
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 (gcrypt pk-crypto)
#:use-module ((guix pki) #:select (%public-key-file %private-key-file))
#:use-module (guix zlib)
#:use-module (guix lzlib)
#:use-module (zlib)
#:use-module (lzlib)
#:use-module (web uri)
#:use-module (web client)
#:use-module (web response)
@ -204,8 +204,6 @@ References: ~%"
(call-with-input-string nar (cut restore-file <> temp)))
(call-with-input-file temp read-string))))
(unless (zlib-available?)
(test-skip 1))
(test-equal "/nar/gzip/*"
"bar"
(call-with-temporary-output-file
@ -217,8 +215,6 @@ References: ~%"
(cut restore-file <> temp)))
(call-with-input-file temp read-string))))
(unless (zlib-available?)
(test-skip 1))
(test-equal "/nar/gzip/* is really gzip"
%gzip-magic-bytes
;; Since 'gzdopen' (aka. 'call-with-gzip-input-port') transparently reads
@ -229,8 +225,6 @@ References: ~%"
(string-append "/nar/gzip/" (basename %item))))))
(get-bytevector-n nar (bytevector-length %gzip-magic-bytes))))
(unless (lzlib-available?)
(test-skip 1))
(test-equal "/nar/lzip/*"
"bar"
(call-with-temporary-output-file
@ -242,8 +236,6 @@ References: ~%"
(cut restore-file <> temp)))
(call-with-input-file temp read-string))))
(unless (zlib-available?)
(test-skip 1))
(test-equal "/*.narinfo with compression"
`(("StorePath" . ,%item)
("URL" . ,(string-append "nar/gzip/" (basename %item)))
@ -264,8 +256,6 @@ References: ~%"
(_ #f)))
(recutils->alist body)))))
(unless (lzlib-available?)
(test-skip 1))
(test-equal "/*.narinfo with lzip compression"
`(("StorePath" . ,%item)
("URL" . ,(string-append "nar/lzip/" (basename %item)))
@ -286,8 +276,6 @@ References: ~%"
(_ #f)))
(recutils->alist body)))))
(unless (zlib-available?)
(test-skip 1))
(test-equal "/*.narinfo for a compressed file"
'("none" "nar") ;compression-less nar
;; Assume 'guix publish -C' is already running on port 6799.
@ -300,8 +288,6 @@ References: ~%"
(list (assoc-ref info "Compression")
(dirname (assoc-ref info "URL")))))
(unless (and (zlib-available?) (lzlib-available?))
(test-skip 1))
(test-equal "/*.narinfo with lzip + gzip"
`((("StorePath" . ,%item)
("URL" . ,(string-append "nar/gzip/" (basename %item)))
@ -411,8 +397,6 @@ References: ~%"
(call-with-input-string "" port-sha256))))))
(response-code (http-get uri))))
(unless (zlib-available?)
(test-skip 1))
(test-equal "with cache"
(list #t
`(("StorePath" . ,%item)
@ -469,8 +453,6 @@ References: ~%"
(stat:size (stat nar)))
(response-code uncompressed)))))))))
(unless (and (zlib-available?) (lzlib-available?))
(test-skip 1))
(test-equal "with cache, lzip + gzip"
'(200 200 404)
(call-with-temporary-directory
@ -515,8 +497,6 @@ References: ~%"
(response-code
(http-get uncompressed))))))))))
(unless (zlib-available?)
(test-skip 1))
(let ((item (add-text-to-store %store "fake-compressed-thing.tar.gz"
(random-text))))
(test-equal "with cache, uncompressed"
@ -596,9 +576,7 @@ References: ~%"
(item (add-text-to-store %store "random" (random-text)))
(part (store-path-hash-part item))
(url (string-append base part ".narinfo"))
(cached (string-append cache
(if (zlib-available?)
"/gzip/" "/none/")
(cached (string-append cache "/gzip/"
(basename item)
".narinfo"))
(response (http-get url)))

4
tests/substitute.scm
View File

@ -29,7 +29,6 @@
#:use-module ((guix store) #:select (%store-prefix))
#:use-module ((guix ui) #:select (guix-warning-port))
#:use-module ((guix utils) #:select (call-with-compressed-output-port))
#:use-module ((guix lzlib) #:select (lzlib-available?))
#:use-module ((guix build utils)
#:select (mkdir-p delete-file-recursively dump-port))
#:use-module (guix tests http)
@ -508,8 +507,7 @@ System: mips64el-linux\n")))
(let ((nar (string-append %main-substitute-directory
"/example.nar")))
(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
(list (string-append "file://"

3
tests/utils.scm
View File

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