1 ;;; GNU Guix --- Functional package management for GNU
2 ;;; Copyright © 2016 Ludovic Courtès <ludo@gnu.org>
4 ;;; This file is part of GNU Guix.
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.
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.
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/>.
19 (define-module (guix zlib)
20 #:use-module (rnrs bytevectors)
21 #:use-module (ice-9 binary-ports)
22 #:use-module (ice-9 match)
23 #:use-module (system foreign)
24 #:use-module (guix config)
25 #:export (zlib-available?
28 call-with-gzip-input-port
29 call-with-gzip-output-port
31 %default-compression-level))
35 ;;; Bindings to the gzip-related part of zlib's API. The main limitation of
36 ;;; this API is that it requires a file descriptor as the source or sink.
41 ;; File name of zlib's shared library. When updating via 'guix pull',
42 ;; '%libz' might be undefined so protect against it.
43 (delay (dynamic-link (if (defined? '%libz)
47 (define (zlib-available?)
48 "Return true if zlib is available, #f otherwise."
49 (false-if-exception (force %zlib)))
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)))
56 (pointer->procedure ret ptr parameters))
60 (define-wrapped-pointer-type <gzip-file>
61 ;; Scheme counterpart of the 'gzFile' opaque type.
66 (format port "#<gzip-file ~a>"
67 (number->string (object-address obj) 16))))
70 (let ((proc (zlib-procedure '* "gzerror" '(* *))))
72 (let* ((errnum* (make-bytevector (sizeof int)))
73 (ptr (proc (gzip-file->pointer gzfile)
74 (bytevector->pointer errnum*))))
75 (values (bytevector-sint-ref errnum* 0
76 (native-endianness) (sizeof int))
77 (pointer->string ptr))))))
80 (let ((proc (zlib-procedure '* "gzdopen" (list int '*))))
82 "Open file descriptor FD as a gzip stream with the given MODE. MODE must
83 be a string denoting the how FD is to be opened, such as \"r\" for reading or
84 \"w9\" for writing data compressed at level 9 to FD. Calling 'gzclose' also
86 (let ((result (proc fd (string->pointer mode))))
87 (if (null-pointer? result)
88 (throw 'zlib-error 'gzdopen)
89 (pointer->gzip-file result))))))
92 (let ((proc (zlib-procedure int "gzread" (list '* '* unsigned-int))))
93 (lambda* (gzfile bv #:optional (start 0) (count (bytevector-length bv)))
94 "Read up to COUNT bytes from GZFILE into BV at offset START. Return the
95 number of uncompressed bytes actually read; it is zero if COUNT is zero or if
96 the end-of-stream has been reached."
97 (let ((ret (proc (gzip-file->pointer gzfile)
98 (bytevector->pointer bv start)
101 (throw 'zlib-error 'gzread! ret)
105 (let ((proc (zlib-procedure int "gzwrite" (list '* '* unsigned-int))))
106 (lambda* (gzfile bv #:optional (start 0) (count (bytevector-length bv)))
107 "Write up to COUNT bytes from BV at offset START into GZFILE. Return
108 the number of uncompressed bytes written, a strictly positive integer."
109 (let ((ret (proc (gzip-file->pointer gzfile)
110 (bytevector->pointer bv start)
113 (throw 'zlib-error 'gzwrite ret)
117 (let ((proc (zlib-procedure int "gzbuffer" (list '* unsigned-int))))
118 (lambda (gzfile size)
119 "Change the internal buffer size of GZFILE to SIZE bytes."
120 (let ((ret (proc (gzip-file->pointer gzfile) size)))
122 (throw 'zlib-error 'gzbuffer! ret))))))
125 (let ((proc (zlib-procedure int "gzeof" '(*))))
127 "Return true if the end-of-file has been reached on GZFILE."
128 (not (zero? (proc (gzip-file->pointer gzfile)))))))
131 (let ((proc (zlib-procedure int "gzclose" '(*))))
134 (let ((ret (proc (gzip-file->pointer gzfile))))
136 (throw 'zlib-error 'gzclose ret (gzerror gzfile)))))))
144 (define %default-buffer-size
145 ;; Default buffer size, as documented in <zlib.h>.
148 (define %default-compression-level
149 ;; Z_DEFAULT_COMPRESSION.
152 (define (close-procedure gzfile port)
153 "Return a procedure that closes GZFILE, ensuring its underlying PORT is
154 closed even if closing GZFILE triggers an exception."
155 (let-syntax ((ignore-EBADF
162 (unless (= EBADF (system-error-errno args))
163 (apply throw args))))))))
168 ;; 'gzclose' closes the underlying file descriptor. 'close-port'
169 ;; calls close(2) and gets EBADF, which we swallow.
171 (ignore-EBADF (close-port port)))
173 ;; Make sure PORT is closed despite the zlib error.
174 (ignore-EBADF (close-port port))
175 (apply throw args))))))
177 (define* (make-gzip-input-port port #:key (buffer-size %default-buffer-size))
178 "Return an input port that decompresses data read from PORT, a file port.
179 PORT is automatically closed when the resulting port is closed. BUFFER-SIZE
180 is the size in bytes of the internal buffer, 8 KiB by default; using a larger
181 buffer increases decompression speed. An error is thrown if PORT contains
182 buffered input, which would be lost (and is lost anyway)."
184 (match (drain-input port)
185 ("" ;PORT's buffer is empty
186 (gzdopen (fileno port) "r"))
188 ;; This is unrecoverable but it's better than having the buffered input
189 ;; be lost, leading to unclear end-of-file or corrupt-data errors down
191 (throw 'zlib-error 'make-gzip-input-port
192 "port contains buffered input" port))))
194 (define (read! bv start count)
195 (gzread! gzfile bv start count))
197 (unless (= buffer-size %default-buffer-size)
198 (gzbuffer! gzfile buffer-size))
200 (make-custom-binary-input-port "gzip-input" read! #f #f
201 (close-procedure gzfile port)))
203 (define* (make-gzip-output-port port
205 (level %default-compression-level)
206 (buffer-size %default-buffer-size))
207 "Return an output port that compresses data at the given LEVEL, using PORT,
208 a file port, as its sink. PORT is automatically closed when the resulting
212 (force-output port) ;empty PORT's buffer
213 (gzdopen (fileno port)
214 (string-append "w" (number->string level)))))
216 (define (write! bv start count)
217 (gzwrite gzfile bv start count))
219 (unless (= buffer-size %default-buffer-size)
220 (gzbuffer! gzfile buffer-size))
222 (make-custom-binary-output-port "gzip-output" write! #f #f
223 (close-procedure gzfile port)))
225 (define* (call-with-gzip-input-port port proc
226 #:key (buffer-size %default-buffer-size))
227 "Call PROC with a port that wraps PORT and decompresses data read from it.
228 PORT is closed upon completion. The gzip internal buffer size is set to
230 (let ((gzip (make-gzip-input-port port #:buffer-size buffer-size)))
236 (close-port gzip)))))
238 (define* (call-with-gzip-output-port port proc
240 (level %default-compression-level)
241 (buffer-size %default-buffer-size))
242 "Call PROC with an output port that wraps PORT and compresses data. PORT is
243 close upon completion. The gzip internal buffer size is set to BUFFER-SIZE
245 (let ((gzip (make-gzip-output-port port
247 #:buffer-size buffer-size)))
253 (close-port gzip)))))
255 ;;; zlib.scm ends here