Commit | Line | Data |
---|---|---|
72153902 LC |
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 | ||
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 | |
81a0f1cd LC |
161 | ;; Since 'gzclose' will eventually close the file descriptor beneath |
162 | ;; PORT, we increase PORT's revealed count and never call 'close-port' | |
163 | ;; on PORT since we would get EBADF if 'gzclose' already closed it (on | |
164 | ;; 2.0 EBADF is swallowed by 'fport_close' but on 2.2 it is raised). | |
165 | (gzdopen (port->fdes port) "r")) | |
688ec13c LC |
166 | (_ |
167 | ;; This is unrecoverable but it's better than having the buffered input | |
168 | ;; be lost, leading to unclear end-of-file or corrupt-data errors down | |
169 | ;; the path. | |
170 | (throw 'zlib-error 'make-gzip-input-port | |
171 | "port contains buffered input" port)))) | |
72153902 LC |
172 | |
173 | (define (read! bv start count) | |
72153902 LC |
174 | (gzread! gzfile bv start count)) |
175 | ||
176 | (unless (= buffer-size %default-buffer-size) | |
177 | (gzbuffer! gzfile buffer-size)) | |
178 | ||
179 | (make-custom-binary-input-port "gzip-input" read! #f #f | |
81a0f1cd LC |
180 | (lambda () |
181 | (gzclose gzfile)))) | |
72153902 LC |
182 | |
183 | (define* (make-gzip-output-port port | |
184 | #:key | |
185 | (level %default-compression-level) | |
186 | (buffer-size %default-buffer-size)) | |
187 | "Return an output port that compresses data at the given LEVEL, using PORT, | |
188 | a file port, as its sink. PORT is automatically closed when the resulting | |
189 | port is closed." | |
190 | (define gzfile | |
688ec13c LC |
191 | (begin |
192 | (force-output port) ;empty PORT's buffer | |
81a0f1cd | 193 | (gzdopen (port->fdes port) |
688ec13c | 194 | (string-append "w" (number->string level))))) |
72153902 LC |
195 | |
196 | (define (write! bv start count) | |
197 | (gzwrite gzfile bv start count)) | |
198 | ||
199 | (unless (= buffer-size %default-buffer-size) | |
200 | (gzbuffer! gzfile buffer-size)) | |
201 | ||
202 | (make-custom-binary-output-port "gzip-output" write! #f #f | |
81a0f1cd LC |
203 | (lambda () |
204 | (gzclose gzfile)))) | |
72153902 LC |
205 | |
206 | (define* (call-with-gzip-input-port port proc | |
207 | #:key (buffer-size %default-buffer-size)) | |
208 | "Call PROC with a port that wraps PORT and decompresses data read from it. | |
209 | PORT is closed upon completion. The gzip internal buffer size is set to | |
210 | BUFFER-SIZE bytes." | |
211 | (let ((gzip (make-gzip-input-port port #:buffer-size buffer-size))) | |
212 | (dynamic-wind | |
213 | (const #t) | |
214 | (lambda () | |
215 | (proc gzip)) | |
216 | (lambda () | |
217 | (close-port gzip))))) | |
218 | ||
219 | (define* (call-with-gzip-output-port port proc | |
220 | #:key | |
221 | (level %default-compression-level) | |
222 | (buffer-size %default-buffer-size)) | |
223 | "Call PROC with an output port that wraps PORT and compresses data. PORT is | |
224 | close upon completion. The gzip internal buffer size is set to BUFFER-SIZE | |
225 | bytes." | |
226 | (let ((gzip (make-gzip-output-port port | |
227 | #:level level | |
228 | #:buffer-size buffer-size))) | |
229 | (dynamic-wind | |
230 | (const #t) | |
231 | (lambda () | |
232 | (proc gzip)) | |
233 | (lambda () | |
234 | (close-port gzip))))) | |
235 | ||
236 | ;;; zlib.scm ends here |