From patchwork Sun Mar 10 18:02:09 2019 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 8bit X-Patchwork-Submitter: Pierre Neidhardt X-Patchwork-Id: 1364 Return-Path: X-Original-To: patchwork@mira.cbaines.net Delivered-To: patchwork@mira.cbaines.net Received: by mira.cbaines.net (Postfix, from userid 113) id 1257416D7B; Sun, 10 Mar 2019 18:10:12 +0000 (GMT) X-Spam-Checker-Version: SpamAssassin 3.4.0 (2014-02-07) on mira.cbaines.net X-Spam-Level: X-Spam-Status: No, score=-1.9 required=5.0 tests=BAYES_00,URIBL_BLOCKED autolearn=unavailable autolearn_force=no version=3.4.0 Received: from lists.gnu.org (lists.gnu.org [209.51.188.17]) by mira.cbaines.net (Postfix) with ESMTP id 77B4E16D7A for ; Sun, 10 Mar 2019 18:10:10 +0000 (GMT) Received: from localhost ([127.0.0.1]:48013 helo=lists.gnu.org) by lists.gnu.org with esmtp (Exim 4.71) (envelope-from ) id 1h32tm-0008UD-1S for patchwork@mira.cbaines.net; Sun, 10 Mar 2019 14:10:10 -0400 Received: from eggs.gnu.org ([209.51.188.92]:37589) by lists.gnu.org with esmtp (Exim 4.71) (envelope-from ) id 1h32qo-00069U-9a for guix-patches@gnu.org; Sun, 10 Mar 2019 14:07:09 -0400 Received: from Debian-exim by eggs.gnu.org with spam-scanned (Exim 4.71) (envelope-from ) id 1h32qk-00010Y-Pa for guix-patches@gnu.org; Sun, 10 Mar 2019 14:07:06 -0400 Received: from debbugs.gnu.org ([209.51.188.43]:52999) by eggs.gnu.org with esmtps (TLS1.0:RSA_AES_128_CBC_SHA1:16) (Exim 4.71) (envelope-from ) id 1h32qk-00010G-Jy for guix-patches@gnu.org; Sun, 10 Mar 2019 14:07:02 -0400 Received: from Debian-debbugs by debbugs.gnu.org with local (Exim 4.84_2) (envelope-from ) id 1h32qk-0006Xk-C2 for guix-patches@gnu.org; Sun, 10 Mar 2019 14:07:02 -0400 X-Loop: help-debbugs@gnu.org Subject: [bug#34807] [PATCH 1/2] Add (guix lzlib). Resent-From: Pierre Neidhardt Original-Sender: "Debbugs-submit" Resent-CC: guix-patches@gnu.org Resent-Date: Sun, 10 Mar 2019 18:07:02 +0000 Resent-Message-ID: Resent-Sender: help-debbugs@gnu.org X-GNU-PR-Message: report 34807 X-GNU-PR-Package: guix-patches X-GNU-PR-Keywords: patch To: 34807@debbugs.gnu.org X-Debbugs-Original-To: guix-patches@gnu.org Received: via spool by submit@debbugs.gnu.org id=B.155224119325105 (code B ref -1); Sun, 10 Mar 2019 18:07:02 +0000 Received: (at submit) by debbugs.gnu.org; 10 Mar 2019 18:06:33 +0000 Received: from localhost ([127.0.0.1]:38310 helo=debbugs.gnu.org) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1h32qG-0006Wo-Ht for submit@debbugs.gnu.org; Sun, 10 Mar 2019 14:06:33 -0400 Received: from eggs.gnu.org ([209.51.188.92]:51014) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1h32qC-0006WP-Sy for submit@debbugs.gnu.org; Sun, 10 Mar 2019 14:06:30 -0400 Received: from lists.gnu.org ([209.51.188.17]:37613) by eggs.gnu.org with esmtps (TLS1.0:RSA_AES_256_CBC_SHA1:32) (Exim 4.71) (envelope-from ) id 1h32q7-0000Yt-Pf for submit@debbugs.gnu.org; Sun, 10 Mar 2019 14:06:23 -0400 Received: from eggs.gnu.org ([209.51.188.92]:37035) by lists.gnu.org with esmtp (Exim 4.71) (envelope-from ) id 1h32q4-0005Va-EW for guix-patches@gnu.org; Sun, 10 Mar 2019 14:06:23 -0400 Received: from Debian-exim by eggs.gnu.org with spam-scanned (Exim 4.71) (envelope-from ) id 1h32m8-0006RO-VE for guix-patches@gnu.org; Sun, 10 Mar 2019 14:02:20 -0400 Received: from relay8-d.mail.gandi.net ([217.70.183.201]:55831) by eggs.gnu.org with esmtps (TLS1.0:DHE_RSA_AES_256_CBC_SHA1:32) (Exim 4.71) (envelope-from ) id 1h32m8-0006OZ-KC for guix-patches@gnu.org; Sun, 10 Mar 2019 14:02:16 -0400 X-Originating-IP: 90.92.41.33 Received: from localhost.localdomain (lfbn-1-12225-33.w90-92.abo.wanadoo.fr [90.92.41.33]) (Authenticated sender: mail@ambrevar.xyz) by relay8-d.mail.gandi.net (Postfix) with ESMTPSA id E15351BF206 for ; Sun, 10 Mar 2019 18:02:09 +0000 (UTC) From: Pierre Neidhardt Date: Sun, 10 Mar 2019 19:02:09 +0100 Message-Id: <20190310180209.11578-1-mail@ambrevar.xyz> X-Mailer: git-send-email 2.20.1 MIME-Version: 1.0 X-detected-operating-system: by eggs.gnu.org: GNU/Linux 2.2.x-3.x [generic] X-detected-operating-system: by eggs.gnu.org: GNU/Linux 2.6.x X-BeenThere: debbugs-submit@debbugs.gnu.org X-Mailman-Version: 2.1.18 Precedence: list X-detected-operating-system: by eggs.gnu.org: GNU/Linux 2.2.x-3.x [generic] X-Received-From: 209.51.188.43 X-BeenThere: guix-patches@gnu.org List-Id: List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Errors-To: guix-patches-bounces+patchwork=mira.cbaines.net@gnu.org Sender: "Guix-patches" X-getmail-retrieved-from-mailbox: Patches * 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. --- Makefile.am | 2 + configure.ac | 11 + guix/config.scm.in | 7 +- guix/lzlib.scm | 592 +++++++++++++++++++++++++++++++++++++++++++++ m4/guix.m4 | 12 + tests/lzlib.scm | 62 +++++ 6 files changed, 685 insertions(+), 1 deletion(-) create mode 100644 guix/lzlib.scm create mode 100644 tests/lzlib.scm diff --git a/Makefile.am b/Makefile.am index cf35770ba7..fd48c57a8d 100644 --- a/Makefile.am +++ b/Makefile.am @@ -101,6 +101,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 \ @@ -389,6 +390,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 \ diff --git a/configure.ac b/configure.ac index 5d70de4beb..edfe807ddd 100644 --- a/configure.ac +++ b/configure.ac @@ -258,6 +258,17 @@ 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_LIBDIR([liblz_libdir]) +if test "x$liblz_libdir" = "x"; then + LIBLZ="liblz" +else + LIBLZ="$liblz_libdir/liblz" +fi +AC_MSG_CHECKING([for lzlib's shared library name]) +AC_MSG_RESULT([$LIBLZ]) +AC_SUBST([LIBLZ]) + dnl Check for Guile-SSH, for the (guix ssh) module. GUIX_CHECK_GUILE_SSH AM_CONDITIONAL([HAVE_GUILE_SSH], diff --git a/guix/config.scm.in b/guix/config.scm.in index d2ec9921c6..0808947ddd 100644 --- a/guix/config.scm.in +++ b/guix/config.scm.in @@ -37,7 +37,8 @@ %libz %gzip %bzip2 - %xz)) + %xz + %liblz)) ;;; Commentary: ;;; @@ -103,4 +104,8 @@ (define %xz "@XZ@") +(define %liblz + ;; TODO: Set this dynamically. + "/gnu/store/8db7vivi8p9mpkbphb8xy8gh2bkwc4iz-lzlib-1.11/lib/liblz") + ;;; config.scm ends here diff --git a/guix/lzlib.scm b/guix/lzlib.scm new file mode 100644 index 0000000000..abab3f761c --- /dev/null +++ b/guix/lzlib.scm @@ -0,0 +1,592 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2019 Pierre Neidhardt +;;; +;;; 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 . + +(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. +;;; +;;; 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 + ;; Scheme counterpart of the 'LZ_Decoder' opaque type. + lz-decoder? + pointer->lz-decoder + lz-decoder->pointer + (lambda (obj port) + (format port "#" + (number->string (object-address obj) 16)))) + +(define-wrapped-pointer-type + ;; Scheme counterpart of the 'LZ_Encoder' opaque type. + lz-encoder? + pointer->lz-encoder + lz-encoder->pointer + (lambda (obj port) + (format port "#" + (number->string (object-address obj) 16)))) + +(define %error-number-ok + ;; TODO: How do we get the values of a C enum? + 0) + + +;; Compression bindings. + +(define lz-compress-open + (let ((proc (lzlib-procedure '* "LZ_compress_open" (list int int uint64)))) + ;; TODO: member-size default is INT64_MAX. Is there a better way to do this with Guile? + (lambda* (dictionary-size match-length-limit #:optional (member-size #x7FFFFFFFFFFFFFFF)) + "Initializes 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) + "Use this function to 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)))) + (when (= ret -1) + (throw 'lzlib-error 'lz-compress-finish (lz-compress-error encoder))))))) + +(define lz-compress-restart-member + (let ((proc (lzlib-procedure int "LZ_compress_restart_member" (list '* uint64)))) + (lambda (encoder member-size) + "Use this function to 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))) + (when (= ret -1) + (throw 'lzlib-error 'lz-compress-restart-member + (lz-compress-error encoder))))))) + +(define lz-compress-sync-flush + (let ((proc (lzlib-procedure int "LZ_compress_sync_flush" (list '*)))) + (lambda (encoder) + "Use this function to 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)))) + (when (= ret -1) + (throw 'lzlib-error 'lz-compress-sync-flush + (lz-compress-error encoder))))))) + +(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) + "Use this function to 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)))) + (when (= ret -1) + (throw 'lzlib-error 'lz-decompress-finish (lz-decompress-error decoder))))))) + +(define lz-decompress-reset + (let ((proc (lzlib-procedure int "LZ_decompress_reset" '(*)))) + (lambda (decoder) + "Resets 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)))) + (when (= ret -1) + (throw 'lzlib-error 'lz-decompress-reset + (lz-decompress-error decoder))))))) + +(define lz-decompress-sync-to-member + (let ((proc (lzlib-procedure int "LZ_decompress_sync_to_member" '(*)))) + (lambda (decoder) + "Resets 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)))) + (when (= ret -1) + (throw 'lzlib-error 'lz-decompress-sync-to-member + (lz-decompress-error decoder))))))) + +(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 strictly 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 strictly positive 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 encoder)))))))) + +(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-finished? (lz-decompress-error encoder)))))))) + +(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 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." + (let* ((written 0) + (read 0) + (chunk (* 64 1024)) + (file-bv (get-bytevector-n file-port count))) + (if (eof-object? file-bv) + 0 + (begin + (while (and (< 0 (lz-decompress-write-size decoder)) + (< written (bytevector-length file-bv))) + (set! written (lz-decompress-write decoder file-bv written (- (bytevector-length file-bv) written)))) + ;; TODO: When should we call `lz-decompress-finish'? + ;; (lz-decompress-finish decoder) + ;; TODO: Loop? + (set! read (lz-decompress-read decoder bv start + (- (bytevector-length bv) start))) + 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 strictly positive integer." + (let ((written 0) + (read 0)) + (while (and (< 0 (lz-compress-write-size encoder)) + (< written count)) + (set! written (lz-compress-write encoder bv (+ start written) (- count written)))) + (lz-compress-finish encoder) + ;; TODO: Better loop? + (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)))) + ;; TODO: Return written (uncompressed) or read (compressed)? + 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 () + (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 () + (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 diff --git a/m4/guix.m4 b/m4/guix.m4 index 5c846f7618..59156733b2 100644 --- a/m4/guix.m4 +++ b/m4/guix.m4 @@ -312,6 +312,18 @@ AC_DEFUN([GUIX_LIBZ_LIBDIR], [ $1="$guix_cv_libz_libdir" ]) +dnl GUIX_LIBLZ_LIBDIR VAR +dnl +dnl Attempt to determine liblz's LIBDIR; store the result in VAR. +AC_DEFUN([GUIX_LIBLZ_LIBDIR], [ + AC_REQUIRE([PKG_PROG_PKG_CONFIG]) + AC_CACHE_CHECK([lzlib's library directory], + [guix_cv_liblz_libdir], + dnl TODO: This fails because lzlib has no pkg-config. + [guix_cv_liblz_libdir="`$PKG_CONFIG lzlib --variable=libdir 2> /dev/null`"]) + $1="$guix_cv_liblz_libdir" +]) + dnl GUIX_CURRENT_LOCALSTATEDIR dnl dnl Determine the localstatedir of an existing Guix installation and set diff --git a/tests/lzlib.scm b/tests/lzlib.scm new file mode 100644 index 0000000000..7f28ac04ec --- /dev/null +++ b/tests/lzlib.scm @@ -0,0 +1,62 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2019 Pierre Neidhardt +;;; +;;; 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 . + +(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. + +(unless (lzlib-available?) + (exit 77)) + +(test-begin "lzlib") + +(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-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) + (and (zero? status) + (port-closed? parent) + (bytevector=? received data)))))))))))) + +(test-end) From patchwork Sun Mar 10 18:09:05 2019 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit X-Patchwork-Submitter: Pierre Neidhardt X-Patchwork-Id: 1365 Return-Path: X-Original-To: patchwork@mira.cbaines.net Delivered-To: patchwork@mira.cbaines.net Received: by mira.cbaines.net (Postfix, from userid 113) id 4012516D7B; Sun, 10 Mar 2019 18:13:41 +0000 (GMT) X-Spam-Checker-Version: SpamAssassin 3.4.0 (2014-02-07) on mira.cbaines.net X-Spam-Level: X-Spam-Status: No, score=-1.9 required=5.0 tests=BAYES_00 autolearn=unavailable autolearn_force=no version=3.4.0 Received: from lists.gnu.org (lists.gnu.org [209.51.188.17]) by mira.cbaines.net (Postfix) with ESMTP id 0D78616D79 for ; Sun, 10 Mar 2019 18:13:41 +0000 (GMT) Received: from localhost ([127.0.0.1]:48079 helo=lists.gnu.org) by lists.gnu.org with esmtp (Exim 4.71) (envelope-from ) id 1h32xA-00021P-Jn for patchwork@mira.cbaines.net; Sun, 10 Mar 2019 14:13:40 -0400 Received: from eggs.gnu.org ([209.51.188.92]:39153) by lists.gnu.org with esmtp (Exim 4.71) (envelope-from ) id 1h32ti-0008VX-AC for guix-patches@gnu.org; Sun, 10 Mar 2019 14:10:06 -0400 Received: from Debian-exim by eggs.gnu.org with spam-scanned (Exim 4.71) (envelope-from ) id 1h32th-0004dd-Mn for guix-patches@gnu.org; Sun, 10 Mar 2019 14:10:06 -0400 Received: from debbugs.gnu.org ([209.51.188.43]:53005) by eggs.gnu.org with esmtps (TLS1.0:RSA_AES_128_CBC_SHA1:16) (Exim 4.71) (envelope-from ) id 1h32th-0004cV-Hr for guix-patches@gnu.org; Sun, 10 Mar 2019 14:10:05 -0400 Received: from Debian-debbugs by debbugs.gnu.org with local (Exim 4.84_2) (envelope-from ) id 1h32te-0006dC-KA for guix-patches@gnu.org; Sun, 10 Mar 2019 14:10:05 -0400 X-Loop: help-debbugs@gnu.org Subject: [bug#34807] [PATCH 2/2] dir-locals.el: Add 'call-with-lzip-input-port' and 'call-with-lzip-output-port' keywords. References: <20190310180209.11578-1-mail@ambrevar.xyz> In-Reply-To: <20190310180209.11578-1-mail@ambrevar.xyz> Resent-From: Pierre Neidhardt Original-Sender: "Debbugs-submit" Resent-CC: guix-patches@gnu.org Resent-Date: Sun, 10 Mar 2019 18:10:02 +0000 Resent-Message-ID: Resent-Sender: help-debbugs@gnu.org X-GNU-PR-Message: followup 34807 X-GNU-PR-Package: guix-patches X-GNU-PR-Keywords: patch To: 34807@debbugs.gnu.org Received: via spool by 34807-submit@debbugs.gnu.org id=B34807.155224135125404 (code B ref 34807); Sun, 10 Mar 2019 18:10:02 +0000 Received: (at 34807) by debbugs.gnu.org; 10 Mar 2019 18:09:11 +0000 Received: from localhost ([127.0.0.1]:38316 helo=debbugs.gnu.org) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1h32sp-0006bg-0v for submit@debbugs.gnu.org; Sun, 10 Mar 2019 14:09:11 -0400 Received: from relay1-d.mail.gandi.net ([217.70.183.193]:38865) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1h32sm-0006bW-Q2 for 34807@debbugs.gnu.org; Sun, 10 Mar 2019 14:09:09 -0400 X-Originating-IP: 90.92.41.33 Received: from localhost.localdomain (lfbn-1-12225-33.w90-92.abo.wanadoo.fr [90.92.41.33]) (Authenticated sender: mail@ambrevar.xyz) by relay1-d.mail.gandi.net (Postfix) with ESMTPSA id 63E45240005 for <34807@debbugs.gnu.org>; Sun, 10 Mar 2019 18:09:05 +0000 (UTC) From: Pierre Neidhardt Date: Sun, 10 Mar 2019 19:09:05 +0100 Message-Id: <20190310180905.14459-1-mail@ambrevar.xyz> X-Mailer: git-send-email 2.20.1 MIME-Version: 1.0 X-BeenThere: debbugs-submit@debbugs.gnu.org X-Mailman-Version: 2.1.18 Precedence: list X-detected-operating-system: by eggs.gnu.org: GNU/Linux 2.2.x-3.x [generic] X-Received-From: 209.51.188.43 X-BeenThere: guix-patches@gnu.org List-Id: List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Errors-To: guix-patches-bounces+patchwork=mira.cbaines.net@gnu.org Sender: "Guix-patches" X-getmail-retrieved-from-mailbox: Patches * .dir-locals.el: Add indentation rules for 'call-with-lzip-input-port' and 'call-with-lzip-output-port'. --- .dir-locals.el | 2 ++ 1 file changed, 2 insertions(+) diff --git a/.dir-locals.el b/.dir-locals.el index 550e06ef09..f1196fd781 100644 --- a/.dir-locals.el +++ b/.dir-locals.el @@ -53,6 +53,8 @@ (eval . (put 'call-with-decompressed-port 'scheme-indent-function 2)) (eval . (put 'call-with-gzip-input-port 'scheme-indent-function 1)) (eval . (put 'call-with-gzip-output-port 'scheme-indent-function 1)) + (eval . (put 'call-with-lzip-input-port 'scheme-indent-function 1)) + (eval . (put 'call-with-lzip-output-port 'scheme-indent-function 1)) (eval . (put 'signature-case 'scheme-indent-function 1)) (eval . (put 'emacs-batch-eval 'scheme-indent-function 0)) (eval . (put 'emacs-batch-edit-file 'scheme-indent-function 1))