235 lines
8.4 KiB
Scheme
235 lines
8.4 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."
|
|||
|
|
(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."
|
|||
|
|
(lambda ()
|
|||
|
|
(catch 'zlib-error
|
|||
|
|
(lambda ()
|
|||
|
|
;; 'gzclose' closes the underlying file descriptor. 'close-port'
|
|||
|
|
;; calls close(2), gets EBADF, which is ignores.
|
|||
|
|
(gzclose gzfile)
|
|||
|
|
(close-port port))
|
|||
|
|
(lambda args
|
|||
|
|
;; Make sure PORT is closed despite the zlib error.
|
|||
|
|
(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."
|
|||
|
|
(define gzfile
|
|||
|
|
(gzdopen (fileno port) "r"))
|
|||
|
|
|
|||
|
|
(define (read! bv start count)
|
|||
|
|
;; XXX: Can 'gzread!' return zero even though we haven't reached the EOF?
|
|||
|
|
(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
|
|||
|
|
(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
|