me
/
guix
Archived
1
0
Fork 0
Code

Add (guix lzlib). 

* guix/lzlib.scm, tests/lzlib.scm: New files.
* Makefile.am (MODULES): Add guix/lzlib.scm.
(SCM_TESTS): Add tests/lzlib.scm.
* m4/guix.m4 (GUIX_LIBLZ_LIBDIR): New macro.
* configure.ac (LIBLZ_LIBDIR): Use it.  Define and substitute
'LIBLZ'.
* guix/config.scm.in (%liblz): New variable.
* guix/self.scm (make-config.scm): Add TODO comment.

Co-authored-by: Ludovic Courtès <ludo@gnu.org>
master
Pierre Neidhardt 2019-03-08 19:02:59 +01:00 committed by Ludovic Courtès
parent 46c102ca5e
commit fea338c6ca
No known key found for this signature in database
GPG Key ID: 090B11993D9AEBB5
7 changed files with 777 additions and 1 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
Makefile.am
View File

@ -103,6 +103,7 @@ MODULES = \
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 \
@ -404,6 +405,7 @@ SCM_TESTS = \
tests/cve.scm \
tests/workers.scm \
tests/zlib.scm \
tests/lzlib.scm \
tests/file-systems.scm \
tests/uuid.scm \
tests/system.scm \

10
configure.ac
View File

@ -250,6 +250,16 @@ 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],

4
guix/config.scm.in
View File

@ -34,6 +34,7 @@
%system
%libz
%liblz
%gzip
%bzip2
%xz))
@ -90,6 +91,9 @@
(define %libz
"@LIBZ@")
(define %liblz
"@LIBLZ@")
(define %gzip
"@GZIP@")

633
guix/lzlib.scm 100644
View File

@ -0,0 +1,633 @@
;;; 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 (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)
#:export (lzlib-available?
make-lzip-input-port
make-lzip-output-port
call-with-lzip-input-port
call-with-lzip-output-port
%default-member-length-limit
%default-compression-level))
;;; 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 strictly 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 %lz-decompress-input-buffer-size (* 64 1024))
(define* (lzread! decoder file-port bv
#:optional (start 0) (count (bytevector-length bv)))
"Read up to COUNT bytes from FILE-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."
;; WARNING: Because we don't alternate between lz-reads and lz-writes, we can't
;; process more than %lz-decompress-input-buffer-size from the file-port.
(when (> count %lz-decompress-input-buffer-size)
(set! count %lz-decompress-input-buffer-size))
(let* ((written 0)
(read 0)
(file-bv (get-bytevector-n file-port count)))
(unless (eof-object? file-bv)
(begin
(while (and (< 0 (lz-decompress-write-size decoder))
(< written (bytevector-length file-bv)))
(set! written (+ written
(lz-decompress-write decoder file-bv written
(- (bytevector-length file-bv) written)))))))
(let loop ((rd 0))
(if (< start (bytevector-length bv))
(begin
(set! rd (lz-decompress-read decoder bv start (- (bytevector-length bv) start)))
(set! start (+ start rd))
(set! read (+ read rd)))
(set! rd 0))
(unless (= rd 0)
(loop rd)))
read))
(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* (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 (apply lz-compress-open
(car (assoc-ref %compression-levels level))))
(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* (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

1
guix/self.scm
View File

@ -925,6 +925,7 @@ Info manual."
%store-database-directory
%config-directory
%libz
;; TODO: %liblz
%gzip
%bzip2
%xz))

17
m4/guix.m4
View File

@ -1,5 +1,5 @@
dnl GNU Guix --- Functional package management for GNU
dnl Copyright © 2012, 2013, 2014, 2015, 2016, 2018 Ludovic Courtès <ludo@gnu.org>
dnl Copyright © 2012, 2013, 2014, 2015, 2016, 2018, 2019 Ludovic Courtès <ludo@gnu.org>
dnl Copyright © 2014 Mark H Weaver <mhw@netris.org>
dnl Copyright © 2017 Efraim Flashner <efraim@flashner.co.il>
dnl
@ -312,6 +312,21 @@ AC_DEFUN([GUIX_LIBZ_LIBDIR], [
$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

111
tests/lzlib.scm 100644
View File

@ -0,0 +1,111 @@
;;; 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 (car (car (assoc-ref (@@ (guix lzlib) %compression-levels)
(@@ (guix lzlib) %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-end)