Commit | Line | Data |
---|---|---|
fea338c6 PN |
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 | |
62 | either 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 | \f | |
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 | |
107 | pointer that can only be used as the encoder argument for the other | |
108 | lz-compress functions, or a null pointer if the encoder could not be | |
109 | allocated. | |
110 | ||
111 | See 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 | |
121 | lz-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 | |
131 | the `lz-compress-write' function). It is safe to call `lz-compress-finish' as | |
132 | many times as needed. After all the produced compressed data have been read | |
133 | with `lz-compress-read' and `lz-compress-member-finished?' returns #t, a new | |
134 | member 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. | |
144 | Call this function only after `lz-compress-member-finished?' indicates that the | |
145 | current 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 | |
156 | the `LZ-compress-write' function. First call `lz-compress-sync-flush'. Then | |
157 | call 'lz-compress-read' until it returns 0. | |
158 | ||
159 | Repeated use of `LZ-compress-sync-flush' may degrade compression ratio, | |
160 | so 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. | |
171 | Return 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 | |
183 | number 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 | ||
197 | It is guaranteed that an immediate call to `lz-compress-write' will accept a | |
198 | SIZE 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 | |
217 | be 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 | |
228 | been fully read and 'lz-compress-restart-member' can be safely called. | |
229 | Otherwise 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 | |
240 | member." | |
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 | |
251 | not 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 | |
272 | perhaps 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 | \f | |
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 | |
286 | pointer that can only be used as the decoder argument for the other | |
287 | lz-decompress functions, or a null pointer if the decoder could not be | |
288 | allocated. | |
289 | ||
290 | See 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 | |
300 | lz-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 | |
310 | the `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 | |
321 | with the `lz-decompress-open' function. Data stored in the internal buffers | |
322 | is 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 | |
333 | until a new member header (or the end of the stream) is found. After a | |
334 | successful call to `lz-decompress-sync-to-member', data written with | |
335 | `lz-decompress-write' will be consumed and 'lz-decompress-read' will return 0 | |
336 | until a header is found. | |
337 | ||
338 | This function is useful to discard any data preceding the first member, or to | |
339 | discard the rest of the current member, for example in case of a data | |
340 | error. If the decoder is already at the beginning of a member, this function | |
341 | does 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. | |
352 | Return 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 | |
364 | number 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 | |
376 | through the `lz-decompress-write' function. | |
377 | ||
378 | It is guaranteed that an immediate call to `lz-decompress-write' will accept a | |
379 | SIZE 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 | |
398 | be 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 | |
409 | been fully read and `lz-decompress-restart-member' can be safely called. | |
410 | Otherwise 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 | |
442 | from 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 | |
453 | not 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 | |
464 | member." | |
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 | |
486 | perhaps 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 | \f | |
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 | |
499 | number of uncompressed bytes actually read; it is zero if COUNT is zero or if | |
500 | the 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 | |
529 | the 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 | \f | |
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. | |
572 | PORT 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, | |
587 | a file port, as its sink. PORT is automatically closed when the resulting | |
588 | port 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. | |
610 | PORT 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 | |
623 | close 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 |