Commit | Line | Data |
---|---|---|
fea338c6 PN |
1 | ;;; GNU Guix --- Functional package management for GNU |
2 | ;;; Copyright © 2019 Pierre Neidhardt <mail@ambrevar.xyz> | |
2a991f3a | 3 | ;;; Copyright © 2019 Ludovic Courtès <ludo@gnu.org> |
fea338c6 PN |
4 | ;;; |
5 | ;;; This file is part of GNU Guix. | |
6 | ;;; | |
7 | ;;; GNU Guix is free software; you can redistribute it and/or modify it | |
8 | ;;; under the terms of the GNU General Public License as published by | |
9 | ;;; the Free Software Foundation; either version 3 of the License, or (at | |
10 | ;;; your option) any later version. | |
11 | ;;; | |
12 | ;;; GNU Guix is distributed in the hope that it will be useful, but | |
13 | ;;; WITHOUT ANY WARRANTY; without even the implied warranty of | |
14 | ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | |
15 | ;;; GNU General Public License for more details. | |
16 | ;;; | |
17 | ;;; You should have received a copy of the GNU General Public License | |
18 | ;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>. | |
19 | ||
20 | (define-module (guix lzlib) | |
21 | #:use-module (rnrs bytevectors) | |
22 | #:use-module (rnrs arithmetic bitwise) | |
23 | #:use-module (ice-9 binary-ports) | |
24 | #:use-module (ice-9 match) | |
25 | #:use-module (system foreign) | |
26 | #:use-module (guix config) | |
2a991f3a | 27 | #:use-module (srfi srfi-11) |
fea338c6 PN |
28 | #:export (lzlib-available? |
29 | make-lzip-input-port | |
30 | make-lzip-output-port | |
2a991f3a | 31 | make-lzip-input-port/compressed |
fea338c6 PN |
32 | call-with-lzip-input-port |
33 | call-with-lzip-output-port | |
34 | %default-member-length-limit | |
35 | %default-compression-level)) | |
36 | ||
37 | ;;; Commentary: | |
38 | ;;; | |
39 | ;;; Bindings to the lzlib / liblz API. Some convenience functions are also | |
40 | ;;; provided (see the export). | |
41 | ;;; | |
42 | ;;; While the bindings are complete, the convenience functions only support | |
43 | ;;; single member archives. To decompress single member archives, we loop | |
44 | ;;; until lz-decompress-read returns 0. This is simpler. To support multiple | |
45 | ;;; members properly, we need (among others) to call lz-decompress-finish and | |
46 | ;;; loop over lz-decompress-read until lz-decompress-finished? returns #t. | |
47 | ;;; Otherwise a multi-member archive starting with an empty member would only | |
48 | ;;; decompress the empty member and stop there, resulting in truncated output. | |
49 | ||
50 | ;;; Code: | |
51 | ||
52 | (define %lzlib | |
53 | ;; File name of lzlib's shared library. When updating via 'guix pull', | |
54 | ;; '%liblz' might be undefined so protect against it. | |
55 | (delay (dynamic-link (if (defined? '%liblz) | |
56 | %liblz | |
57 | "liblz")))) | |
58 | ||
59 | (define (lzlib-available?) | |
60 | "Return true if lzlib is available, #f otherwise." | |
61 | (false-if-exception (force %lzlib))) | |
62 | ||
63 | (define (lzlib-procedure ret name parameters) | |
64 | "Return a procedure corresponding to C function NAME in liblz, or #f if | |
65 | either lzlib or the function could not be found." | |
66 | (match (false-if-exception (dynamic-func name (force %lzlib))) | |
67 | ((? pointer? ptr) | |
68 | (pointer->procedure ret ptr parameters)) | |
69 | (#f | |
70 | #f))) | |
71 | ||
72 | (define-wrapped-pointer-type <lz-decoder> | |
73 | ;; Scheme counterpart of the 'LZ_Decoder' opaque type. | |
74 | lz-decoder? | |
75 | pointer->lz-decoder | |
76 | lz-decoder->pointer | |
77 | (lambda (obj port) | |
78 | (format port "#<lz-decoder ~a>" | |
79 | (number->string (object-address obj) 16)))) | |
80 | ||
81 | (define-wrapped-pointer-type <lz-encoder> | |
82 | ;; Scheme counterpart of the 'LZ_Encoder' opaque type. | |
83 | lz-encoder? | |
84 | pointer->lz-encoder | |
85 | lz-encoder->pointer | |
86 | (lambda (obj port) | |
87 | (format port "#<lz-encoder ~a>" | |
88 | (number->string (object-address obj) 16)))) | |
89 | ||
90 | ;; From lzlib.h | |
91 | (define %error-number-ok 0) | |
92 | (define %error-number-bad-argument 1) | |
93 | (define %error-number-mem-error 2) | |
94 | (define %error-number-sequence-error 3) | |
95 | (define %error-number-header-error 4) | |
96 | (define %error-number-unexpected-eof 5) | |
97 | (define %error-number-data-error 6) | |
98 | (define %error-number-library-error 7) | |
99 | ||
100 | \f | |
101 | ;; Compression bindings. | |
102 | ||
103 | (define lz-compress-open | |
104 | (let ((proc (lzlib-procedure '* "LZ_compress_open" (list int int uint64))) | |
105 | ;; member-size is an "unsigned long long", and the C standard guarantees | |
106 | ;; a minimum range of 0..2^64-1. | |
107 | (unlimited-size (- (expt 2 64) 1))) | |
108 | (lambda* (dictionary-size match-length-limit #:optional (member-size unlimited-size)) | |
109 | "Initialize the internal stream state for compression and returns a | |
110 | pointer that can only be used as the encoder argument for the other | |
111 | lz-compress functions, or a null pointer if the encoder could not be | |
112 | allocated. | |
113 | ||
114 | See the manual: (lzlib) Compression functions." | |
115 | (let ((encoder-ptr (proc dictionary-size match-length-limit member-size))) | |
116 | (if (not (= (lz-compress-error encoder-ptr) -1)) | |
117 | (pointer->lz-encoder encoder-ptr) | |
118 | (throw 'lzlib-error 'lz-compress-open)))))) | |
119 | ||
120 | (define lz-compress-close | |
121 | (let ((proc (lzlib-procedure int "LZ_compress_close" '(*)))) | |
122 | (lambda (encoder) | |
123 | "Close encoder. ENCODER can no longer be used as an argument to any | |
124 | lz-compress function. " | |
125 | (let ((ret (proc (lz-encoder->pointer encoder)))) | |
126 | (if (= ret -1) | |
127 | (throw 'lzlib-error 'lz-compress-close ret) | |
128 | ret))))) | |
129 | ||
130 | (define lz-compress-finish | |
131 | (let ((proc (lzlib-procedure int "LZ_compress_finish" '(*)))) | |
132 | (lambda (encoder) | |
133 | "Tell that all the data for this member have already been written (with | |
134 | the `lz-compress-write' function). It is safe to call `lz-compress-finish' as | |
135 | many times as needed. After all the produced compressed data have been read | |
136 | with `lz-compress-read' and `lz-compress-member-finished?' returns #t, a new | |
137 | member can be started with 'lz-compress-restart-member'." | |
138 | (let ((ret (proc (lz-encoder->pointer encoder)))) | |
139 | (if (= ret -1) | |
140 | (throw 'lzlib-error 'lz-compress-finish (lz-compress-error encoder)) | |
141 | ret))))) | |
142 | ||
143 | (define lz-compress-restart-member | |
144 | (let ((proc (lzlib-procedure int "LZ_compress_restart_member" (list '* uint64)))) | |
145 | (lambda (encoder member-size) | |
146 | "Start a new member in a multimember data stream. | |
147 | Call this function only after `lz-compress-member-finished?' indicates that the | |
148 | current member has been fully read (with the `lz-compress-read' function)." | |
149 | (let ((ret (proc (lz-encoder->pointer encoder) member-size))) | |
150 | (if (= ret -1) | |
151 | (throw 'lzlib-error 'lz-compress-restart-member | |
152 | (lz-compress-error encoder)) | |
153 | ret))))) | |
154 | ||
155 | (define lz-compress-sync-flush | |
156 | (let ((proc (lzlib-procedure int "LZ_compress_sync_flush" (list '*)))) | |
157 | (lambda (encoder) | |
158 | "Make available to `lz-compress-read' all the data already written with | |
159 | the `LZ-compress-write' function. First call `lz-compress-sync-flush'. Then | |
160 | call 'lz-compress-read' until it returns 0. | |
161 | ||
162 | Repeated use of `LZ-compress-sync-flush' may degrade compression ratio, | |
163 | so use it only when needed. " | |
164 | (let ((ret (proc (lz-encoder->pointer encoder)))) | |
165 | (if (= ret -1) | |
166 | (throw 'lzlib-error 'lz-compress-sync-flush | |
167 | (lz-compress-error encoder)) | |
168 | ret))))) | |
169 | ||
170 | (define lz-compress-read | |
171 | (let ((proc (lzlib-procedure int "LZ_compress_read" (list '* '* int)))) | |
172 | (lambda* (encoder lzfile-bv #:optional (start 0) (count (bytevector-length lzfile-bv))) | |
173 | "Read up to COUNT bytes from the encoder stream, storing the results in LZFILE-BV. | |
e13354a7 | 174 | Return the number of uncompressed bytes written, a positive integer." |
fea338c6 PN |
175 | (let ((ret (proc (lz-encoder->pointer encoder) |
176 | (bytevector->pointer lzfile-bv start) | |
177 | count))) | |
178 | (if (= ret -1) | |
179 | (throw 'lzlib-error 'lz-compress-read (lz-compress-error encoder)) | |
180 | ret))))) | |
181 | ||
182 | (define lz-compress-write | |
183 | (let ((proc (lzlib-procedure int "LZ_compress_write" (list '* '* int)))) | |
184 | (lambda* (encoder bv #:optional (start 0) (count (bytevector-length bv))) | |
185 | "Write up to COUNT bytes from BV to the encoder stream. Return the | |
186 | number of uncompressed bytes written, a strictly positive integer." | |
187 | (let ((ret (proc (lz-encoder->pointer encoder) | |
188 | (bytevector->pointer bv start) | |
189 | count))) | |
190 | (if (< ret 0) | |
191 | (throw 'lzlib-error 'lz-compress-write (lz-compress-error encoder)) | |
192 | ret))))) | |
193 | ||
194 | (define lz-compress-write-size | |
195 | (let ((proc (lzlib-procedure int "LZ_compress_write_size" '(*)))) | |
196 | (lambda (encoder) | |
197 | "The maximum number of bytes that can be immediately written through the | |
198 | `lz-compress-write' function. | |
199 | ||
200 | It is guaranteed that an immediate call to `lz-compress-write' will accept a | |
201 | SIZE up to the returned number of bytes. " | |
202 | (let ((ret (proc (lz-encoder->pointer encoder)))) | |
203 | (if (= ret -1) | |
204 | (throw 'lzlib-error 'lz-compress-write-size (lz-compress-error encoder)) | |
205 | ret))))) | |
206 | ||
207 | (define lz-compress-error | |
208 | (let ((proc (lzlib-procedure int "LZ_compress_errno" '(*)))) | |
209 | (lambda (encoder) | |
210 | "ENCODER can be a Scheme object or a pointer." | |
211 | (let* ((error-number (proc (if (lz-encoder? encoder) | |
212 | (lz-encoder->pointer encoder) | |
213 | encoder)))) | |
214 | error-number)))) | |
215 | ||
216 | (define lz-compress-finished? | |
217 | (let ((proc (lzlib-procedure int "LZ_compress_finished" '(*)))) | |
218 | (lambda (encoder) | |
219 | "Return #t if all the data have been read and `lz-compress-close' can | |
220 | be safely called. Otherwise return #f." | |
221 | (let ((ret (proc (lz-encoder->pointer encoder)))) | |
222 | (match ret | |
223 | (1 #t) | |
224 | (0 #f) | |
225 | (_ (throw 'lzlib-error 'lz-compress-finished? (lz-compress-error encoder)))))))) | |
226 | ||
227 | (define lz-compress-member-finished? | |
228 | (let ((proc (lzlib-procedure int "LZ_compress_member_finished" '(*)))) | |
229 | (lambda (encoder) | |
230 | "Return #t if the current member, in a multimember data stream, has | |
231 | been fully read and 'lz-compress-restart-member' can be safely called. | |
232 | Otherwise return #f." | |
233 | (let ((ret (proc (lz-encoder->pointer encoder)))) | |
234 | (match ret | |
235 | (1 #t) | |
236 | (0 #f) | |
237 | (_ (throw 'lzlib-error 'lz-compress-member-finished? (lz-compress-error encoder)))))))) | |
238 | ||
239 | (define lz-compress-data-position | |
240 | (let ((proc (lzlib-procedure uint64 "LZ_compress_data_position" '(*)))) | |
241 | (lambda (encoder) | |
242 | "Return the number of input bytes already compressed in the current | |
243 | member." | |
244 | (let ((ret (proc (lz-encoder->pointer encoder)))) | |
245 | (if (= ret -1) | |
246 | (throw 'lzlib-error 'lz-compress-data-position | |
247 | (lz-compress-error encoder)) | |
248 | ret))))) | |
249 | ||
250 | (define lz-compress-member-position | |
251 | (let ((proc (lzlib-procedure uint64 "LZ_compress_member_position" '(*)))) | |
252 | (lambda (encoder) | |
253 | "Return the number of compressed bytes already produced, but perhaps | |
254 | not yet read, in the current member." | |
255 | (let ((ret (proc (lz-encoder->pointer encoder)))) | |
256 | (if (= ret -1) | |
257 | (throw 'lzlib-error 'lz-compress-member-position | |
258 | (lz-compress-error encoder)) | |
259 | ret))))) | |
260 | ||
261 | (define lz-compress-total-in-size | |
262 | (let ((proc (lzlib-procedure uint64 "LZ_compress_total_in_size" '(*)))) | |
263 | (lambda (encoder) | |
264 | "Return the total number of input bytes already compressed." | |
265 | (let ((ret (proc (lz-encoder->pointer encoder)))) | |
266 | (if (= ret -1) | |
267 | (throw 'lzlib-error 'lz-compress-total-in-size | |
268 | (lz-compress-error encoder)) | |
269 | ret))))) | |
270 | ||
271 | (define lz-compress-total-out-size | |
272 | (let ((proc (lzlib-procedure uint64 "LZ_compress_total_out_size" '(*)))) | |
273 | (lambda (encoder) | |
274 | "Return the total number of compressed bytes already produced, but | |
275 | perhaps not yet read." | |
276 | (let ((ret (proc (lz-encoder->pointer encoder)))) | |
277 | (if (= ret -1) | |
278 | (throw 'lzlib-error 'lz-compress-total-out-size | |
279 | (lz-compress-error encoder)) | |
280 | ret))))) | |
281 | ||
282 | \f | |
283 | ;; Decompression bindings. | |
284 | ||
285 | (define lz-decompress-open | |
286 | (let ((proc (lzlib-procedure '* "LZ_decompress_open" '()))) | |
287 | (lambda () | |
288 | "Initializes the internal stream state for decompression and returns a | |
289 | pointer that can only be used as the decoder argument for the other | |
290 | lz-decompress functions, or a null pointer if the decoder could not be | |
291 | allocated. | |
292 | ||
293 | See the manual: (lzlib) Decompression functions." | |
294 | (let ((decoder-ptr (proc))) | |
295 | (if (not (= (lz-decompress-error decoder-ptr) -1)) | |
296 | (pointer->lz-decoder decoder-ptr) | |
297 | (throw 'lzlib-error 'lz-decompress-open)))))) | |
298 | ||
299 | (define lz-decompress-close | |
300 | (let ((proc (lzlib-procedure int "LZ_decompress_close" '(*)))) | |
301 | (lambda (decoder) | |
302 | "Close decoder. DECODER can no longer be used as an argument to any | |
303 | lz-decompress function. " | |
304 | (let ((ret (proc (lz-decoder->pointer decoder)))) | |
305 | (if (= ret -1) | |
306 | (throw 'lzlib-error 'lz-decompress-close ret) | |
307 | ret))))) | |
308 | ||
309 | (define lz-decompress-finish | |
310 | (let ((proc (lzlib-procedure int "LZ_decompress_finish" '(*)))) | |
311 | (lambda (decoder) | |
312 | "Tell that all the data for this stream have already been written (with | |
313 | the `lz-decompress-write' function). It is safe to call | |
314 | `lz-decompress-finish' as many times as needed." | |
315 | (let ((ret (proc (lz-decoder->pointer decoder)))) | |
316 | (if (= ret -1) | |
317 | (throw 'lzlib-error 'lz-decompress-finish (lz-decompress-error decoder)) | |
318 | ret))))) | |
319 | ||
320 | (define lz-decompress-reset | |
321 | (let ((proc (lzlib-procedure int "LZ_decompress_reset" '(*)))) | |
322 | (lambda (decoder) | |
323 | "Reset the internal state of DECODER as it was just after opening it | |
324 | with the `lz-decompress-open' function. Data stored in the internal buffers | |
325 | is discarded. Position counters are set to 0." | |
326 | (let ((ret (proc (lz-decoder->pointer decoder)))) | |
327 | (if (= ret -1) | |
328 | (throw 'lzlib-error 'lz-decompress-reset | |
329 | (lz-decompress-error decoder)) | |
330 | ret))))) | |
331 | ||
332 | (define lz-decompress-sync-to-member | |
333 | (let ((proc (lzlib-procedure int "LZ_decompress_sync_to_member" '(*)))) | |
334 | (lambda (decoder) | |
335 | "Reset the error state of DECODER and enters a search state that lasts | |
336 | until a new member header (or the end of the stream) is found. After a | |
337 | successful call to `lz-decompress-sync-to-member', data written with | |
338 | `lz-decompress-write' will be consumed and 'lz-decompress-read' will return 0 | |
339 | until a header is found. | |
340 | ||
341 | This function is useful to discard any data preceding the first member, or to | |
342 | discard the rest of the current member, for example in case of a data | |
343 | error. If the decoder is already at the beginning of a member, this function | |
344 | does nothing." | |
345 | (let ((ret (proc (lz-decoder->pointer decoder)))) | |
346 | (if (= ret -1) | |
347 | (throw 'lzlib-error 'lz-decompress-sync-to-member | |
348 | (lz-decompress-error decoder)) | |
349 | ret))))) | |
350 | ||
351 | (define lz-decompress-read | |
352 | (let ((proc (lzlib-procedure int "LZ_decompress_read" (list '* '* int)))) | |
353 | (lambda* (decoder file-bv #:optional (start 0) (count (bytevector-length file-bv))) | |
354 | "Read up to COUNT bytes from the decoder stream, storing the results in FILE-BV. | |
355 | Return the number of uncompressed bytes written, a non-negative positive integer." | |
356 | (let ((ret (proc (lz-decoder->pointer decoder) | |
357 | (bytevector->pointer file-bv start) | |
358 | count))) | |
359 | (if (< ret 0) | |
360 | (throw 'lzlib-error 'lz-decompress-read (lz-decompress-error decoder)) | |
361 | ret))))) | |
362 | ||
363 | (define lz-decompress-write | |
364 | (let ((proc (lzlib-procedure int "LZ_decompress_write" (list '* '* int)))) | |
365 | (lambda* (decoder bv #:optional (start 0) (count (bytevector-length bv))) | |
366 | "Write up to COUNT bytes from BV to the decoder stream. Return the | |
367 | number of uncompressed bytes written, a non-negative integer." | |
368 | (let ((ret (proc (lz-decoder->pointer decoder) | |
369 | (bytevector->pointer bv start) | |
370 | count))) | |
371 | (if (< ret 0) | |
372 | (throw 'lzlib-error 'lz-decompress-write (lz-decompress-error decoder)) | |
373 | ret))))) | |
374 | ||
375 | (define lz-decompress-write-size | |
376 | (let ((proc (lzlib-procedure int "LZ_decompress_write_size" '(*)))) | |
377 | (lambda (decoder) | |
378 | "Return the maximum number of bytes that can be immediately written | |
379 | through the `lz-decompress-write' function. | |
380 | ||
381 | It is guaranteed that an immediate call to `lz-decompress-write' will accept a | |
382 | SIZE up to the returned number of bytes. " | |
383 | (let ((ret (proc (lz-decoder->pointer decoder)))) | |
384 | (if (= ret -1) | |
385 | (throw 'lzlib-error 'lz-decompress-write-size (lz-decompress-error decoder)) | |
386 | ret))))) | |
387 | ||
388 | (define lz-decompress-error | |
389 | (let ((proc (lzlib-procedure int "LZ_decompress_errno" '(*)))) | |
390 | (lambda (decoder) | |
391 | "DECODER can be a Scheme object or a pointer." | |
392 | (let* ((error-number (proc (if (lz-decoder? decoder) | |
393 | (lz-decoder->pointer decoder) | |
394 | decoder)))) | |
395 | error-number)))) | |
396 | ||
397 | (define lz-decompress-finished? | |
398 | (let ((proc (lzlib-procedure int "LZ_decompress_finished" '(*)))) | |
399 | (lambda (decoder) | |
400 | "Return #t if all the data have been read and `lz-decompress-close' can | |
401 | be safely called. Otherwise return #f." | |
402 | (let ((ret (proc (lz-decoder->pointer decoder)))) | |
403 | (match ret | |
404 | (1 #t) | |
405 | (0 #f) | |
406 | (_ (throw 'lzlib-error 'lz-decompress-finished? (lz-decompress-error decoder)))))))) | |
407 | ||
408 | (define lz-decompress-member-finished? | |
409 | (let ((proc (lzlib-procedure int "LZ_decompress_member_finished" '(*)))) | |
410 | (lambda (decoder) | |
411 | "Return #t if the current member, in a multimember data stream, has | |
412 | been fully read and `lz-decompress-restart-member' can be safely called. | |
413 | Otherwise return #f." | |
414 | (let ((ret (proc (lz-decoder->pointer decoder)))) | |
415 | (match ret | |
416 | (1 #t) | |
417 | (0 #f) | |
418 | (_ (throw 'lzlib-error 'lz-decompress-member-finished? (lz-decompress-error decoder)))))))) | |
419 | ||
420 | (define lz-decompress-member-version | |
421 | (let ((proc (lzlib-procedure int "LZ_decompress_member_version" '(*)))) | |
422 | (lambda (decoder) | |
423 | (let ((ret (proc (lz-decoder->pointer decoder)))) | |
424 | "Return the version of current member from member header." | |
425 | (if (= ret -1) | |
426 | (throw 'lzlib-error 'lz-decompress-data-position | |
427 | (lz-decompress-error decoder)) | |
428 | ret))))) | |
429 | ||
430 | (define lz-decompress-dictionary-size | |
431 | (let ((proc (lzlib-procedure int "LZ_decompress_dictionary_size" '(*)))) | |
432 | (lambda (decoder) | |
433 | (let ((ret (proc (lz-decoder->pointer decoder)))) | |
434 | "Return the dictionary size of current member from member header." | |
435 | (if (= ret -1) | |
436 | (throw 'lzlib-error 'lz-decompress-member-position | |
437 | (lz-decompress-error decoder)) | |
438 | ret))))) | |
439 | ||
440 | (define lz-decompress-data-crc | |
441 | (let ((proc (lzlib-procedure unsigned-int "LZ_decompress_data_crc" '(*)))) | |
442 | (lambda (decoder) | |
443 | (let ((ret (proc (lz-decoder->pointer decoder)))) | |
444 | "Return the 32 bit Cyclic Redundancy Check of the data decompressed | |
445 | from the current member. The returned value is valid only when | |
446 | `lz-decompress-member-finished' returns #t. " | |
447 | (if (= ret -1) | |
448 | (throw 'lzlib-error 'lz-decompress-member-position | |
449 | (lz-decompress-error decoder)) | |
450 | ret))))) | |
451 | ||
452 | (define lz-decompress-data-position | |
453 | (let ((proc (lzlib-procedure uint64 "LZ_decompress_data_position" '(*)))) | |
454 | (lambda (decoder) | |
455 | "Return the number of decompressed bytes already produced, but perhaps | |
456 | not yet read, in the current member." | |
457 | (let ((ret (proc (lz-decoder->pointer decoder)))) | |
458 | (if (= ret -1) | |
459 | (throw 'lzlib-error 'lz-decompress-data-position | |
460 | (lz-decompress-error decoder)) | |
461 | ret))))) | |
462 | ||
463 | (define lz-decompress-member-position | |
464 | (let ((proc (lzlib-procedure uint64 "LZ_decompress_member_position" '(*)))) | |
465 | (lambda (decoder) | |
466 | "Return the number of input bytes already decompressed in the current | |
467 | member." | |
468 | (let ((ret (proc (lz-decoder->pointer decoder)))) | |
469 | (if (= ret -1) | |
470 | (throw 'lzlib-error 'lz-decompress-member-position | |
471 | (lz-decompress-error decoder)) | |
472 | ret))))) | |
473 | ||
474 | (define lz-decompress-total-in-size | |
475 | (let ((proc (lzlib-procedure uint64 "LZ_decompress_total_in_size" '(*)))) | |
476 | (lambda (decoder) | |
477 | (let ((ret (proc (lz-decoder->pointer decoder)))) | |
478 | "Return the total number of input bytes already compressed." | |
479 | (if (= ret -1) | |
480 | (throw 'lzlib-error 'lz-decompress-total-in-size | |
481 | (lz-decompress-error decoder)) | |
482 | ret))))) | |
483 | ||
484 | (define lz-decompress-total-out-size | |
485 | (let ((proc (lzlib-procedure uint64 "LZ_decompress_total_out_size" '(*)))) | |
486 | (lambda (decoder) | |
487 | (let ((ret (proc (lz-decoder->pointer decoder)))) | |
488 | "Return the total number of compressed bytes already produced, but | |
489 | perhaps not yet read." | |
490 | (if (= ret -1) | |
491 | (throw 'lzlib-error 'lz-decompress-total-out-size | |
492 | (lz-decompress-error decoder)) | |
493 | ret))))) | |
494 | ||
495 | \f | |
496 | ;; High level functions. | |
c131bea2 LC |
497 | |
498 | (define* (lzread! decoder port bv | |
fea338c6 | 499 | #:optional (start 0) (count (bytevector-length bv))) |
c131bea2 | 500 | "Read up to COUNT bytes from PORT into BV at offset START. Return the |
fea338c6 PN |
501 | number of uncompressed bytes actually read; it is zero if COUNT is zero or if |
502 | the end-of-stream has been reached." | |
c131bea2 LC |
503 | (define (feed-decoder! decoder) |
504 | ;; Feed DECODER with data read from PORT. | |
505 | (match (get-bytevector-n port (lz-decompress-write-size decoder)) | |
506 | ((? eof-object? eof) eof) | |
507 | (bv (lz-decompress-write decoder bv)))) | |
508 | ||
509 | (let loop ((read 0) | |
510 | (start start)) | |
511 | (cond ((< read count) | |
512 | (match (lz-decompress-read decoder bv start (- count read)) | |
87399dfc LC |
513 | (0 (cond ((lz-decompress-finished? decoder) |
514 | read) | |
515 | ((eof-object? (feed-decoder! decoder)) | |
516 | (lz-decompress-finish decoder) | |
517 | (loop read start)) | |
518 | (else ;read again | |
519 | (loop read start)))) | |
c131bea2 LC |
520 | (n (loop (+ read n) (+ start n))))) |
521 | (else | |
522 | read)))) | |
fea338c6 | 523 | |
2a991f3a LC |
524 | (define (lzwrite! encoder source source-offset source-count |
525 | target target-offset target-count) | |
526 | "Write up to SOURCE-COUNT bytes from SOURCE to ENCODER, and read up to | |
527 | TARGET-COUNT bytes into TARGET at TARGET-OFFSET. Return two values: the | |
528 | number of bytes read from SOURCE, and the number of bytes written to TARGET, | |
529 | possibly zero." | |
530 | (define read | |
531 | (if (> (lz-compress-write-size encoder) 0) | |
532 | (match (lz-compress-write encoder source source-offset source-count) | |
533 | (0 (lz-compress-finish encoder) 0) | |
534 | (n n)) | |
535 | 0)) | |
536 | ||
537 | (define written | |
538 | (lz-compress-read encoder target target-offset target-count)) | |
539 | ||
540 | (values read written)) | |
541 | ||
fea338c6 PN |
542 | (define* (lzwrite encoder bv lz-port |
543 | #:optional (start 0) (count (bytevector-length bv))) | |
544 | "Write up to COUNT bytes from BV at offset START into LZ-PORT. Return | |
545 | the number of uncompressed bytes written, a non-negative integer." | |
546 | (let ((written 0) | |
547 | (read 0)) | |
548 | (while (and (< 0 (lz-compress-write-size encoder)) | |
549 | (< written count)) | |
550 | (set! written (+ written | |
551 | (lz-compress-write encoder bv (+ start written) (- count written))))) | |
552 | (when (= written 0) | |
553 | (lz-compress-finish encoder)) | |
554 | (let ((lz-bv (make-bytevector written))) | |
555 | (let loop ((rd 0)) | |
556 | (set! rd (lz-compress-read encoder lz-bv 0 (bytevector-length lz-bv))) | |
557 | (put-bytevector lz-port lz-bv 0 rd) | |
558 | (set! read (+ read rd)) | |
559 | (unless (= rd 0) | |
560 | (loop rd)))) | |
561 | ;; `written' is the total byte count of uncompressed data. | |
562 | written)) | |
563 | ||
564 | \f | |
565 | ;;; | |
566 | ;;; Port interface. | |
567 | ;;; | |
568 | ||
569 | ;; Alist of (levels (dictionary-size match-length-limit)). 0 is the fastest. | |
570 | ;; See bbexample.c in lzlib's source. | |
571 | (define %compression-levels | |
572 | `((0 (65535 16)) | |
573 | (1 (,(bitwise-arithmetic-shift-left 1 20) 5)) | |
574 | (2 (,(bitwise-arithmetic-shift-left 3 19) 6)) | |
575 | (3 (,(bitwise-arithmetic-shift-left 1 21) 8)) | |
576 | (4 (,(bitwise-arithmetic-shift-left 3 20) 12)) | |
577 | (5 (,(bitwise-arithmetic-shift-left 1 22) 20)) | |
578 | (6 (,(bitwise-arithmetic-shift-left 1 23) 36)) | |
579 | (7 (,(bitwise-arithmetic-shift-left 1 24) 68)) | |
580 | (8 (,(bitwise-arithmetic-shift-left 3 23) 132)) | |
581 | (9 (,(bitwise-arithmetic-shift-left 1 25) 273)))) | |
582 | ||
583 | (define %default-compression-level | |
584 | 6) | |
585 | ||
586 | (define* (make-lzip-input-port port) | |
587 | "Return an input port that decompresses data read from PORT, a file port. | |
588 | PORT is automatically closed when the resulting port is closed." | |
589 | (define decoder (lz-decompress-open)) | |
590 | ||
591 | (define (read! bv start count) | |
592 | (lzread! decoder port bv start count)) | |
593 | ||
594 | (make-custom-binary-input-port "lzip-input" read! #f #f | |
595 | (lambda () | |
596 | (lz-decompress-close decoder) | |
597 | (close-port port)))) | |
598 | ||
599 | (define* (make-lzip-output-port port | |
600 | #:key | |
601 | (level %default-compression-level)) | |
602 | "Return an output port that compresses data at the given LEVEL, using PORT, | |
603 | a file port, as its sink. PORT is automatically closed when the resulting | |
604 | port is closed." | |
605 | (define encoder (apply lz-compress-open | |
606 | (car (assoc-ref %compression-levels level)))) | |
607 | ||
608 | (define (write! bv start count) | |
609 | (lzwrite encoder bv port start count)) | |
610 | ||
611 | (make-custom-binary-output-port "lzip-output" write! #f #f | |
612 | (lambda () | |
613 | (lz-compress-finish encoder) | |
614 | ;; "lz-read" the trailing metadata added by `lz-compress-finish'. | |
615 | (let ((lz-bv (make-bytevector (* 64 1024)))) | |
616 | (let loop ((rd 0)) | |
617 | (set! rd (lz-compress-read encoder lz-bv 0 (bytevector-length lz-bv))) | |
618 | (put-bytevector port lz-bv 0 rd) | |
619 | (unless (= rd 0) | |
620 | (loop rd)))) | |
621 | (lz-compress-close encoder) | |
622 | (close-port port)))) | |
623 | ||
2a991f3a LC |
624 | (define* (make-lzip-input-port/compressed port |
625 | #:key | |
626 | (level %default-compression-level)) | |
627 | "Return an input port that compresses data read from PORT, with the given LEVEL. | |
628 | PORT is automatically closed when the resulting port is closed." | |
629 | (define encoder (apply lz-compress-open | |
630 | (car (assoc-ref %compression-levels level)))) | |
631 | ||
632 | (define input-buffer (make-bytevector 8192)) | |
633 | (define input-len 0) | |
634 | (define input-offset 0) | |
635 | ||
636 | (define input-eof? #f) | |
637 | ||
638 | (define (read! bv start count) | |
639 | (cond | |
640 | (input-eof? | |
641 | (match (lz-compress-read encoder bv start count) | |
642 | (0 (if (lz-compress-finished? encoder) | |
643 | 0 | |
644 | (read! bv start count))) | |
645 | (n n))) | |
646 | ((= input-offset input-len) | |
647 | (match (get-bytevector-n! port input-buffer 0 | |
648 | (bytevector-length input-buffer)) | |
649 | ((? eof-object?) | |
650 | (set! input-eof? #t) | |
651 | (lz-compress-finish encoder)) | |
652 | (count | |
653 | (set! input-offset 0) | |
654 | (set! input-len count))) | |
655 | (read! bv start count)) | |
656 | (else | |
657 | (let-values (((read written) | |
658 | (lzwrite! encoder | |
659 | input-buffer input-offset | |
660 | (- input-len input-offset) | |
661 | bv start count))) | |
662 | (set! input-offset (+ input-offset read)) | |
663 | ||
664 | ;; Make sure we don't return zero except on EOF. | |
665 | (if (= 0 written) | |
666 | (read! bv start count) | |
667 | written))))) | |
668 | ||
669 | (make-custom-binary-input-port "lzip-input/compressed" | |
670 | read! #f #f | |
671 | (lambda () | |
672 | (close-port port)))) | |
673 | ||
fea338c6 PN |
674 | (define* (call-with-lzip-input-port port proc) |
675 | "Call PROC with a port that wraps PORT and decompresses data read from it. | |
676 | PORT is closed upon completion." | |
677 | (let ((lzip (make-lzip-input-port port))) | |
678 | (dynamic-wind | |
679 | (const #t) | |
680 | (lambda () | |
681 | (proc lzip)) | |
682 | (lambda () | |
683 | (close-port lzip))))) | |
684 | ||
685 | (define* (call-with-lzip-output-port port proc | |
686 | #:key | |
687 | (level %default-compression-level)) | |
688 | "Call PROC with an output port that wraps PORT and compresses data. PORT is | |
689 | close upon completion." | |
690 | (let ((lzip (make-lzip-output-port port | |
691 | #:level level))) | |
692 | (dynamic-wind | |
693 | (const #t) | |
694 | (lambda () | |
695 | (proc lzip)) | |
696 | (lambda () | |
697 | (close-port lzip))))) | |
698 | ||
699 | ;;; lzlib.scm ends here |