guix-devel/guix/zlib.scm

256 lines
9.3 KiB
Scheme
Raw Normal View History

;;; 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