unofficial mirror of guix-patches@gnu.org 
 help / color / mirror / code / Atom feed
* [bug#34807] [PATCH 1/2] Add (guix lzlib).
@ 2019-03-10 18:02 Pierre Neidhardt
  2019-03-10 18:09 ` [bug#34807] [PATCH 2/2] dir-locals.el: Add 'call-with-lzip-input-port' and 'call-with-lzip-output-port' keywords Pierre Neidhardt
  2019-03-22 21:35 ` [bug#34807] [PATCH 1/2] Add (guix lzlib) Ludovic Courtès
  0 siblings, 2 replies; 15+ messages in thread
From: Pierre Neidhardt @ 2019-03-10 18:02 UTC (permalink / raw)
  To: 34807

* 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 <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.
+;;;
+;;; 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))))
+
+(define %error-number-ok
+  ;; TODO: How do we get the values of a C enum?
+  0)
+
+\f
+;; 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)))))
+
+\f
+;; 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)))))
+
+\f
+;; 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))
+
+\f
+;;;
+;;; 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 <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.
+
+(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)
-- 
2.20.1

^ permalink raw reply related	[flat|nested] 15+ messages in thread

end of thread, other threads:[~2019-05-07 15:52 UTC | newest]

Thread overview: 15+ messages (download: mbox.gz follow: Atom feed
-- links below jump to the message on this page --
2019-03-10 18:02 [bug#34807] [PATCH 1/2] Add (guix lzlib) Pierre Neidhardt
2019-03-10 18:09 ` [bug#34807] [PATCH 2/2] dir-locals.el: Add 'call-with-lzip-input-port' and 'call-with-lzip-output-port' keywords Pierre Neidhardt
2019-03-22 21:35 ` [bug#34807] [PATCH 1/2] Add (guix lzlib) Ludovic Courtès
2019-05-01 16:46   ` Pierre Neidhardt
2019-05-02  9:16     ` Pierre Neidhardt
2019-05-04  9:11       ` Ludovic Courtès
2019-05-04 10:23         ` Pierre Neidhardt
2019-05-04 21:09           ` Ludovic Courtès
2019-05-04 21:39             ` Pierre Neidhardt
2019-05-06 21:18               ` Ludovic Courtès
2019-05-06 23:28                 ` Tobias Geerinckx-Rice
2019-05-07  7:02                   ` Pierre Neidhardt
2019-05-07 15:44                     ` bug#34807: " Ludovic Courtès
2019-05-07 15:51                       ` [bug#34807] " Pierre Neidhardt
2019-05-07  8:19                   ` Ludovic Courtès

Code repositories for project(s) associated with this public inbox

	https://git.savannah.gnu.org/cgit/guix.git

This is a public inbox, see mirroring instructions
for how to clone and mirror all data and code used for this inbox;
as well as URLs for read-only IMAP folder(s) and NNTP newsgroup(s).