summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorPierre Neidhardt <mail@ambrevar.xyz>2019-03-08 19:02:59 +0100
committerLudovic Courtès <ludo@gnu.org>2019-05-06 23:21:33 +0200
commitfea338c6ca1922097fa233be85f424c152a4f507 (patch)
tree82dc3e961d206f331ee7e31999c4b38d345d7aa4
parent46c102ca5e76ffc1daa42edba439eee9fd0f102c (diff)
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>
-rw-r--r--Makefile.am2
-rw-r--r--configure.ac10
-rw-r--r--guix/config.scm.in4
-rw-r--r--guix/lzlib.scm633
-rw-r--r--guix/self.scm1
-rw-r--r--m4/guix.m417
-rw-r--r--tests/lzlib.scm111
7 files changed, 777 insertions, 1 deletions
diff --git a/Makefile.am b/Makefile.am
index 04944523861..9539fef1b13 100644
--- a/Makefile.am
+++ b/Makefile.am
@@ -103,6 +103,7 @@ MODULES = \
103 guix/cve.scm \ 103 guix/cve.scm \
104 guix/workers.scm \ 104 guix/workers.scm \
105 guix/zlib.scm \ 105 guix/zlib.scm \
106 guix/lzlib.scm \
106 guix/build-system.scm \ 107 guix/build-system.scm \
107 guix/build-system/android-ndk.scm \ 108 guix/build-system/android-ndk.scm \
108 guix/build-system/ant.scm \ 109 guix/build-system/ant.scm \
@@ -404,6 +405,7 @@ SCM_TESTS = \
404 tests/cve.scm \ 405 tests/cve.scm \
405 tests/workers.scm \ 406 tests/workers.scm \
406 tests/zlib.scm \ 407 tests/zlib.scm \
408 tests/lzlib.scm \
407 tests/file-systems.scm \ 409 tests/file-systems.scm \
408 tests/uuid.scm \ 410 tests/uuid.scm \
409 tests/system.scm \ 411 tests/system.scm \
diff --git a/configure.ac b/configure.ac
index 7e7ae02730d..3918550a791 100644
--- a/configure.ac
+++ b/configure.ac
@@ -250,6 +250,16 @@ AC_MSG_CHECKING([for zlib's shared library name])
250AC_MSG_RESULT([$LIBZ]) 250AC_MSG_RESULT([$LIBZ])
251AC_SUBST([LIBZ]) 251AC_SUBST([LIBZ])
252 252
253dnl Library name of lzlib suitable for 'dynamic-link'.
254GUIX_LIBLZ_FILE_NAME([LIBLZ])
255if test "x$LIBLZ" = "x"; then
256 LIBLZ="liblz"
257else
258 # Strip the .so or .so.1 extension since that's what 'dynamic-link' expects.
259 LIBLZ="`echo $LIBLZ | sed -es'/\.so\(\.[[0-9.]]\+\)\?//g'`"
260fi
261AC_SUBST([LIBLZ])
262
253dnl Check for Guile-SSH, for the (guix ssh) module. 263dnl Check for Guile-SSH, for the (guix ssh) module.
254GUIX_CHECK_GUILE_SSH 264GUIX_CHECK_GUILE_SSH
255AM_CONDITIONAL([HAVE_GUILE_SSH], 265AM_CONDITIONAL([HAVE_GUILE_SSH],
diff --git a/guix/config.scm.in b/guix/config.scm.in
index 247b15ed818..0ada0f3c38c 100644
--- a/guix/config.scm.in
+++ b/guix/config.scm.in
@@ -34,6 +34,7 @@
34 34
35 %system 35 %system
36 %libz 36 %libz
37 %liblz
37 %gzip 38 %gzip
38 %bzip2 39 %bzip2
39 %xz)) 40 %xz))
@@ -90,6 +91,9 @@
90(define %libz 91(define %libz
91 "@LIBZ@") 92 "@LIBZ@")
92 93
94(define %liblz
95 "@LIBLZ@")
96
93(define %gzip 97(define %gzip
94 "@GZIP@") 98 "@GZIP@")
95 99
diff --git a/guix/lzlib.scm b/guix/lzlib.scm
new file mode 100644
index 00000000000..d596f0d95dd
--- /dev/null
+++ b/guix/lzlib.scm
@@ -0,0 +1,633 @@
1;;; GNU Guix --- Functional package management for GNU
2;;; Copyright © 2019 Pierre Neidhardt <mail@ambrevar.xyz>
3;;;
4;;; This file is part of GNU Guix.
5;;;
6;;; GNU Guix is free software; you can redistribute it and/or modify it
7;;; under the terms of the GNU General Public License as published by
8;;; the Free Software Foundation; either version 3 of the License, or (at
9;;; your option) any later version.
10;;;
11;;; GNU Guix is distributed in the hope that it will be useful, but
12;;; WITHOUT ANY WARRANTY; without even the implied warranty of
13;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
14;;; GNU General Public License for more details.
15;;;
16;;; You should have received a copy of the GNU General Public License
17;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
18
19(define-module (guix lzlib)
20 #:use-module (rnrs bytevectors)
21 #:use-module (rnrs arithmetic bitwise)
22 #:use-module (ice-9 binary-ports)
23 #:use-module (ice-9 match)
24 #:use-module (system foreign)
25 #:use-module (guix config)
26 #:export (lzlib-available?
27 make-lzip-input-port
28 make-lzip-output-port
29 call-with-lzip-input-port
30 call-with-lzip-output-port
31 %default-member-length-limit
32 %default-compression-level))
33
34;;; Commentary:
35;;;
36;;; Bindings to the lzlib / liblz API. Some convenience functions are also
37;;; provided (see the export).
38;;;
39;;; While the bindings are complete, the convenience functions only support
40;;; single member archives. To decompress single member archives, we loop
41;;; until lz-decompress-read returns 0. This is simpler. To support multiple
42;;; members properly, we need (among others) to call lz-decompress-finish and
43;;; loop over lz-decompress-read until lz-decompress-finished? returns #t.
44;;; Otherwise a multi-member archive starting with an empty member would only
45;;; decompress the empty member and stop there, resulting in truncated output.
46
47;;; Code:
48
49(define %lzlib
50 ;; File name of lzlib's shared library. When updating via 'guix pull',
51 ;; '%liblz' might be undefined so protect against it.
52 (delay (dynamic-link (if (defined? '%liblz)
53 %liblz
54 "liblz"))))
55
56(define (lzlib-available?)
57 "Return true if lzlib is available, #f otherwise."
58 (false-if-exception (force %lzlib)))
59
60(define (lzlib-procedure ret name parameters)
61 "Return a procedure corresponding to C function NAME in liblz, or #f if
62either lzlib or the function could not be found."
63 (match (false-if-exception (dynamic-func name (force %lzlib)))
64 ((? pointer? ptr)
65 (pointer->procedure ret ptr parameters))
66 (#f
67 #f)))
68
69(define-wrapped-pointer-type <lz-decoder>
70 ;; Scheme counterpart of the 'LZ_Decoder' opaque type.
71 lz-decoder?
72 pointer->lz-decoder
73 lz-decoder->pointer
74 (lambda (obj port)
75 (format port "#<lz-decoder ~a>"
76 (number->string (object-address obj) 16))))
77
78(define-wrapped-pointer-type <lz-encoder>
79 ;; Scheme counterpart of the 'LZ_Encoder' opaque type.
80 lz-encoder?
81 pointer->lz-encoder
82 lz-encoder->pointer
83 (lambda (obj port)
84 (format port "#<lz-encoder ~a>"
85 (number->string (object-address obj) 16))))
86
87;; From lzlib.h
88(define %error-number-ok 0)
89(define %error-number-bad-argument 1)
90(define %error-number-mem-error 2)
91(define %error-number-sequence-error 3)
92(define %error-number-header-error 4)
93(define %error-number-unexpected-eof 5)
94(define %error-number-data-error 6)
95(define %error-number-library-error 7)
96
97
98;; Compression bindings.
99
100(define lz-compress-open
101 (let ((proc (lzlib-procedure '* "LZ_compress_open" (list int int uint64)))
102 ;; member-size is an "unsigned long long", and the C standard guarantees
103 ;; a minimum range of 0..2^64-1.
104 (unlimited-size (- (expt 2 64) 1)))
105 (lambda* (dictionary-size match-length-limit #:optional (member-size unlimited-size))
106 "Initialize the internal stream state for compression and returns a
107pointer that can only be used as the encoder argument for the other
108lz-compress functions, or a null pointer if the encoder could not be
109allocated.
110
111See the manual: (lzlib) Compression functions."
112 (let ((encoder-ptr (proc dictionary-size match-length-limit member-size)))
113 (if (not (= (lz-compress-error encoder-ptr) -1))
114 (pointer->lz-encoder encoder-ptr)
115 (throw 'lzlib-error 'lz-compress-open))))))
116
117(define lz-compress-close
118 (let ((proc (lzlib-procedure int "LZ_compress_close" '(*))))
119 (lambda (encoder)
120 "Close encoder. ENCODER can no longer be used as an argument to any
121lz-compress function. "
122 (let ((ret (proc (lz-encoder->pointer encoder))))
123 (if (= ret -1)
124 (throw 'lzlib-error 'lz-compress-close ret)
125 ret)))))
126
127(define lz-compress-finish
128 (let ((proc (lzlib-procedure int "LZ_compress_finish" '(*))))
129 (lambda (encoder)
130 "Tell that all the data for this member have already been written (with
131the `lz-compress-write' function). It is safe to call `lz-compress-finish' as
132many times as needed. After all the produced compressed data have been read
133with `lz-compress-read' and `lz-compress-member-finished?' returns #t, a new
134member can be started with 'lz-compress-restart-member'."
135 (let ((ret (proc (lz-encoder->pointer encoder))))
136 (if (= ret -1)
137 (throw 'lzlib-error 'lz-compress-finish (lz-compress-error encoder))
138 ret)))))
139
140(define lz-compress-restart-member
141 (let ((proc (lzlib-procedure int "LZ_compress_restart_member" (list '* uint64))))
142 (lambda (encoder member-size)
143 "Start a new member in a multimember data stream.
144Call this function only after `lz-compress-member-finished?' indicates that the
145current member has been fully read (with the `lz-compress-read' function)."
146 (let ((ret (proc (lz-encoder->pointer encoder) member-size)))
147 (if (= ret -1)
148 (throw 'lzlib-error 'lz-compress-restart-member
149 (lz-compress-error encoder))
150 ret)))))
151
152(define lz-compress-sync-flush
153 (let ((proc (lzlib-procedure int "LZ_compress_sync_flush" (list '*))))
154 (lambda (encoder)
155 "Make available to `lz-compress-read' all the data already written with
156the `LZ-compress-write' function. First call `lz-compress-sync-flush'. Then
157call 'lz-compress-read' until it returns 0.
158
159Repeated use of `LZ-compress-sync-flush' may degrade compression ratio,
160so use it only when needed. "
161 (let ((ret (proc (lz-encoder->pointer encoder))))
162 (if (= ret -1)
163 (throw 'lzlib-error 'lz-compress-sync-flush
164 (lz-compress-error encoder))
165 ret)))))
166
167(define lz-compress-read
168 (let ((proc (lzlib-procedure int "LZ_compress_read" (list '* '* int))))
169 (lambda* (encoder lzfile-bv #:optional (start 0) (count (bytevector-length lzfile-bv)))
170 "Read up to COUNT bytes from the encoder stream, storing the results in LZFILE-BV.
171Return the number of uncompressed bytes written, a strictly positive integer."
172 (let ((ret (proc (lz-encoder->pointer encoder)
173 (bytevector->pointer lzfile-bv start)
174 count)))
175 (if (= ret -1)
176 (throw 'lzlib-error 'lz-compress-read (lz-compress-error encoder))
177 ret)))))
178
179(define lz-compress-write
180 (let ((proc (lzlib-procedure int "LZ_compress_write" (list '* '* int))))
181 (lambda* (encoder bv #:optional (start 0) (count (bytevector-length bv)))
182 "Write up to COUNT bytes from BV to the encoder stream. Return the
183number of uncompressed bytes written, a strictly positive integer."
184 (let ((ret (proc (lz-encoder->pointer encoder)
185 (bytevector->pointer bv start)
186 count)))
187 (if (< ret 0)
188 (throw 'lzlib-error 'lz-compress-write (lz-compress-error encoder))
189 ret)))))
190
191(define lz-compress-write-size
192 (let ((proc (lzlib-procedure int "LZ_compress_write_size" '(*))))
193 (lambda (encoder)
194 "The maximum number of bytes that can be immediately written through the
195`lz-compress-write' function.
196
197It is guaranteed that an immediate call to `lz-compress-write' will accept a
198SIZE up to the returned number of bytes. "
199 (let ((ret (proc (lz-encoder->pointer encoder))))
200 (if (= ret -1)
201 (throw 'lzlib-error 'lz-compress-write-size (lz-compress-error encoder))
202 ret)))))
203
204(define lz-compress-error
205 (let ((proc (lzlib-procedure int "LZ_compress_errno" '(*))))
206 (lambda (encoder)
207 "ENCODER can be a Scheme object or a pointer."
208 (let* ((error-number (proc (if (lz-encoder? encoder)
209 (lz-encoder->pointer encoder)
210 encoder))))
211 error-number))))
212
213(define lz-compress-finished?
214 (let ((proc (lzlib-procedure int "LZ_compress_finished" '(*))))
215 (lambda (encoder)
216 "Return #t if all the data have been read and `lz-compress-close' can
217be safely called. Otherwise return #f."
218 (let ((ret (proc (lz-encoder->pointer encoder))))
219 (match ret
220 (1 #t)
221 (0 #f)
222 (_ (throw 'lzlib-error 'lz-compress-finished? (lz-compress-error encoder))))))))
223
224(define lz-compress-member-finished?
225 (let ((proc (lzlib-procedure int "LZ_compress_member_finished" '(*))))
226 (lambda (encoder)
227 "Return #t if the current member, in a multimember data stream, has
228been fully read and 'lz-compress-restart-member' can be safely called.
229Otherwise return #f."
230 (let ((ret (proc (lz-encoder->pointer encoder))))
231 (match ret
232 (1 #t)
233 (0 #f)
234 (_ (throw 'lzlib-error 'lz-compress-member-finished? (lz-compress-error encoder))))))))
235
236(define lz-compress-data-position
237 (let ((proc (lzlib-procedure uint64 "LZ_compress_data_position" '(*))))
238 (lambda (encoder)
239 "Return the number of input bytes already compressed in the current
240member."
241 (let ((ret (proc (lz-encoder->pointer encoder))))
242 (if (= ret -1)
243 (throw 'lzlib-error 'lz-compress-data-position
244 (lz-compress-error encoder))
245 ret)))))
246
247(define lz-compress-member-position
248 (let ((proc (lzlib-procedure uint64 "LZ_compress_member_position" '(*))))
249 (lambda (encoder)
250 "Return the number of compressed bytes already produced, but perhaps
251not yet read, in the current member."
252 (let ((ret (proc (lz-encoder->pointer encoder))))
253 (if (= ret -1)
254 (throw 'lzlib-error 'lz-compress-member-position
255 (lz-compress-error encoder))
256 ret)))))
257
258(define lz-compress-total-in-size
259 (let ((proc (lzlib-procedure uint64 "LZ_compress_total_in_size" '(*))))
260 (lambda (encoder)
261 "Return the total number of input bytes already compressed."
262 (let ((ret (proc (lz-encoder->pointer encoder))))
263 (if (= ret -1)
264 (throw 'lzlib-error 'lz-compress-total-in-size
265 (lz-compress-error encoder))
266 ret)))))
267
268(define lz-compress-total-out-size
269 (let ((proc (lzlib-procedure uint64 "LZ_compress_total_out_size" '(*))))
270 (lambda (encoder)
271 "Return the total number of compressed bytes already produced, but
272perhaps not yet read."
273 (let ((ret (proc (lz-encoder->pointer encoder))))
274 (if (= ret -1)
275 (throw 'lzlib-error 'lz-compress-total-out-size
276 (lz-compress-error encoder))
277 ret)))))
278
279
280;; Decompression bindings.
281
282(define lz-decompress-open
283 (let ((proc (lzlib-procedure '* "LZ_decompress_open" '())))
284 (lambda ()
285 "Initializes the internal stream state for decompression and returns a
286pointer that can only be used as the decoder argument for the other
287lz-decompress functions, or a null pointer if the decoder could not be
288allocated.
289
290See the manual: (lzlib) Decompression functions."
291 (let ((decoder-ptr (proc)))
292 (if (not (= (lz-decompress-error decoder-ptr) -1))
293 (pointer->lz-decoder decoder-ptr)
294 (throw 'lzlib-error 'lz-decompress-open))))))
295
296(define lz-decompress-close
297 (let ((proc (lzlib-procedure int "LZ_decompress_close" '(*))))
298 (lambda (decoder)
299 "Close decoder. DECODER can no longer be used as an argument to any
300lz-decompress function. "
301 (let ((ret (proc (lz-decoder->pointer decoder))))
302 (if (= ret -1)
303 (throw 'lzlib-error 'lz-decompress-close ret)
304 ret)))))
305
306(define lz-decompress-finish
307 (let ((proc (lzlib-procedure int "LZ_decompress_finish" '(*))))
308 (lambda (decoder)
309 "Tell that all the data for this stream have already been written (with
310the `lz-decompress-write' function). It is safe to call
311`lz-decompress-finish' as many times as needed."
312 (let ((ret (proc (lz-decoder->pointer decoder))))
313 (if (= ret -1)
314 (throw 'lzlib-error 'lz-decompress-finish (lz-decompress-error decoder))
315 ret)))))
316
317(define lz-decompress-reset
318 (let ((proc (lzlib-procedure int "LZ_decompress_reset" '(*))))
319 (lambda (decoder)
320 "Reset the internal state of DECODER as it was just after opening it
321with the `lz-decompress-open' function. Data stored in the internal buffers
322is discarded. Position counters are set to 0."
323 (let ((ret (proc (lz-decoder->pointer decoder))))
324 (if (= ret -1)
325 (throw 'lzlib-error 'lz-decompress-reset
326 (lz-decompress-error decoder))
327 ret)))))
328
329(define lz-decompress-sync-to-member
330 (let ((proc (lzlib-procedure int "LZ_decompress_sync_to_member" '(*))))
331 (lambda (decoder)
332 "Reset the error state of DECODER and enters a search state that lasts
333until a new member header (or the end of the stream) is found. After a
334successful call to `lz-decompress-sync-to-member', data written with
335`lz-decompress-write' will be consumed and 'lz-decompress-read' will return 0
336until a header is found.
337
338This function is useful to discard any data preceding the first member, or to
339discard the rest of the current member, for example in case of a data
340error. If the decoder is already at the beginning of a member, this function
341does nothing."
342 (let ((ret (proc (lz-decoder->pointer decoder))))
343 (if (= ret -1)
344 (throw 'lzlib-error 'lz-decompress-sync-to-member
345 (lz-decompress-error decoder))
346 ret)))))
347
348(define lz-decompress-read
349 (let ((proc (lzlib-procedure int "LZ_decompress_read" (list '* '* int))))
350 (lambda* (decoder file-bv #:optional (start 0) (count (bytevector-length file-bv)))
351 "Read up to COUNT bytes from the decoder stream, storing the results in FILE-BV.
352Return the number of uncompressed bytes written, a non-negative positive integer."
353 (let ((ret (proc (lz-decoder->pointer decoder)
354 (bytevector->pointer file-bv start)
355 count)))
356 (if (< ret 0)
357 (throw 'lzlib-error 'lz-decompress-read (lz-decompress-error decoder))
358 ret)))))
359
360(define lz-decompress-write
361 (let ((proc (lzlib-procedure int "LZ_decompress_write" (list '* '* int))))
362 (lambda* (decoder bv #:optional (start 0) (count (bytevector-length bv)))
363 "Write up to COUNT bytes from BV to the decoder stream. Return the
364number of uncompressed bytes written, a non-negative integer."
365 (let ((ret (proc (lz-decoder->pointer decoder)
366 (bytevector->pointer bv start)
367 count)))
368 (if (< ret 0)
369 (throw 'lzlib-error 'lz-decompress-write (lz-decompress-error decoder))
370 ret)))))
371
372(define lz-decompress-write-size
373 (let ((proc (lzlib-procedure int "LZ_decompress_write_size" '(*))))
374 (lambda (decoder)
375 "Return the maximum number of bytes that can be immediately written
376through the `lz-decompress-write' function.
377
378It is guaranteed that an immediate call to `lz-decompress-write' will accept a
379SIZE up to the returned number of bytes. "
380 (let ((ret (proc (lz-decoder->pointer decoder))))
381 (if (= ret -1)
382 (throw 'lzlib-error 'lz-decompress-write-size (lz-decompress-error decoder))
383 ret)))))
384
385(define lz-decompress-error
386 (let ((proc (lzlib-procedure int "LZ_decompress_errno" '(*))))
387 (lambda (decoder)
388 "DECODER can be a Scheme object or a pointer."
389 (let* ((error-number (proc (if (lz-decoder? decoder)
390 (lz-decoder->pointer decoder)
391 decoder))))
392 error-number))))
393
394(define lz-decompress-finished?
395 (let ((proc (lzlib-procedure int "LZ_decompress_finished" '(*))))
396 (lambda (decoder)
397 "Return #t if all the data have been read and `lz-decompress-close' can
398be safely called. Otherwise return #f."
399 (let ((ret (proc (lz-decoder->pointer decoder))))
400 (match ret
401 (1 #t)
402 (0 #f)
403 (_ (throw 'lzlib-error 'lz-decompress-finished? (lz-decompress-error decoder))))))))
404
405(define lz-decompress-member-finished?
406 (let ((proc (lzlib-procedure int "LZ_decompress_member_finished" '(*))))
407 (lambda (decoder)
408 "Return #t if the current member, in a multimember data stream, has
409been fully read and `lz-decompress-restart-member' can be safely called.
410Otherwise return #f."
411 (let ((ret (proc (lz-decoder->pointer decoder))))
412 (match ret
413 (1 #t)
414 (0 #f)
415 (_ (throw 'lzlib-error 'lz-decompress-member-finished? (lz-decompress-error decoder))))))))
416
417(define lz-decompress-member-version
418 (let ((proc (lzlib-procedure int "LZ_decompress_member_version" '(*))))
419 (lambda (decoder)
420 (let ((ret (proc (lz-decoder->pointer decoder))))
421 "Return the version of current member from member header."
422 (if (= ret -1)
423 (throw 'lzlib-error 'lz-decompress-data-position
424 (lz-decompress-error decoder))
425 ret)))))
426
427(define lz-decompress-dictionary-size
428 (let ((proc (lzlib-procedure int "LZ_decompress_dictionary_size" '(*))))
429 (lambda (decoder)
430 (let ((ret (proc (lz-decoder->pointer decoder))))
431 "Return the dictionary size of current member from member header."
432 (if (= ret -1)
433 (throw 'lzlib-error 'lz-decompress-member-position
434 (lz-decompress-error decoder))
435 ret)))))
436
437(define lz-decompress-data-crc
438 (let ((proc (lzlib-procedure unsigned-int "LZ_decompress_data_crc" '(*))))
439 (lambda (decoder)
440 (let ((ret (proc (lz-decoder->pointer decoder))))
441 "Return the 32 bit Cyclic Redundancy Check of the data decompressed
442from the current member. The returned value is valid only when
443`lz-decompress-member-finished' returns #t. "
444 (if (= ret -1)
445 (throw 'lzlib-error 'lz-decompress-member-position
446 (lz-decompress-error decoder))
447 ret)))))
448
449(define lz-decompress-data-position
450 (let ((proc (lzlib-procedure uint64 "LZ_decompress_data_position" '(*))))
451 (lambda (decoder)
452 "Return the number of decompressed bytes already produced, but perhaps
453not yet read, in the current member."
454 (let ((ret (proc (lz-decoder->pointer decoder))))
455 (if (= ret -1)
456 (throw 'lzlib-error 'lz-decompress-data-position
457 (lz-decompress-error decoder))
458 ret)))))
459
460(define lz-decompress-member-position
461 (let ((proc (lzlib-procedure uint64 "LZ_decompress_member_position" '(*))))
462 (lambda (decoder)
463 "Return the number of input bytes already decompressed in the current
464member."
465 (let ((ret (proc (lz-decoder->pointer decoder))))
466 (if (= ret -1)
467 (throw 'lzlib-error 'lz-decompress-member-position
468 (lz-decompress-error decoder))
469 ret)))))
470
471(define lz-decompress-total-in-size
472 (let ((proc (lzlib-procedure uint64 "LZ_decompress_total_in_size" '(*))))
473 (lambda (decoder)
474 (let ((ret (proc (lz-decoder->pointer decoder))))
475 "Return the total number of input bytes already compressed."
476 (if (= ret -1)
477 (throw 'lzlib-error 'lz-decompress-total-in-size
478 (lz-decompress-error decoder))
479 ret)))))
480
481(define lz-decompress-total-out-size
482 (let ((proc (lzlib-procedure uint64 "LZ_decompress_total_out_size" '(*))))
483 (lambda (decoder)
484 (let ((ret (proc (lz-decoder->pointer decoder))))
485 "Return the total number of compressed bytes already produced, but
486perhaps not yet read."
487 (if (= ret -1)
488 (throw 'lzlib-error 'lz-decompress-total-out-size
489 (lz-decompress-error decoder))
490 ret)))))
491
492
493;; High level functions.
494(define %lz-decompress-input-buffer-size (* 64 1024))
495
496(define* (lzread! decoder file-port bv
497 #:optional (start 0) (count (bytevector-length bv)))
498 "Read up to COUNT bytes from FILE-PORT into BV at offset START. Return the
499number of uncompressed bytes actually read; it is zero if COUNT is zero or if
500the end-of-stream has been reached."
501 ;; WARNING: Because we don't alternate between lz-reads and lz-writes, we can't
502 ;; process more than %lz-decompress-input-buffer-size from the file-port.
503 (when (> count %lz-decompress-input-buffer-size)
504 (set! count %lz-decompress-input-buffer-size))
505 (let* ((written 0)
506 (read 0)
507 (file-bv (get-bytevector-n file-port count)))
508 (unless (eof-object? file-bv)
509 (begin
510 (while (and (< 0 (lz-decompress-write-size decoder))
511 (< written (bytevector-length file-bv)))
512 (set! written (+ written
513 (lz-decompress-write decoder file-bv written
514 (- (bytevector-length file-bv) written)))))))
515 (let loop ((rd 0))
516 (if (< start (bytevector-length bv))
517 (begin
518 (set! rd (lz-decompress-read decoder bv start (- (bytevector-length bv) start)))
519 (set! start (+ start rd))
520 (set! read (+ read rd)))
521 (set! rd 0))
522 (unless (= rd 0)
523 (loop rd)))
524 read))
525
526(define* (lzwrite encoder bv lz-port
527 #:optional (start 0) (count (bytevector-length bv)))
528 "Write up to COUNT bytes from BV at offset START into LZ-PORT. Return
529the number of uncompressed bytes written, a non-negative integer."
530 (let ((written 0)
531 (read 0))
532 (while (and (< 0 (lz-compress-write-size encoder))
533 (< written count))
534 (set! written (+ written
535 (lz-compress-write encoder bv (+ start written) (- count written)))))
536 (when (= written 0)
537 (lz-compress-finish encoder))
538 (let ((lz-bv (make-bytevector written)))
539 (let loop ((rd 0))
540 (set! rd (lz-compress-read encoder lz-bv 0 (bytevector-length lz-bv)))
541 (put-bytevector lz-port lz-bv 0 rd)
542 (set! read (+ read rd))
543 (unless (= rd 0)
544 (loop rd))))
545 ;; `written' is the total byte count of uncompressed data.
546 written))
547
548
549;;;
550;;; Port interface.
551;;;
552
553;; Alist of (levels (dictionary-size match-length-limit)). 0 is the fastest.
554;; See bbexample.c in lzlib's source.
555(define %compression-levels
556 `((0 (65535 16))
557 (1 (,(bitwise-arithmetic-shift-left 1 20) 5))
558 (2 (,(bitwise-arithmetic-shift-left 3 19) 6))
559 (3 (,(bitwise-arithmetic-shift-left 1 21) 8))
560 (4 (,(bitwise-arithmetic-shift-left 3 20) 12))
561 (5 (,(bitwise-arithmetic-shift-left 1 22) 20))
562 (6 (,(bitwise-arithmetic-shift-left 1 23) 36))
563 (7 (,(bitwise-arithmetic-shift-left 1 24) 68))
564 (8 (,(bitwise-arithmetic-shift-left 3 23) 132))
565 (9 (,(bitwise-arithmetic-shift-left 1 25) 273))))
566
567(define %default-compression-level
568 6)
569
570(define* (make-lzip-input-port port)
571 "Return an input port that decompresses data read from PORT, a file port.
572PORT is automatically closed when the resulting port is closed."
573 (define decoder (lz-decompress-open))
574
575 (define (read! bv start count)
576 (lzread! decoder port bv start count))
577
578 (make-custom-binary-input-port "lzip-input" read! #f #f
579 (lambda ()
580 (lz-decompress-close decoder)
581 (close-port port))))
582
583(define* (make-lzip-output-port port
584 #:key
585 (level %default-compression-level))
586 "Return an output port that compresses data at the given LEVEL, using PORT,
587a file port, as its sink. PORT is automatically closed when the resulting
588port is closed."
589 (define encoder (apply lz-compress-open
590 (car (assoc-ref %compression-levels level))))
591
592 (define (write! bv start count)
593 (lzwrite encoder bv port start count))
594
595 (make-custom-binary-output-port "lzip-output" write! #f #f
596 (lambda ()
597 (lz-compress-finish encoder)
598 ;; "lz-read" the trailing metadata added by `lz-compress-finish'.
599 (let ((lz-bv (make-bytevector (* 64 1024))))
600 (let loop ((rd 0))
601 (set! rd (lz-compress-read encoder lz-bv 0 (bytevector-length lz-bv)))
602 (put-bytevector port lz-bv 0 rd)
603 (unless (= rd 0)
604 (loop rd))))
605 (lz-compress-close encoder)
606 (close-port port))))
607
608(define* (call-with-lzip-input-port port proc)
609 "Call PROC with a port that wraps PORT and decompresses data read from it.
610PORT is closed upon completion."
611 (let ((lzip (make-lzip-input-port port)))
612 (dynamic-wind
613 (const #t)
614 (lambda ()
615 (proc lzip))
616 (lambda ()
617 (close-port lzip)))))
618
619(define* (call-with-lzip-output-port port proc
620 #:key
621 (level %default-compression-level))
622 "Call PROC with an output port that wraps PORT and compresses data. PORT is
623close upon completion."
624 (let ((lzip (make-lzip-output-port port
625 #:level level)))
626 (dynamic-wind
627 (const #t)
628 (lambda ()
629 (proc lzip))
630 (lambda ()
631 (close-port lzip)))))
632
633;;; lzlib.scm ends here
diff --git a/guix/self.scm b/guix/self.scm
index 7098e4ea29a..74ea65240cd 100644
--- a/guix/self.scm
+++ b/guix/self.scm
@@ -925,6 +925,7 @@ Info manual."
925 %store-database-directory 925 %store-database-directory
926 %config-directory 926 %config-directory
927 %libz 927 %libz
928 ;; TODO: %liblz
928 %gzip 929 %gzip
929 %bzip2 930 %bzip2
930 %xz)) 931 %xz))
diff --git a/m4/guix.m4 b/m4/guix.m4
index 5c846f76180..d0c5ec0f083 100644
--- a/m4/guix.m4
+++ b/m4/guix.m4
@@ -1,5 +1,5 @@
1dnl GNU Guix --- Functional package management for GNU 1dnl GNU Guix --- Functional package management for GNU
2dnl Copyright © 2012, 2013, 2014, 2015, 2016, 2018 Ludovic Courtès <ludo@gnu.org> 2dnl Copyright © 2012, 2013, 2014, 2015, 2016, 2018, 2019 Ludovic Courtès <ludo@gnu.org>
3dnl Copyright © 2014 Mark H Weaver <mhw@netris.org> 3dnl Copyright © 2014 Mark H Weaver <mhw@netris.org>
4dnl Copyright © 2017 Efraim Flashner <efraim@flashner.co.il> 4dnl Copyright © 2017 Efraim Flashner <efraim@flashner.co.il>
5dnl 5dnl
@@ -312,6 +312,21 @@ AC_DEFUN([GUIX_LIBZ_LIBDIR], [
312 $1="$guix_cv_libz_libdir" 312 $1="$guix_cv_libz_libdir"
313]) 313])
314 314
315dnl GUIX_LIBLZ_FILE_NAME VAR
316dnl
317dnl Attempt to determine liblz's absolute file name; store the result in VAR.
318AC_DEFUN([GUIX_LIBLZ_FILE_NAME], [
319 AC_REQUIRE([PKG_PROG_PKG_CONFIG])
320 AC_CACHE_CHECK([lzlib's file name],
321 [guix_cv_liblz_libdir],
322 [old_LIBS="$LIBS"
323 LIBS="-llz"
324 AC_LINK_IFELSE([AC_LANG_SOURCE([int main () { return LZ_decompress_open(); }])],
325 [guix_cv_liblz_libdir="`ldd conftest$EXEEXT | grep liblz | sed '-es/.*=> \(.*\) .*$/\1/g'`"])
326 LIBS="$old_LIBS"])
327 $1="$guix_cv_liblz_libdir"
328])
329
315dnl GUIX_CURRENT_LOCALSTATEDIR 330dnl GUIX_CURRENT_LOCALSTATEDIR
316dnl 331dnl
317dnl Determine the localstatedir of an existing Guix installation and set 332dnl 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 00000000000..cf53a9417d5
--- /dev/null
+++ b/tests/lzlib.scm
@@ -0,0 +1,111 @@
1;;; GNU Guix --- Functional package management for GNU
2;;; Copyright © 2019 Pierre Neidhardt <mail@ambrevar.xyz>
3;;;
4;;; This file is part of GNU Guix.
5;;;
6;;; GNU Guix is free software; you can redistribute it and/or modify it
7;;; under the terms of the GNU General Public License as published by
8;;; the Free Software Foundation; either version 3 of the License, or (at
9;;; your option) any later version.
10;;;
11;;; GNU Guix is distributed in the hope that it will be useful, but
12;;; WITHOUT ANY WARRANTY; without even the implied warranty of
13;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
14;;; GNU General Public License for more details.
15;;;
16;;; You should have received a copy of the GNU General Public License
17;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
18
19(define-module (test-lzlib)
20 #:use-module (guix lzlib)
21 #:use-module (guix tests)
22 #:use-module (srfi srfi-64)
23 #:use-module (rnrs bytevectors)
24 #:use-module (rnrs io ports)
25 #:use-module (ice-9 match))
26
27;; Test the (guix lzlib) module.
28
29(define-syntax-rule (test-assert* description exp)
30 (begin
31 (unless (lzlib-available?)
32 (test-skip 1))
33 (test-assert description exp)))
34
35(test-begin "lzlib")
36
37(define (compress-and-decompress data)
38 "DATA must be a bytevector."
39 (pk "Uncompressed bytes:" (bytevector-length data))
40 (match (pipe)
41 ((parent . child)
42 (match (primitive-fork)
43 (0 ;compress
44 (dynamic-wind
45 (const #t)
46 (lambda ()
47 (close-port parent)
48 (call-with-lzip-output-port child
49 (lambda (port)
50 (put-bytevector port data))))
51 (lambda ()
52 (primitive-exit 0))))
53 (pid ;decompress
54 (begin
55 (close-port child)
56 (let ((received (call-with-lzip-input-port parent
57 (lambda (port)
58 (get-bytevector-all port)))))
59 (match (waitpid pid)
60 ((_ . status)
61 (pk "Status" status)
62 (pk "Length data" (bytevector-length data) "received" (bytevector-length received))
63 ;; The following loop is a debug helper.
64 (let loop ((i 0))
65 (if (and (< i (bytevector-length received))
66 (= (bytevector-u8-ref received i)
67 (bytevector-u8-ref data i)))
68 (loop (+ 1 i))
69 (pk "First diff at index" i)))
70 (and (zero? status)
71 (port-closed? parent)
72 (bytevector=? received data)))))))))))
73
74(test-assert* "null bytevector"
75 (compress-and-decompress (make-bytevector (+ (random 100000)
76 (* 20 1024)))))
77
78(test-assert* "random bytevector"
79 (compress-and-decompress (random-bytevector (+ (random 100000)
80 (* 20 1024)))))
81(test-assert* "small bytevector"
82 (compress-and-decompress (random-bytevector 127)))
83
84(test-assert* "1 bytevector"
85 (compress-and-decompress (random-bytevector 1)))
86
87(test-assert* "Bytevector of size relative to Lzip internal buffers (2 * dictionary)"
88 (compress-and-decompress
89 (random-bytevector
90 (* 2 (car (car (assoc-ref (@@ (guix lzlib) %compression-levels)
91 (@@ (guix lzlib) %default-compression-level))))))))
92
93(test-assert* "Bytevector of size relative to Lzip internal buffers (64KiB)"
94 (compress-and-decompress (random-bytevector (* 64 1024))))
95
96(test-assert* "Bytevector of size relative to Lzip internal buffers (64KiB-1)"
97 (compress-and-decompress (random-bytevector (1- (* 64 1024)))))
98
99(test-assert* "Bytevector of size relative to Lzip internal buffers (64KiB+1)"
100 (compress-and-decompress (random-bytevector (1+ (* 64 1024)))))
101
102(test-assert* "Bytevector of size relative to Lzip internal buffers (1MiB)"
103 (compress-and-decompress (random-bytevector (* 1024 1024))))
104
105(test-assert* "Bytevector of size relative to Lzip internal buffers (1MiB-1)"
106 (compress-and-decompress (random-bytevector (1- (* 1024 1024)))))
107
108(test-assert* "Bytevector of size relative to Lzip internal buffers (1MiB+1)"
109 (compress-and-decompress (random-bytevector (1+ (* 1024 1024)))))
110
111(test-end)