zlib.scm 33 KB

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