256 lines
9.3 KiB
Scheme
256 lines
9.3 KiB
Scheme
;;; GNU Guix --- Functional package management for GNU
|
||
;;; Copyright © 2016 Ludovic Courtès <ludo@gnu.org>
|
||
;;;
|
||
;;; This file is part of GNU Guix.
|
||
;;;
|
||
;;; GNU Guix is free software; you can redistribute it and/or modify it
|
||
;;; under the terms of the GNU General Public License as published by
|
||
;;; the Free Software Foundation; either version 3 of the License, or (at
|
||
;;; your option) any later version.
|
||
;;;
|
||
;;; GNU Guix is distributed in the hope that it will be useful, but
|
||
;;; WITHOUT ANY WARRANTY; without even the implied warranty of
|
||
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||
;;; GNU General Public License for more details.
|
||
;;;
|
||
;;; You should have received a copy of the GNU General Public License
|
||
;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
|
||
|
||
(define-module (guix zlib)
|
||
#:use-module (rnrs bytevectors)
|
||
#:use-module (ice-9 binary-ports)
|
||
#:use-module (ice-9 match)
|
||
#:use-module (system foreign)
|
||
#:use-module (guix config)
|
||
#:export (zlib-available?
|
||
make-gzip-input-port
|
||
make-gzip-output-port
|
||
call-with-gzip-input-port
|
||
call-with-gzip-output-port
|
||
%default-buffer-size
|
||
%default-compression-level))
|
||
|
||
;;; Commentary:
|
||
;;;
|
||
;;; Bindings to the gzip-related part of zlib's API. The main limitation of
|
||
;;; this API is that it requires a file descriptor as the source or sink.
|
||
;;;
|
||
;;; Code:
|
||
|
||
(define %zlib
|
||
;; File name of zlib's shared library. When updating via 'guix pull',
|
||
;; '%libz' might be undefined so protect against it.
|
||
(delay (dynamic-link (if (defined? '%libz)
|
||
%libz
|
||
"libz"))))
|
||
|
||
(define (zlib-available?)
|
||
"Return true if zlib is available, #f otherwise."
|
||
(false-if-exception (force %zlib)))
|
||
|
||
(define (zlib-procedure ret name parameters)
|
||
"Return a procedure corresponding to C function NAME in libz, or #f if
|
||
either zlib or the function could not be found."
|
||
(match (false-if-exception (dynamic-func name (force %zlib)))
|
||
((? pointer? ptr)
|
||
(pointer->procedure ret ptr parameters))
|
||
(#f
|
||
#f)))
|
||
|
||
(define-wrapped-pointer-type <gzip-file>
|
||
;; Scheme counterpart of the 'gzFile' opaque type.
|
||
gzip-file?
|
||
pointer->gzip-file
|
||
gzip-file->pointer
|
||
(lambda (obj port)
|
||
(format port "#<gzip-file ~a>"
|
||
(number->string (object-address obj) 16))))
|
||
|
||
(define gzerror
|
||
(let ((proc (zlib-procedure '* "gzerror" '(* *))))
|
||
(lambda (gzfile)
|
||
(let* ((errnum* (make-bytevector (sizeof int)))
|
||
(ptr (proc (gzip-file->pointer gzfile)
|
||
(bytevector->pointer errnum*))))
|
||
(values (bytevector-sint-ref errnum* 0
|
||
(native-endianness) (sizeof int))
|
||
(pointer->string ptr))))))
|
||
|
||
(define gzdopen
|
||
(let ((proc (zlib-procedure '* "gzdopen" (list int '*))))
|
||
(lambda (fd mode)
|
||
"Open file descriptor FD as a gzip stream with the given MODE. MODE must
|
||
be a string denoting the how FD is to be opened, such as \"r\" for reading or
|
||
\"w9\" for writing data compressed at level 9 to FD. Calling 'gzclose' also
|
||
closes FD."
|
||
(let ((result (proc fd (string->pointer mode))))
|
||
(if (null-pointer? result)
|
||
(throw 'zlib-error 'gzdopen)
|
||
(pointer->gzip-file result))))))
|
||
|
||
(define gzread!
|
||
(let ((proc (zlib-procedure int "gzread" (list '* '* unsigned-int))))
|
||
(lambda* (gzfile bv #:optional (start 0) (count (bytevector-length bv)))
|
||
"Read up to COUNT bytes from GZFILE into BV at offset START. Return the
|
||
number of uncompressed bytes actually read; it is zero if COUNT is zero or if
|
||
the end-of-stream has been reached."
|
||
(let ((ret (proc (gzip-file->pointer gzfile)
|
||
(bytevector->pointer bv start)
|
||
count)))
|
||
(if (< ret 0)
|
||
(throw 'zlib-error 'gzread! ret)
|
||
ret)))))
|
||
|
||
(define gzwrite
|
||
(let ((proc (zlib-procedure int "gzwrite" (list '* '* unsigned-int))))
|
||
(lambda* (gzfile bv #:optional (start 0) (count (bytevector-length bv)))
|
||
"Write up to COUNT bytes from BV at offset START into GZFILE. Return
|
||
the number of uncompressed bytes written, a strictly positive integer."
|
||
(let ((ret (proc (gzip-file->pointer gzfile)
|
||
(bytevector->pointer bv start)
|
||
count)))
|
||
(if (<= ret 0)
|
||
(throw 'zlib-error 'gzwrite ret)
|
||
ret)))))
|
||
|
||
(define gzbuffer!
|
||
(let ((proc (zlib-procedure int "gzbuffer" (list '* unsigned-int))))
|
||
(lambda (gzfile size)
|
||
"Change the internal buffer size of GZFILE to SIZE bytes."
|
||
(let ((ret (proc (gzip-file->pointer gzfile) size)))
|
||
(unless (zero? ret)
|
||
(throw 'zlib-error 'gzbuffer! ret))))))
|
||
|
||
(define gzeof?
|
||
(let ((proc (zlib-procedure int "gzeof" '(*))))
|
||
(lambda (gzfile)
|
||
"Return true if the end-of-file has been reached on GZFILE."
|
||
(not (zero? (proc (gzip-file->pointer gzfile)))))))
|
||
|
||
(define gzclose
|
||
(let ((proc (zlib-procedure int "gzclose" '(*))))
|
||
(lambda (gzfile)
|
||
"Close GZFILE."
|
||
(let ((ret (proc (gzip-file->pointer gzfile))))
|
||
(unless (zero? ret)
|
||
(throw 'zlib-error 'gzclose ret (gzerror gzfile)))))))
|
||
|
||
|
||
|
||
;;;
|
||
;;; Port interface.
|
||
;;;
|
||
|
||
(define %default-buffer-size
|
||
;; Default buffer size, as documented in <zlib.h>.
|
||
8192)
|
||
|
||
(define %default-compression-level
|
||
;; Z_DEFAULT_COMPRESSION.
|
||
-1)
|
||
|
||
(define (close-procedure gzfile port)
|
||
"Return a procedure that closes GZFILE, ensuring its underlying PORT is
|
||
closed even if closing GZFILE triggers an exception."
|
||
(let-syntax ((ignore-EBADF
|
||
(syntax-rules ()
|
||
((_ exp)
|
||
(catch 'system-error
|
||
(lambda ()
|
||
exp)
|
||
(lambda args
|
||
(unless (= EBADF (system-error-errno args))
|
||
(apply throw args))))))))
|
||
|
||
(lambda ()
|
||
(catch 'zlib-error
|
||
(lambda ()
|
||
;; 'gzclose' closes the underlying file descriptor. 'close-port'
|
||
;; calls close(2) and gets EBADF, which we swallow.
|
||
(gzclose gzfile)
|
||
(ignore-EBADF (close-port port)))
|
||
(lambda args
|
||
;; Make sure PORT is closed despite the zlib error.
|
||
(ignore-EBADF (close-port port))
|
||
(apply throw args))))))
|
||
|
||
(define* (make-gzip-input-port port #:key (buffer-size %default-buffer-size))
|
||
"Return an input port that decompresses data read from PORT, a file port.
|
||
PORT is automatically closed when the resulting port is closed. BUFFER-SIZE
|
||
is the size in bytes of the internal buffer, 8 KiB by default; using a larger
|
||
buffer increases decompression speed. An error is thrown if PORT contains
|
||
buffered input, which would be lost (and is lost anyway)."
|
||
(define gzfile
|
||
(match (drain-input port)
|
||
("" ;PORT's buffer is empty
|
||
(gzdopen (fileno port) "r"))
|
||
(_
|
||
;; This is unrecoverable but it's better than having the buffered input
|
||
;; be lost, leading to unclear end-of-file or corrupt-data errors down
|
||
;; the path.
|
||
(throw 'zlib-error 'make-gzip-input-port
|
||
"port contains buffered input" port))))
|
||
|
||
(define (read! bv start count)
|
||
(gzread! gzfile bv start count))
|
||
|
||
(unless (= buffer-size %default-buffer-size)
|
||
(gzbuffer! gzfile buffer-size))
|
||
|
||
(make-custom-binary-input-port "gzip-input" read! #f #f
|
||
(close-procedure gzfile port)))
|
||
|
||
(define* (make-gzip-output-port port
|
||
#:key
|
||
(level %default-compression-level)
|
||
(buffer-size %default-buffer-size))
|
||
"Return an output port that compresses data at the given LEVEL, using PORT,
|
||
a file port, as its sink. PORT is automatically closed when the resulting
|
||
port is closed."
|
||
(define gzfile
|
||
(begin
|
||
(force-output port) ;empty PORT's buffer
|
||
(gzdopen (fileno port)
|
||
(string-append "w" (number->string level)))))
|
||
|
||
(define (write! bv start count)
|
||
(gzwrite gzfile bv start count))
|
||
|
||
(unless (= buffer-size %default-buffer-size)
|
||
(gzbuffer! gzfile buffer-size))
|
||
|
||
(make-custom-binary-output-port "gzip-output" write! #f #f
|
||
(close-procedure gzfile port)))
|
||
|
||
(define* (call-with-gzip-input-port port proc
|
||
#:key (buffer-size %default-buffer-size))
|
||
"Call PROC with a port that wraps PORT and decompresses data read from it.
|
||
PORT is closed upon completion. The gzip internal buffer size is set to
|
||
BUFFER-SIZE bytes."
|
||
(let ((gzip (make-gzip-input-port port #:buffer-size buffer-size)))
|
||
(dynamic-wind
|
||
(const #t)
|
||
(lambda ()
|
||
(proc gzip))
|
||
(lambda ()
|
||
(close-port gzip)))))
|
||
|
||
(define* (call-with-gzip-output-port port proc
|
||
#:key
|
||
(level %default-compression-level)
|
||
(buffer-size %default-buffer-size))
|
||
"Call PROC with an output port that wraps PORT and compresses data. PORT is
|
||
close upon completion. The gzip internal buffer size is set to BUFFER-SIZE
|
||
bytes."
|
||
(let ((gzip (make-gzip-output-port port
|
||
#:level level
|
||
#:buffer-size buffer-size)))
|
||
(dynamic-wind
|
||
(const #t)
|
||
(lambda ()
|
||
(proc gzip))
|
||
(lambda ()
|
||
(close-port gzip)))))
|
||
|
||
;;; zlib.scm ends here
|