Commit | Line | Data |
---|---|---|
72153902 | 1 | ;;; GNU Guix --- Functional package management for GNU |
85f4f7b7 | 2 | ;;; Copyright © 2016, 2017 Ludovic Courtès <ludo@gnu.org> |
72153902 LC |
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 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? | |
26 | make-gzip-input-port | |
27 | make-gzip-output-port | |
28 | call-with-gzip-input-port | |
29 | call-with-gzip-output-port | |
30 | %default-buffer-size | |
31 | %default-compression-level)) | |
32 | ||
33 | ;;; Commentary: | |
34 | ;;; | |
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. | |
37 | ;;; | |
38 | ;;; Code: | |
39 | ||
40 | (define %zlib | |
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) | |
44 | %libz | |
45 | "libz")))) | |
46 | ||
47 | (define (zlib-available?) | |
48 | "Return true if zlib is available, #f otherwise." | |
49 | (false-if-exception (force %zlib))) | |
50 | ||
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 | ||
60 | (define-wrapped-pointer-type <gzip-file> | |
61 | ;; Scheme counterpart of the 'gzFile' opaque type. | |
62 | gzip-file? | |
63 | pointer->gzip-file | |
64 | gzip-file->pointer | |
65 | (lambda (obj port) | |
66 | (format port "#<gzip-file ~a>" | |
67 | (number->string (object-address obj) 16)))) | |
68 | ||
69 | (define gzerror | |
70 | (let ((proc (zlib-procedure '* "gzerror" '(* *)))) | |
71 | (lambda (gzfile) | |
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)))))) | |
78 | ||
79 | (define gzdopen | |
80 | (let ((proc (zlib-procedure '* "gzdopen" (list int '*)))) | |
81 | (lambda (fd mode) | |
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 | |
85 | closes FD." | |
86 | (let ((result (proc fd (string->pointer mode)))) | |
87 | (if (null-pointer? result) | |
88 | (throw 'zlib-error 'gzdopen) | |
89 | (pointer->gzip-file result)))))) | |
90 | ||
91 | (define gzread! | |
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 | |
d00240c3 LC |
95 | number of uncompressed bytes actually read; it is zero if COUNT is zero or if |
96 | the end-of-stream has been reached." | |
72153902 LC |
97 | (let ((ret (proc (gzip-file->pointer gzfile) |
98 | (bytevector->pointer bv start) | |
99 | count))) | |
100 | (if (< ret 0) | |
101 | (throw 'zlib-error 'gzread! ret) | |
102 | ret))))) | |
103 | ||
104 | (define gzwrite | |
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) | |
111 | count))) | |
112 | (if (<= ret 0) | |
113 | (throw 'zlib-error 'gzwrite ret) | |
114 | ret))))) | |
115 | ||
116 | (define gzbuffer! | |
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))) | |
121 | (unless (zero? ret) | |
122 | (throw 'zlib-error 'gzbuffer! ret)))))) | |
123 | ||
124 | (define gzeof? | |
125 | (let ((proc (zlib-procedure int "gzeof" '(*)))) | |
126 | (lambda (gzfile) | |
127 | "Return true if the end-of-file has been reached on GZFILE." | |
128 | (not (zero? (proc (gzip-file->pointer gzfile))))))) | |
129 | ||
130 | (define gzclose | |
131 | (let ((proc (zlib-procedure int "gzclose" '(*)))) | |
132 | (lambda (gzfile) | |
133 | "Close GZFILE." | |
134 | (let ((ret (proc (gzip-file->pointer gzfile)))) | |
135 | (unless (zero? ret) | |
136 | (throw 'zlib-error 'gzclose ret (gzerror gzfile))))))) | |
137 | ||
138 | ||
139 | \f | |
140 | ;;; | |
141 | ;;; Port interface. | |
142 | ;;; | |
143 | ||
144 | (define %default-buffer-size | |
145 | ;; Default buffer size, as documented in <zlib.h>. | |
146 | 8192) | |
147 | ||
148 | (define %default-compression-level | |
149 | ;; Z_DEFAULT_COMPRESSION. | |
150 | -1) | |
151 | ||
72153902 LC |
152 | (define* (make-gzip-input-port port #:key (buffer-size %default-buffer-size)) |
153 | "Return an input port that decompresses data read from PORT, a file port. | |
154 | PORT is automatically closed when the resulting port is closed. BUFFER-SIZE | |
155 | is the size in bytes of the internal buffer, 8 KiB by default; using a larger | |
688ec13c LC |
156 | buffer increases decompression speed. An error is thrown if PORT contains |
157 | buffered input, which would be lost (and is lost anyway)." | |
72153902 | 158 | (define gzfile |
688ec13c LC |
159 | (match (drain-input port) |
160 | ("" ;PORT's buffer is empty | |
85f4f7b7 LC |
161 | ;; 'gzclose' will eventually close the file descriptor beneath PORT. |
162 | ;; 'close-port' on PORT would get EBADF if 'gzclose' already closed it, | |
163 | ;; so that's no good; revealed ports are no good either because they | |
164 | ;; leak (see <https://bugs.gnu.org/28784>); calling 'close-port' after | |
165 | ;; 'gzclose' doesn't work either because it leads to a race condition | |
166 | ;; (see <https://bugs.gnu.org/29335>). So we dup and close PORT right | |
167 | ;; away. | |
168 | (gzdopen (dup (fileno port)) "r")) | |
688ec13c LC |
169 | (_ |
170 | ;; This is unrecoverable but it's better than having the buffered input | |
171 | ;; be lost, leading to unclear end-of-file or corrupt-data errors down | |
172 | ;; the path. | |
173 | (throw 'zlib-error 'make-gzip-input-port | |
174 | "port contains buffered input" port)))) | |
72153902 LC |
175 | |
176 | (define (read! bv start count) | |
72153902 LC |
177 | (gzread! gzfile bv start count)) |
178 | ||
179 | (unless (= buffer-size %default-buffer-size) | |
180 | (gzbuffer! gzfile buffer-size)) | |
181 | ||
85f4f7b7 | 182 | (close-port port) ;we no longer need it |
72153902 | 183 | (make-custom-binary-input-port "gzip-input" read! #f #f |
85f4f7b7 LC |
184 | (lambda () |
185 | (gzclose gzfile)))) | |
72153902 LC |
186 | |
187 | (define* (make-gzip-output-port port | |
188 | #:key | |
189 | (level %default-compression-level) | |
190 | (buffer-size %default-buffer-size)) | |
191 | "Return an output port that compresses data at the given LEVEL, using PORT, | |
192 | a file port, as its sink. PORT is automatically closed when the resulting | |
193 | port is closed." | |
194 | (define gzfile | |
688ec13c LC |
195 | (begin |
196 | (force-output port) ;empty PORT's buffer | |
85f4f7b7 | 197 | (gzdopen (dup (fileno port)) |
688ec13c | 198 | (string-append "w" (number->string level))))) |
72153902 LC |
199 | |
200 | (define (write! bv start count) | |
201 | (gzwrite gzfile bv start count)) | |
202 | ||
203 | (unless (= buffer-size %default-buffer-size) | |
204 | (gzbuffer! gzfile buffer-size)) | |
205 | ||
85f4f7b7 | 206 | (close-port port) |
72153902 | 207 | (make-custom-binary-output-port "gzip-output" write! #f #f |
85f4f7b7 LC |
208 | (lambda () |
209 | (gzclose gzfile)))) | |
72153902 LC |
210 | |
211 | (define* (call-with-gzip-input-port port proc | |
212 | #:key (buffer-size %default-buffer-size)) | |
213 | "Call PROC with a port that wraps PORT and decompresses data read from it. | |
214 | PORT is closed upon completion. The gzip internal buffer size is set to | |
215 | BUFFER-SIZE bytes." | |
216 | (let ((gzip (make-gzip-input-port port #:buffer-size buffer-size))) | |
217 | (dynamic-wind | |
218 | (const #t) | |
219 | (lambda () | |
220 | (proc gzip)) | |
221 | (lambda () | |
222 | (close-port gzip))))) | |
223 | ||
224 | (define* (call-with-gzip-output-port port proc | |
225 | #:key | |
226 | (level %default-compression-level) | |
227 | (buffer-size %default-buffer-size)) | |
228 | "Call PROC with an output port that wraps PORT and compresses data. PORT is | |
229 | close upon completion. The gzip internal buffer size is set to BUFFER-SIZE | |
230 | bytes." | |
231 | (let ((gzip (make-gzip-output-port port | |
232 | #:level level | |
233 | #:buffer-size buffer-size))) | |
234 | (dynamic-wind | |
235 | (const #t) | |
236 | (lambda () | |
237 | (proc gzip)) | |
238 | (lambda () | |
239 | (close-port gzip))))) | |
240 | ||
241 | ;;; zlib.scm ends here |