zlib.scm 30 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456457458459460461462463464465466467468469470471472473474475476477478479480481482483484485486487488489490491492493494495496497498499500501502503504505506507508509510511512513514515516517518519520521522523524525526527528529530531532533534535536537538539540541542543544545546547548549550551552553554555556557558559560561562563564565566567568569570571572573574575576577578579580581582583584585586587588589590591592593594595596597598599600601602603604605606607608609610611612613614615616617618619620621622623624625626627628629630631632633634635636637638639640641642643644645646647648649650651652653654655656657658659660661662663664665666667668669670671672673674675676677678679680681682683684685686687688689690691692693694695696697698699700701702703704705706707708709710711712713714715716717718719720721722723724725726727728729730731732733734735736737738739740741742743744745746747748749750751752753754755756757758759760761762763764765766767768769770771772773774775776777778779780781782783784785786787788789
  1. ;;; Guile-zlib --- GNU Guile bindings of zlib
  2. ;;; Copyright © 2016, 2017, 2021 Ludovic Courtès <ludo@gnu.org>
  3. ;;; Copyright © 2020 Mathieu Othacehe <othacehe@gnu.org>
  4. ;;; Copyright © 2013 David Thompson <dthompson2@worcester.edu>
  5. ;;;
  6. ;;; This file is part of Guile-zlib.
  7. ;;;
  8. ;;; Guile-zlib is free software; you can redistribute it and/or modify it
  9. ;;; under the terms of the GNU General Public License as published by
  10. ;;; the Free Software Foundation; either version 3 of the License, or (at
  11. ;;; your option) any later version.
  12. ;;;
  13. ;;; Guile-zlib is distributed in the hope that it will be useful, but
  14. ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
  15. ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
  16. ;;; GNU General Public License for more details.
  17. ;;;
  18. ;;; You should have received a copy of the GNU General Public License
  19. ;;; along with Guile-zlib. If not, see <http://www.gnu.org/licenses/>.
  20. (define-module (zlib)
  21. #:use-module (zlib config)
  22. #:use-module (rnrs bytevectors)
  23. #:use-module (ice-9 binary-ports)
  24. #:use-module (ice-9 match)
  25. #:use-module (system foreign)
  26. #:use-module (ice-9 receive)
  27. #:use-module (srfi srfi-1)
  28. #:export (make-gzip-input-port
  29. make-gzip-output-port
  30. call-with-gzip-input-port
  31. call-with-gzip-output-port
  32. %default-buffer-size
  33. %default-compression-level
  34. compress
  35. uncompress
  36. adler32
  37. crc32
  38. make-zlib-input-port
  39. make-zlib-output-port
  40. call-with-zlib-input-port
  41. call-with-zlib-output-port))
  42. ;;; Commentary:
  43. ;;;
  44. ;;; This file is extracted from Guix and originally written by Ludovic Courtès.
  45. ;;; Bindings to the gzip-related part of zlib's API. The main limitation of
  46. ;;; this API is that it requires a file descriptor as the source or sink.
  47. ;;;
  48. ;;; Code:
  49. (define %zlib
  50. (delay (dynamic-link %libz)))
  51. (define (zlib-procedure ret name parameters)
  52. "Return a procedure corresponding to C function NAME in libz, or #f if
  53. either zlib or the function could not be found."
  54. (match (false-if-exception (dynamic-func name (force %zlib)))
  55. ((? pointer? ptr)
  56. (pointer->procedure ret ptr parameters))
  57. (#f
  58. #f)))
  59. (define-wrapped-pointer-type <gzip-file>
  60. ;; Scheme counterpart of the 'gzFile' opaque type.
  61. gzip-file?
  62. pointer->gzip-file
  63. gzip-file->pointer
  64. (lambda (obj port)
  65. (format port "#<gzip-file ~a>"
  66. (number->string (object-address obj) 16))))
  67. (define gzerror
  68. (let ((proc (zlib-procedure '* "gzerror" '(* *))))
  69. (lambda (gzfile)
  70. (let* ((errnum* (make-bytevector (sizeof int)))
  71. (ptr (proc (gzip-file->pointer gzfile)
  72. (bytevector->pointer errnum*))))
  73. (values (bytevector-sint-ref errnum* 0
  74. (native-endianness) (sizeof int))
  75. (pointer->string ptr))))))
  76. (define gzdopen
  77. (let ((proc (zlib-procedure '* "gzdopen" (list int '*))))
  78. (lambda (fd mode)
  79. "Open file descriptor FD as a gzip stream with the given MODE. MODE must
  80. be a string denoting the how FD is to be opened, such as \"r\" for reading or
  81. \"w9\" for writing data compressed at level 9 to FD. Calling 'gzclose' also
  82. closes FD."
  83. (let ((result (proc fd (string->pointer mode))))
  84. (if (null-pointer? result)
  85. (throw 'zlib-error 'gzdopen)
  86. (pointer->gzip-file result))))))
  87. (define gzread!
  88. (let ((proc (zlib-procedure int "gzread" (list '* '* unsigned-int))))
  89. (lambda* (gzfile bv #:optional (start 0) (count (bytevector-length bv)))
  90. "Read up to COUNT bytes from GZFILE into BV at offset START. Return the
  91. number of uncompressed bytes actually read; it is zero if COUNT is zero or if
  92. the end-of-stream has been reached."
  93. (let ((ret (proc (gzip-file->pointer gzfile)
  94. (bytevector->pointer bv start)
  95. count)))
  96. (if (< ret 0)
  97. (throw 'zlib-error 'gzread! ret)
  98. ret)))))
  99. (define gzwrite
  100. (let ((proc (zlib-procedure int "gzwrite" (list '* '* unsigned-int))))
  101. (lambda* (gzfile bv #:optional (start 0) (count (bytevector-length bv)))
  102. "Write up to COUNT bytes from BV at offset START into GZFILE. Return
  103. the number of uncompressed bytes written, a strictly positive integer."
  104. (let ((ret (proc (gzip-file->pointer gzfile)
  105. (bytevector->pointer bv start)
  106. count)))
  107. (if (<= ret 0)
  108. (throw 'zlib-error 'gzwrite ret)
  109. ret)))))
  110. (define gzbuffer!
  111. (let ((proc (zlib-procedure int "gzbuffer" (list '* unsigned-int))))
  112. (lambda (gzfile size)
  113. "Change the internal buffer size of GZFILE to SIZE bytes."
  114. (let ((ret (proc (gzip-file->pointer gzfile) size)))
  115. (unless (zero? ret)
  116. (throw 'zlib-error 'gzbuffer! ret))))))
  117. (define gzeof?
  118. (let ((proc (zlib-procedure int "gzeof" '(*))))
  119. (lambda (gzfile)
  120. "Return true if the end-of-file has been reached on GZFILE."
  121. (not (zero? (proc (gzip-file->pointer gzfile)))))))
  122. (define gzclose
  123. (let ((proc (zlib-procedure int "gzclose" '(*))))
  124. (lambda (gzfile)
  125. "Close GZFILE."
  126. (let ((ret (proc (gzip-file->pointer gzfile))))
  127. (unless (zero? ret)
  128. (throw 'zlib-error 'gzclose ret (gzerror gzfile)))))))
  129. ;;;
  130. ;;; Port interface.
  131. ;;;
  132. (define %default-buffer-size
  133. ;; Default buffer size, as documented in <zlib.h>.
  134. 8192)
  135. (define %default-compression-level
  136. ;; Z_DEFAULT_COMPRESSION.
  137. -1)
  138. (define* (make-gzip-input-port port #:key (buffer-size %default-buffer-size))
  139. "Return an input port that decompresses data read from PORT, a file port.
  140. PORT is automatically closed when the resulting port is closed. BUFFER-SIZE
  141. is the size in bytes of the internal buffer, 8 KiB by default; using a larger
  142. buffer increases decompression speed. An error is thrown if PORT contains
  143. buffered input, which would be lost (and is lost anyway)."
  144. (define gzfile
  145. (match (drain-input port)
  146. ("" ;PORT's buffer is empty
  147. ;; 'gzclose' will eventually close the file descriptor beneath PORT.
  148. ;; 'close-port' on PORT would get EBADF if 'gzclose' already closed it,
  149. ;; so that's no good; revealed ports are no good either because they
  150. ;; leak (see <https://bugs.gnu.org/28784>); calling 'close-port' after
  151. ;; 'gzclose' doesn't work either because it leads to a race condition
  152. ;; (see <https://bugs.gnu.org/29335>). So we dup and close PORT right
  153. ;; away.
  154. (gzdopen (dup (fileno port)) "r"))
  155. (_
  156. ;; This is unrecoverable but it's better than having the buffered input
  157. ;; be lost, leading to unclear end-of-file or corrupt-data errors down
  158. ;; the path.
  159. (throw 'zlib-error 'make-gzip-input-port
  160. "port contains buffered input" port))))
  161. (define (read! bv start count)
  162. (gzread! gzfile bv start count))
  163. (unless (= buffer-size %default-buffer-size)
  164. (gzbuffer! gzfile buffer-size))
  165. (close-port port) ;we no longer need it
  166. (make-custom-binary-input-port "gzip-input" read! #f #f
  167. (lambda ()
  168. (gzclose gzfile))))
  169. (define* (make-gzip-output-port port
  170. #:key
  171. (level %default-compression-level)
  172. (buffer-size %default-buffer-size))
  173. "Return an output port that compresses data at the given LEVEL, using PORT,
  174. a file port, as its sink. PORT must be a file port; it is automatically
  175. closed when the resulting port is closed."
  176. (define gzfile
  177. (begin
  178. (force-output port) ;empty PORT's buffer
  179. (gzdopen (dup (fileno port))
  180. (string-append "w" (number->string level)))))
  181. (define (write! bv start count)
  182. (gzwrite gzfile bv start count))
  183. (unless (= buffer-size %default-buffer-size)
  184. (gzbuffer! gzfile buffer-size))
  185. (close-port port)
  186. (make-custom-binary-output-port "gzip-output" write! #f #f
  187. (lambda ()
  188. (gzclose gzfile))))
  189. (define* (call-with-gzip-input-port port proc
  190. #:key (buffer-size %default-buffer-size))
  191. "Call PROC with a port that wraps PORT and decompresses data read from it.
  192. PORT must be a file port; it is closed upon completion. The gzip internal
  193. buffer size is set to BUFFER-SIZE bytes.
  194. See 'call-with-zlib-input-port' for a slightly slower variant that does not
  195. require PORT to be a file port."
  196. (let ((gzip (make-gzip-input-port port #:buffer-size buffer-size)))
  197. (dynamic-wind
  198. (const #t)
  199. (lambda ()
  200. (proc gzip))
  201. (lambda ()
  202. (close-port gzip)))))
  203. (define* (call-with-gzip-output-port port proc
  204. #:key
  205. (level %default-compression-level)
  206. (buffer-size %default-buffer-size))
  207. "Call PROC with an output port that wraps PORT and compresses data. PORT
  208. must be a file port; it is closed upon completion. The gzip internal buffer
  209. size is set to BUFFER-SIZE bytes.
  210. See 'call-with-zlib-output-port' for a slightly slower variant that does not
  211. require PORT to be a file port."
  212. (let ((gzip (make-gzip-output-port port
  213. #:level level
  214. #:buffer-size buffer-size)))
  215. (dynamic-wind
  216. (const #t)
  217. (lambda ()
  218. (proc gzip))
  219. (lambda ()
  220. (close-port gzip)))))
  221. ;;;
  222. ;;; Raw operations, originally from davexunit's guile-zlib
  223. ;;; https://github.com/davexunit/guile-zlib
  224. ;;; fd28b7515efc4af6faf55854993cb0c8bed1f8c5
  225. ;;;
  226. ;;
  227. ;; ZEXTERN int ZEXPORT uncompress OF((Bytef *dest, uLongf *destLen,
  228. ;; const Bytef *source, uLong sourceLen));
  229. ;;
  230. ;; Decompresses the source buffer into the destination
  231. ;; buffer. sourceLen is the byte length of the source buffer. Upon
  232. ;; entry, destLen is the total size of the destination buffer, which
  233. ;; must be large enough to hold the entire uncompressed data. (The
  234. ;; size of the uncompressed data must have been saved previously by
  235. ;; the compressor and transmitted to the decompressor by some
  236. ;; mechanism outside the scope of this compression library.) Upon
  237. ;; exit, destLen is the actual size of the compressed buffer.
  238. ;;
  239. ;; uncompress returns Z_OK if success, Z_MEM_ERROR if there was not
  240. ;; enough memory, Z_BUF_ERROR if there was not enough room in the
  241. ;; output buffer, or Z_DATA_ERROR if the input data was corrupted or
  242. ;; incomplete. In the case where there is not enough room,
  243. ;; uncompress() will fill the output buffer with the uncompressed data
  244. ;; up to that point.
  245. (define %uncompress
  246. (zlib-procedure int "uncompress" (list '* '* '* unsigned-long)))
  247. ;;
  248. ;; ZEXTERN int ZEXPORT compress OF((Bytef *dest, uLongf *destLen,
  249. ;; const Bytef *source, uLong sourceLen));
  250. ;;
  251. ;; Compresses the source buffer into the destination buffer. sourceLen
  252. ;; is the byte length of the source buffer. Upon entry, destLen is the
  253. ;; total size of the destination buffer, which must be at least the
  254. ;; value returned by compressBound(sourceLen). Upon exit, destLen is
  255. ;; the actual size of the compressed buffer.
  256. ;;
  257. ;; compress returns Z_OK if success, Z_MEM_ERROR if there was not
  258. ;; enough memory, Z_BUF_ERROR if there was not enough room in the
  259. ;; output buffer.
  260. (define %compress
  261. (zlib-procedure int "compress" (list '* '* '* unsigned-long)))
  262. ;;
  263. ;; ZEXTERN uLong ZEXPORT compressBound OF((uLong sourceLen));
  264. ;;
  265. ;; compressBound() returns an upper bound on the compressed size after
  266. ;; compress() or compress2() on sourceLen bytes. It would be used
  267. ;; before a compress() or compress2() call to allocate the destination
  268. ;; buffer.
  269. (define %compress-bound
  270. (zlib-procedure unsigned-long "compressBound" (list unsigned-long)))
  271. ;; Update a running Adler-32 checksum with the bytes buf[0..len-1] and
  272. ;; return the updated checksum. If buf is Z_NULL, this function returns the
  273. ;; required initial value for the checksum.
  274. ;;
  275. ;; An Adler-32 checksum is almost as reliable as a CRC32 but can be computed
  276. ;; much faster.
  277. ;;
  278. ;; Usage example:
  279. ;;
  280. ;; uLong adler = adler32(0L, Z_NULL, 0);
  281. ;;
  282. ;; while (read_buffer(buffer, length) != EOF) {
  283. ;; adler = adler32(adler, buffer, length);
  284. ;; }
  285. ;; if (adler != original_adler) error();
  286. (define %adler32
  287. (zlib-procedure unsigned-long "adler32" (list unsigned-long '* unsigned-int)))
  288. ;; Update a running CRC-32 with the bytes buf[0..len-1] and return the
  289. ;; updated CRC-32. If buf is Z_NULL, this function returns the required
  290. ;; initial value for the crc. Pre- and post-conditioning (one's complement) is
  291. ;; performed within this function so it shouldn't be done by the application.
  292. ;;
  293. ;; Usage example:
  294. ;;
  295. ;; uLong crc = crc32(0L, Z_NULL, 0);
  296. ;;
  297. ;; while (read_buffer(buffer, length) != EOF) {
  298. ;; crc = crc32(crc, buffer, length);
  299. ;; }
  300. ;; if (crc != original_crc) error();
  301. (define %crc32
  302. (zlib-procedure unsigned-long "crc32" (list unsigned-long '* unsigned-int)))
  303. ;; There is a bit of guesswork involved when creating the bytevectors
  304. ;; to store compressed/uncompressed data in. This procedure provides a
  305. ;; convenient way to copy the portion of a bytevector that was
  306. ;; actually used.
  307. (define (bytevector-copy-region bv start end)
  308. (let* ((length (- end start))
  309. (new-bv (make-bytevector length)))
  310. (bytevector-copy! bv start new-bv 0 length)
  311. new-bv))
  312. ;; uncompress/compress take a bytevector that zlib writes the size of
  313. ;; the returned data to. This procedure saves me a few keystrokes when
  314. ;; fetching that value.
  315. (define (buffer-length bv)
  316. (bytevector-uint-ref bv 0
  317. (native-endianness) (sizeof unsigned-long)))
  318. (define (uncompress bv)
  319. "Uncompresses bytevector and returns a bytevector containing
  320. the uncompressed data."
  321. (define (try-uncompress length)
  322. (let* ((dest (make-bytevector (* (sizeof uint8) length)))
  323. (dest-length (make-bytevector (sizeof unsigned-long))))
  324. (bytevector-uint-set! dest-length 0 length
  325. (native-endianness) (sizeof unsigned-long))
  326. (values (%uncompress (bytevector->pointer dest)
  327. (bytevector->pointer dest-length)
  328. (bytevector->pointer bv)
  329. length)
  330. (bytevector-copy-region dest 0 (buffer-length dest-length)))))
  331. ;; We don't know how much space we need to store the uncompressed
  332. ;; data. So, we make an initial guess and keep increasing buffer
  333. ;; size until it works.
  334. (define (step-buffer-length length)
  335. (inexact->exact (round (* length 1.5))))
  336. (let try-again ((tries 1)
  337. (length (step-buffer-length (bytevector-length bv))))
  338. ;; Bail after so many failed attempts. This shouldn't happen, but
  339. ;; I don't like the idea of a potentially unbounded loop that
  340. ;; keeps allocating larger and larger chunks of memory.
  341. (if (> tries 10)
  342. (throw 'zlib-error 'uncompress 0)
  343. (receive (ret-code uncompressed-data)
  344. (try-uncompress length)
  345. ;; return code -5 means that destination buffer was too small.
  346. ;; return code 0 means everything went OK.
  347. (cond ((= ret-code -5)
  348. (try-again (1+ tries) (step-buffer-length length)))
  349. ((= ret-code 0)
  350. uncompressed-data)
  351. (else
  352. (throw 'zlib-error 'uncompress ret-code)))))))
  353. (define (compress bv)
  354. "Compresses bytevector and returns a bytevector containing the compressed data."
  355. (let* ((bv-length (bytevector-length bv))
  356. (dest-length (%compress-bound bv-length))
  357. (dest-bv (make-bytevector dest-length))
  358. (dest-length-bv (make-bytevector (sizeof unsigned-long)))
  359. (ret-code 0))
  360. (bytevector-uint-set! dest-length-bv 0 dest-length
  361. (native-endianness) (sizeof unsigned-long))
  362. (set! ret-code
  363. (%compress (bytevector->pointer dest-bv)
  364. (bytevector->pointer dest-length-bv)
  365. (bytevector->pointer bv)
  366. bv-length))
  367. (if (= ret-code 0)
  368. (bytevector-copy-region dest-bv 0
  369. (buffer-length dest-length-bv))
  370. (throw 'zlib-error 'compress ret-code))))
  371. (define %default-adler32 (%adler32 0 %null-pointer 0))
  372. (define %default-crc32 (%crc32 0 %null-pointer 0))
  373. (define* (adler32 bv #:optional (value %default-adler32))
  374. "Computes adler32 checksum with optional starting value."
  375. (%adler32 value (bytevector->pointer bv) (bytevector-length bv)))
  376. (define* (crc32 bv #:optional (value %default-crc32))
  377. "Computes crc32 checksum with optional starting value."
  378. (%crc32 value (bytevector->pointer bv) (bytevector-length bv)))
  379. ;;;
  380. ;;; Low-level zlib stream API.
  381. ;;;
  382. (define %zlib-version
  383. ;; Library version that we're targeting.
  384. "1.2.11")
  385. ;; struct zstream
  386. (define %stream-struct
  387. (list '* ;next_in
  388. unsigned-int ;avail_in
  389. unsigned-long ;total_in
  390. '* ;next_out
  391. unsigned-int ;avail_out
  392. unsigned-long ;total_out
  393. '* ;msg
  394. '* ;state
  395. '* ;zalloc
  396. '* ;zfree
  397. '* ;opaque
  398. int ;data_type
  399. unsigned-long ;adler
  400. unsigned-long)) ;reserved
  401. (define (offset-of types n)
  402. "Return the offset of the Nth field among TYPES, the list of types of a
  403. struct's fields."
  404. (if (zero? n)
  405. 0
  406. (let* ((base (sizeof (take types n)))
  407. (align (alignof (list-ref types n)))
  408. (mod (modulo base align)))
  409. (if (zero? mod)
  410. base
  411. (+ base (- align mod))))))
  412. (define-syntax-rule (define-stream-getter name index)
  413. "Define NAME as a procedure accessing the INDEXth field of %STREAM-STRUCT."
  414. (define name
  415. (let* ((offset (offset-of %stream-struct index))
  416. (type (list-ref %stream-struct index))
  417. (size (sizeof type)))
  418. (lambda (stream)
  419. (bytevector-uint-ref stream offset (native-endianness)
  420. size)))))
  421. (define-syntax-rule (define-stream-setter name index)
  422. "Define NAME as a procedure setting the INDEXth field of %STREAM-STRUCT."
  423. (define name
  424. (let* ((offset (offset-of %stream-struct index))
  425. (type (list-ref %stream-struct index))
  426. (size (sizeof type)))
  427. (lambda (stream value)
  428. (bytevector-uint-set! stream offset value
  429. (native-endianness) size)))))
  430. (define-stream-getter stream-avail-in 1)
  431. (define-stream-getter stream-avail-out 4)
  432. (define-stream-getter stream-error-message 6)
  433. (define-stream-setter set-stream-next-in! 0)
  434. (define-stream-setter set-stream-avail-in! 1)
  435. (define-stream-setter set-stream-next-out! 3)
  436. (define-stream-setter set-stream-avail-out! 4)
  437. (define (stream-error-message* stream)
  438. "Return the error message associated with STREAM or #f."
  439. (match (stream-error-message stream)
  440. ((? zero?) #f)
  441. (address (pointer->string (make-pointer address)))))
  442. (define inflate!
  443. (let ((proc (zlib-procedure int "inflate" `(* ,int))))
  444. (lambda (stream flush)
  445. (proc stream flush))))
  446. (define deflate!
  447. (let ((proc (zlib-procedure int "deflate" `(* ,int))))
  448. (lambda (stream flush)
  449. (proc stream flush))))
  450. (define (window-bits-for-format format)
  451. ;; Search for "windowBits" in <zlib.h>.
  452. (define MAX_WBITS 15) ;<zconf.h>
  453. (match format
  454. ('deflate (- MAX_WBITS)) ;raw deflate
  455. ('zlib MAX_WBITS) ;zlib header
  456. ('gzip (+ MAX_WBITS 16)))) ;gzip header
  457. (define inflate-init!
  458. (let ((proc (zlib-procedure int "inflateInit2_" `(* ,int * ,int))))
  459. (lambda (stream window-bits)
  460. (let ((ret (proc stream window-bits
  461. (string->pointer %zlib-version)
  462. (sizeof %stream-struct))))
  463. (unless (zero? ret)
  464. (throw 'zlib-error 'inflate-init! ret))))))
  465. (define deflate-init!
  466. (let ((proc (zlib-procedure int "deflateInit2_" `(* ,int ,int ,int ,int
  467. ,int * ,int))))
  468. (lambda* (stream level
  469. #:key
  470. (window-bits (window-bits-for-format 'zlib))
  471. (memory-level 8)
  472. (strategy Z_DEFAULT_STRATEGY))
  473. (let ((ret (proc stream level Z_DEFLATED
  474. window-bits memory-level strategy
  475. (string->pointer %zlib-version)
  476. (sizeof %stream-struct))))
  477. (unless (zero? ret)
  478. (throw 'zlib-error 'deflate-init! ret))))))
  479. (define inflate-end!
  480. (let ((proc (zlib-procedure int "inflateEnd" '(*))))
  481. (lambda (stream)
  482. (let ((ret (proc stream)))
  483. (unless (zero? ret)
  484. (throw 'zlib-error 'inflate-end! ret))))))
  485. (define deflate-end!
  486. (let ((proc (zlib-procedure int "deflateEnd" '(*))))
  487. (lambda (stream)
  488. (let ((ret (proc stream)))
  489. (unless (zero? ret)
  490. (throw 'zlib-error 'deflate-end! ret))))))
  491. ;; Error codes.
  492. (define Z_OK 0)
  493. (define Z_STREAM_END 1)
  494. (define Z_NEED_DICT 2)
  495. (define Z_ERRNO -1)
  496. (define Z_STREAM_ERROR -2)
  497. (define Z_DATA_ERROR -3)
  498. (define Z_MEM_ERROR -4)
  499. (define Z_BUF_ERROR -5)
  500. ;; Flush flags.
  501. (define Z_NO_FLUSH 0)
  502. (define Z_PARTIAL_FLUSH 1)
  503. (define Z_SYNC_FLUSH 2)
  504. (define Z_FULL_FLUSH 3)
  505. (define Z_FINISH 4)
  506. ;; 'deflate-init!' flags.
  507. (define Z_DEFLATED 8)
  508. (define Z_DEFAULT_STRATEGY 0)
  509. (define* (make-zlib-input-port port
  510. #:key
  511. (format 'zlib)
  512. (buffer-size %default-buffer-size)
  513. (close? #t))
  514. "Return an input port that decompresses data read from PORT. FORMAT is a
  515. symbol denoting the header format; it must be one of 'deflate (RFC 1950),
  516. 'zlib (RFC 1951), or 'gzip (RFC 1952).
  517. When CLOSE? is true, PORT is automatically closed when the resulting port is
  518. closed."
  519. (define input-buffer (make-bytevector buffer-size))
  520. ;; Instead of writing uncompressed data directly to the user-provided
  521. ;; buffer, keep a large-enough buffer. That way, we know we cannot stumble
  522. ;; into Z_BUF_ERROR because of insufficient output space.
  523. (define output-buffer (make-bytevector %default-buffer-size))
  524. (define buffered 0)
  525. (define offset 0)
  526. (define eof? #f)
  527. (define stream (make-bytevector (sizeof %stream-struct)))
  528. (define pointer
  529. (let ((ptr (bytevector->pointer stream)))
  530. (lambda (bv)
  531. (if (eq? bv stream)
  532. ptr
  533. (bytevector->pointer bv)))))
  534. (define (read! bv start count)
  535. (cond ((> buffered 0)
  536. (let ((n (min count buffered)))
  537. (bytevector-copy! output-buffer offset bv start n)
  538. (set! buffered (- buffered n))
  539. (set! offset (+ offset n))
  540. n))
  541. (eof? 0)
  542. (else
  543. (set! offset 0)
  544. (set-stream-next-out! stream
  545. (pointer-address
  546. (bytevector->pointer output-buffer)))
  547. (set-stream-avail-out! stream (bytevector-length output-buffer))
  548. (let loop ((ret Z_OK)
  549. (flush? #f))
  550. (if (and (not flush?)
  551. (or (zero? (stream-avail-in stream))
  552. (= Z_BUF_ERROR ret)))
  553. (let ((n (get-bytevector-n! port input-buffer
  554. 0 buffer-size)))
  555. (if (eof-object? n)
  556. (loop ret #t)
  557. (begin
  558. (set-stream-next-in! stream
  559. (pointer-address
  560. (bytevector->pointer input-buffer)))
  561. (set-stream-avail-in! stream n)
  562. (loop ret flush?))))
  563. (let ((ret (inflate! (pointer stream)
  564. (if flush? Z_SYNC_FLUSH 0))))
  565. (set! buffered (- (bytevector-length output-buffer)
  566. (stream-avail-out stream)))
  567. (cond ((= ret Z_OK)
  568. (read! bv start count))
  569. ((= ret Z_STREAM_END)
  570. (set! eof? #t)
  571. (read! bv start count))
  572. ((and (not flush?) (= Z_BUF_ERROR ret))
  573. (loop ret flush?))
  574. (else
  575. (throw 'zlib-error ret
  576. (stream-error-message* stream))))))))))
  577. (define result
  578. (make-custom-binary-input-port "zlib-input" read! #f #f
  579. (lambda ()
  580. (inflate-end! (pointer stream))
  581. (when close?
  582. (close-port port)))))
  583. ;; No need for extra buffering.
  584. (cond-expand ((or guile-2.2 guile-3.0)
  585. (setvbuf result 'none))
  586. (else #t)) ;not possible on 2.0
  587. (inflate-init! (pointer stream)
  588. (window-bits-for-format format))
  589. (set-stream-avail-in! stream 0)
  590. result)
  591. (define* (make-zlib-output-port port
  592. #:key
  593. (format 'zlib)
  594. (buffer-size %default-buffer-size)
  595. (level %default-compression-level)
  596. (close? #t))
  597. "Return an output port that compresses data at the given LEVEL, using PORT
  598. as its sink. FORMAT is a symbol denoting the header format; it must be one
  599. of 'deflate (RFC 1950), 'zlib (RFC 1951), or 'gzip (RFC 1952).
  600. When FORMAT is 'gzip, the gzip header takes default values, and in particular
  601. no modification time and no file name.
  602. When CLOSE? is true, PORT is automatically closed when the resulting port is
  603. closed."
  604. (define output-buffer (make-bytevector buffer-size))
  605. (define stream (make-bytevector (sizeof %stream-struct)))
  606. (define pointer
  607. (let ((ptr (bytevector->pointer stream)))
  608. (lambda (bv)
  609. (if (eq? bv stream)
  610. ptr
  611. (bytevector->pointer bv)))))
  612. (define (output-compressed-data! stream)
  613. (put-bytevector port output-buffer 0
  614. (- buffer-size (stream-avail-out stream)))
  615. (set-stream-avail-out! stream buffer-size)
  616. (set-stream-next-out! stream
  617. (pointer-address
  618. (bytevector->pointer output-buffer))))
  619. (define* (write! bv start count #:optional flush?)
  620. (set-stream-next-in! stream (+ start (pointer-address
  621. (bytevector->pointer bv))))
  622. (set-stream-avail-in! stream count)
  623. (let loop ()
  624. (if (zero? (stream-avail-out stream))
  625. (begin
  626. (output-compressed-data! stream)
  627. (loop))
  628. (let ((ret (deflate! (pointer stream)
  629. (if flush? Z_FINISH Z_NO_FLUSH))))
  630. (cond ((= ret Z_BUF_ERROR)
  631. (loop))
  632. ((= ret Z_OK)
  633. (match (- count (stream-avail-in stream))
  634. (0 (loop)) ;zero would mean EOF
  635. (n n)))
  636. ((and flush? (= ret Z_STREAM_END))
  637. (- count (stream-avail-in stream)))
  638. (else
  639. (throw 'zlib-error 'deflate! ret
  640. (stream-error-message* stream))))))))
  641. (define (flush)
  642. (write! #vu8() 0 0 #t)
  643. (output-compressed-data! stream))
  644. (define (close)
  645. (flush)
  646. (deflate-end! (pointer stream))
  647. (when close?
  648. (close-port port)))
  649. (deflate-init! (pointer stream) level
  650. #:window-bits (window-bits-for-format format))
  651. (set-stream-avail-out! stream buffer-size)
  652. (set-stream-next-out! stream
  653. (pointer-address (bytevector->pointer output-buffer)))
  654. (make-custom-binary-output-port "zlib-output" write! #f #f close))
  655. (define* (call-with-zlib-input-port port proc
  656. #:key
  657. (format 'zlib)
  658. (buffer-size %default-buffer-size))
  659. "Call PROC with a port that wraps PORT and decompresses data read from it.
  660. PORT is closed upon completion. The zlib internal buffer size is set to
  661. BUFFER-SIZE bytes."
  662. (let ((zlib (make-zlib-input-port port
  663. #:format format
  664. #:buffer-size buffer-size
  665. #:close? #t)))
  666. (dynamic-wind
  667. (const #t)
  668. (lambda ()
  669. (proc zlib))
  670. (lambda ()
  671. (close-port zlib)))))
  672. (define* (call-with-zlib-output-port port proc
  673. #:key
  674. (format 'zlib)
  675. (level %default-compression-level)
  676. (buffer-size %default-buffer-size))
  677. "Call PROC with an output port that wraps PORT and compresses data in the
  678. given FORMAT, with the given LEVEL. PORT is closed upon completion. The
  679. zlib internal buffer size is set to BUFFER-SIZE bytes."
  680. (let ((zlib (make-zlib-output-port port
  681. #:format format
  682. #:level level
  683. #:buffer-size buffer-size
  684. #:close? #t)))
  685. (dynamic-wind
  686. (const #t)
  687. (lambda ()
  688. (proc zlib))
  689. (lambda ()
  690. (close-port zlib)))))
  691. ;;; zlib.scm ends here