guix/lzlib.scm

   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* (lzread! decoder file-port bv
 495                   #:optional (start 0) (count (bytevector-length bv)))
 496   "Read up to COUNT bytes from FILE-PORT into BV at offset START.  Return the
 497 number of uncompressed bytes actually read; it is zero if COUNT is zero or if
 498 the end-of-stream has been reached."
 499   ;; WARNING: Because we don't alternate between lz-reads and lz-writes, we can't
 500   ;; process more than lz-decompress-write-size from the file-port.
 501   (when (> count (lz-decompress-write-size decoder))
 502     (set! count (lz-decompress-write-size decoder)))
 503   (let ((file-bv (get-bytevector-n file-port count)))
 504     (unless (eof-object? file-bv)
 505       (lz-decompress-write decoder file-bv 0 (bytevector-length file-bv))))
 506   (let ((read 0))
 507     (let loop ((rd 0))
 508       (if (< start (bytevector-length bv))
 509           (begin
 510             (set! rd (lz-decompress-read decoder bv start (- (bytevector-length bv) start)))
 511             (set! start (+ start rd))
 512             (set! read (+ read rd)))
 513           (set! rd 0))
 514       (unless (= rd 0)
 515         (loop rd)))
 516     read))
 517
 518 (define* (lzwrite encoder bv lz-port
 519                   #:optional (start 0) (count (bytevector-length bv)))
 520   "Write up to COUNT bytes from BV at offset START into LZ-PORT.  Return
 521 the number of uncompressed bytes written, a non-negative integer."
 522   (let ((written 0)
 523         (read 0))
 524     (while (and (< 0 (lz-compress-write-size encoder))
 525                 (< written count))
 526       (set! written (+ written
 527                        (lz-compress-write encoder bv (+ start written) (- count written)))))
 528     (when (= written 0)
 529       (lz-compress-finish encoder))
 530     (let ((lz-bv (make-bytevector written)))
 531       (let loop ((rd 0))
 532         (set! rd (lz-compress-read encoder lz-bv 0 (bytevector-length lz-bv)))
 533         (put-bytevector lz-port lz-bv 0 rd)
 534         (set! read (+ read rd))
 535         (unless (= rd 0)
 536           (loop rd))))
 537     ;; `written' is the total byte count of uncompressed data.
 538     written))
 539
 540 \f
 541 ;;;
 542 ;;; Port interface.
 543 ;;;
 544
 545 ;; Alist of (levels (dictionary-size match-length-limit)).  0 is the fastest.
 546 ;; See bbexample.c in lzlib's source.
 547 (define %compression-levels
 548   `((0 (65535 16))
 549     (1 (,(bitwise-arithmetic-shift-left 1 20) 5))
 550     (2 (,(bitwise-arithmetic-shift-left 3 19) 6))
 551     (3 (,(bitwise-arithmetic-shift-left 1 21) 8))
 552     (4 (,(bitwise-arithmetic-shift-left 3 20) 12))
 553     (5 (,(bitwise-arithmetic-shift-left 1 22) 20))
 554     (6 (,(bitwise-arithmetic-shift-left 1 23) 36))
 555     (7 (,(bitwise-arithmetic-shift-left 1 24) 68))
 556     (8 (,(bitwise-arithmetic-shift-left 3 23) 132))
 557     (9 (,(bitwise-arithmetic-shift-left 1 25) 273))))
 558
 559 (define %default-compression-level
 560   6)
 561
 562 (define* (make-lzip-input-port port)
 563   "Return an input port that decompresses data read from PORT, a file port.
 564 PORT is automatically closed when the resulting port is closed."
 565   (define decoder (lz-decompress-open))
 566
 567   (define (read! bv start count)
 568     (lzread! decoder port bv start count))
 569
 570   (make-custom-binary-input-port "lzip-input" read! #f #f
 571                                  (lambda ()
 572                                    (lz-decompress-close decoder)
 573                                    (close-port port))))
 574
 575 (define* (make-lzip-output-port port
 576                                 #:key
 577                                 (level %default-compression-level))
 578   "Return an output port that compresses data at the given LEVEL, using PORT,
 579 a file port, as its sink.  PORT is automatically closed when the resulting
 580 port is closed."
 581   (define encoder (apply lz-compress-open
 582                          (car (assoc-ref %compression-levels level))))
 583
 584   (define (write! bv start count)
 585     (lzwrite encoder bv port start count))
 586
 587   (make-custom-binary-output-port "lzip-output" write! #f #f
 588                                   (lambda ()
 589                                     (lz-compress-finish encoder)
 590                                     ;; "lz-read" the trailing metadata added by `lz-compress-finish'.
 591                                     (let ((lz-bv (make-bytevector (* 64 1024))))
 592                                       (let loop ((rd 0))
 593                                         (set! rd (lz-compress-read encoder lz-bv 0 (bytevector-length lz-bv)))
 594                                         (put-bytevector port lz-bv 0 rd)
 595                                         (unless (= rd 0)
 596                                           (loop rd))))
 597                                     (lz-compress-close encoder)
 598                                     (close-port port))))
 599
 600 (define* (call-with-lzip-input-port port proc)
 601   "Call PROC with a port that wraps PORT and decompresses data read from it.
 602 PORT is closed upon completion."
 603   (let ((lzip (make-lzip-input-port port)))
 604     (dynamic-wind
 605       (const #t)
 606       (lambda ()
 607         (proc lzip))
 608       (lambda ()
 609         (close-port lzip)))))
 610
 611 (define* (call-with-lzip-output-port port proc
 612                                      #:key
 613                                      (level %default-compression-level))
 614   "Call PROC with an output port that wraps PORT and compresses data.  PORT is
 615 close upon completion."
 616   (let ((lzip (make-lzip-output-port port
 617                                      #:level level)))
 618     (dynamic-wind
 619       (const #t)
 620       (lambda ()
 621         (proc lzip))
 622       (lambda ()
 623         (close-port lzip)))))
 624
 625 ;;; lzlib.scm ends here