You can not select more than 25 topics Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.
 
 
 
 
 
 

235 lines
8.4 KiB

  1. ;;; GNU Guix --- Functional package management for GNU
  2. ;;; Copyright © 2016 Ludovic Courtès <ludo@gnu.org>
  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. (define-module (guix zlib)
  19. #:use-module (rnrs bytevectors)
  20. #:use-module (ice-9 binary-ports)
  21. #:use-module (ice-9 match)
  22. #:use-module (system foreign)
  23. #:use-module (guix config)
  24. #:export (zlib-available?
  25. make-gzip-input-port
  26. make-gzip-output-port
  27. call-with-gzip-input-port
  28. call-with-gzip-output-port
  29. %default-buffer-size
  30. %default-compression-level))
  31. ;;; Commentary:
  32. ;;;
  33. ;;; Bindings to the gzip-related part of zlib's API. The main limitation of
  34. ;;; this API is that it requires a file descriptor as the source or sink.
  35. ;;;
  36. ;;; Code:
  37. (define %zlib
  38. ;; File name of zlib's shared library. When updating via 'guix pull',
  39. ;; '%libz' might be undefined so protect against it.
  40. (delay (dynamic-link (if (defined? '%libz)
  41. %libz
  42. "libz"))))
  43. (define (zlib-available?)
  44. "Return true if zlib is available, #f otherwise."
  45. (false-if-exception (force %zlib)))
  46. (define (zlib-procedure ret name parameters)
  47. "Return a procedure corresponding to C function NAME in libz, or #f if
  48. either zlib or the function could not be found."
  49. (match (false-if-exception (dynamic-func name (force %zlib)))
  50. ((? pointer? ptr)
  51. (pointer->procedure ret ptr parameters))
  52. (#f
  53. #f)))
  54. (define-wrapped-pointer-type <gzip-file>
  55. ;; Scheme counterpart of the 'gzFile' opaque type.
  56. gzip-file?
  57. pointer->gzip-file
  58. gzip-file->pointer
  59. (lambda (obj port)
  60. (format port "#<gzip-file ~a>"
  61. (number->string (object-address obj) 16))))
  62. (define gzerror
  63. (let ((proc (zlib-procedure '* "gzerror" '(* *))))
  64. (lambda (gzfile)
  65. (let* ((errnum* (make-bytevector (sizeof int)))
  66. (ptr (proc (gzip-file->pointer gzfile)
  67. (bytevector->pointer errnum*))))
  68. (values (bytevector-sint-ref errnum* 0
  69. (native-endianness) (sizeof int))
  70. (pointer->string ptr))))))
  71. (define gzdopen
  72. (let ((proc (zlib-procedure '* "gzdopen" (list int '*))))
  73. (lambda (fd mode)
  74. "Open file descriptor FD as a gzip stream with the given MODE. MODE must
  75. be a string denoting the how FD is to be opened, such as \"r\" for reading or
  76. \"w9\" for writing data compressed at level 9 to FD. Calling 'gzclose' also
  77. closes FD."
  78. (let ((result (proc fd (string->pointer mode))))
  79. (if (null-pointer? result)
  80. (throw 'zlib-error 'gzdopen)
  81. (pointer->gzip-file result))))))
  82. (define gzread!
  83. (let ((proc (zlib-procedure int "gzread" (list '* '* unsigned-int))))
  84. (lambda* (gzfile bv #:optional (start 0) (count (bytevector-length bv)))
  85. "Read up to COUNT bytes from GZFILE into BV at offset START. Return the
  86. number of uncompressed bytes actually read."
  87. (let ((ret (proc (gzip-file->pointer gzfile)
  88. (bytevector->pointer bv start)
  89. count)))
  90. (if (< ret 0)
  91. (throw 'zlib-error 'gzread! ret)
  92. ret)))))
  93. (define gzwrite
  94. (let ((proc (zlib-procedure int "gzwrite" (list '* '* unsigned-int))))
  95. (lambda* (gzfile bv #:optional (start 0) (count (bytevector-length bv)))
  96. "Write up to COUNT bytes from BV at offset START into GZFILE. Return
  97. the number of uncompressed bytes written, a strictly positive integer."
  98. (let ((ret (proc (gzip-file->pointer gzfile)
  99. (bytevector->pointer bv start)
  100. count)))
  101. (if (<= ret 0)
  102. (throw 'zlib-error 'gzwrite ret)
  103. ret)))))
  104. (define gzbuffer!
  105. (let ((proc (zlib-procedure int "gzbuffer" (list '* unsigned-int))))
  106. (lambda (gzfile size)
  107. "Change the internal buffer size of GZFILE to SIZE bytes."
  108. (let ((ret (proc (gzip-file->pointer gzfile) size)))
  109. (unless (zero? ret)
  110. (throw 'zlib-error 'gzbuffer! ret))))))
  111. (define gzeof?
  112. (let ((proc (zlib-procedure int "gzeof" '(*))))
  113. (lambda (gzfile)
  114. "Return true if the end-of-file has been reached on GZFILE."
  115. (not (zero? (proc (gzip-file->pointer gzfile)))))))
  116. (define gzclose
  117. (let ((proc (zlib-procedure int "gzclose" '(*))))
  118. (lambda (gzfile)
  119. "Close GZFILE."
  120. (let ((ret (proc (gzip-file->pointer gzfile))))
  121. (unless (zero? ret)
  122. (throw 'zlib-error 'gzclose ret (gzerror gzfile)))))))
  123. ;;;
  124. ;;; Port interface.
  125. ;;;
  126. (define %default-buffer-size
  127. ;; Default buffer size, as documented in <zlib.h>.
  128. 8192)
  129. (define %default-compression-level
  130. ;; Z_DEFAULT_COMPRESSION.
  131. -1)
  132. (define (close-procedure gzfile port)
  133. "Return a procedure that closes GZFILE, ensuring its underlying PORT is
  134. closed even if closing GZFILE triggers an exception."
  135. (lambda ()
  136. (catch 'zlib-error
  137. (lambda ()
  138. ;; 'gzclose' closes the underlying file descriptor. 'close-port'
  139. ;; calls close(2), gets EBADF, which is ignores.
  140. (gzclose gzfile)
  141. (close-port port))
  142. (lambda args
  143. ;; Make sure PORT is closed despite the zlib error.
  144. (close-port port)
  145. (apply throw args)))))
  146. (define* (make-gzip-input-port port #:key (buffer-size %default-buffer-size))
  147. "Return an input port that decompresses data read from PORT, a file port.
  148. PORT is automatically closed when the resulting port is closed. BUFFER-SIZE
  149. is the size in bytes of the internal buffer, 8 KiB by default; using a larger
  150. buffer increases decompression speed."
  151. (define gzfile
  152. (gzdopen (fileno port) "r"))
  153. (define (read! bv start count)
  154. ;; XXX: Can 'gzread!' return zero even though we haven't reached the EOF?
  155. (gzread! gzfile bv start count))
  156. (unless (= buffer-size %default-buffer-size)
  157. (gzbuffer! gzfile buffer-size))
  158. (make-custom-binary-input-port "gzip-input" read! #f #f
  159. (close-procedure gzfile port)))
  160. (define* (make-gzip-output-port port
  161. #:key
  162. (level %default-compression-level)
  163. (buffer-size %default-buffer-size))
  164. "Return an output port that compresses data at the given LEVEL, using PORT,
  165. a file port, as its sink. PORT is automatically closed when the resulting
  166. port is closed."
  167. (define gzfile
  168. (gzdopen (fileno port)
  169. (string-append "w" (number->string level))))
  170. (define (write! bv start count)
  171. (gzwrite gzfile bv start count))
  172. (unless (= buffer-size %default-buffer-size)
  173. (gzbuffer! gzfile buffer-size))
  174. (make-custom-binary-output-port "gzip-output" write! #f #f
  175. (close-procedure gzfile port)))
  176. (define* (call-with-gzip-input-port port proc
  177. #:key (buffer-size %default-buffer-size))
  178. "Call PROC with a port that wraps PORT and decompresses data read from it.
  179. PORT is closed upon completion. The gzip internal buffer size is set to
  180. BUFFER-SIZE bytes."
  181. (let ((gzip (make-gzip-input-port port #:buffer-size buffer-size)))
  182. (dynamic-wind
  183. (const #t)
  184. (lambda ()
  185. (proc gzip))
  186. (lambda ()
  187. (close-port gzip)))))
  188. (define* (call-with-gzip-output-port port proc
  189. #:key
  190. (level %default-compression-level)
  191. (buffer-size %default-buffer-size))
  192. "Call PROC with an output port that wraps PORT and compresses data. PORT is
  193. close upon completion. The gzip internal buffer size is set to BUFFER-SIZE
  194. bytes."
  195. (let ((gzip (make-gzip-output-port port
  196. #:level level
  197. #:buffer-size buffer-size)))
  198. (dynamic-wind
  199. (const #t)
  200. (lambda ()
  201. (proc gzip))
  202. (lambda ()
  203. (close-port gzip)))))
  204. ;;; zlib.scm ends here