pax_global_header00006660000000000000000000000064140226644150014516gustar00rootroot0000000000000052 comment=429b3c65ee8946d7ced2353efb8710047fd29c57 guile-zlib/000077500000000000000000000000001402266441500131255ustar00rootroot00000000000000guile-zlib/.gitignore000066400000000000000000000014551402266441500151220ustar00rootroot00000000000000*.eps *.go *.log *.pdf *.png *.tar.xz *.tar.gz *.tmp *~ .#* \#*\# ,* /ABOUT-NLS /INSTALL /aclocal.m4 /autom4te.cache /build-aux/ar-lib /build-aux/compile /build-aux/config.guess /build-aux/config.rpath /build-aux/config.sub /build-aux/depcomp /build-aux/install-sh /build-aux/mdate-sh /build-aux/missing /build-aux/test-driver /build-aux/texinfo.tex /config.status /configure /doc/*.1 /doc/.dirstamp /doc/contributing.*.texi /doc/*.aux /doc/*.cp /doc/*.cps /doc/*.fn /doc/*.fns /doc/*.html /doc/*.info /doc/*.info-[0-9] /doc/*.ky /doc/*.pg /doc/*.toc /doc/*.t2p /doc/*.tp /doc/*.vr /doc/*.vrs /doc/stamp-vti /doc/version.texi /doc/version-*.texi /m4/* /pre-inst-env /test-env /test-tmp /tests/*.trs GPATH GRTAGS GTAGS Makefile Makefile.in config.cache stamp-h[0-9] tmp /.version /doc/stamp-[0-9] /zlib/config.scm guile-zlib/AUTHORS000066400000000000000000000001111402266441500141660ustar00rootroot00000000000000Contributers to Guile Zlib 0.1: Mathieu Othacehe guile-zlib/COPYING000066400000000000000000000001531402266441500141570ustar00rootroot00000000000000This project's license is GPL 3+. You can read the full license at https://www.gnu.org/licenses/gpl.html. guile-zlib/ChangeLog000066400000000000000000000000001402266441500146650ustar00rootroot00000000000000guile-zlib/HACKING000066400000000000000000000017471402266441500141250ustar00rootroot00000000000000-*- mode: org; coding: utf-8; -*- #+TITLE: Hacking zlib * Contributing By far the easiest way to hack on zlib is to develop using Guix: #+BEGIN_SRC bash # Obtain the source code cd /path/to/source-code guix environment -l guix.scm # In the new shell, run: hall dist --execute && autoreconf -vif && ./configure && make check #+END_SRC You can now hack this project's files to your heart's content, whilst testing them from your `guix environment' shell. If you'd like to tidy the project again, but retain the ability to test the project from the commandline, simply run: #+BEGIN_SRC bash ./hall clean --skip "pre-inst-env" --execute #+END_SRC ** Manual Installation If you do not yet use Guix, you will have to install this project's dependencies manually: - autoconf - automake - pkg-config - texinfo - guile-hall - zlib Once those dependencies are installed you can run: #+BEGIN_SRC bash hall dist -x && autoreconf -vif && ./configure && make check #+END_SRC guile-zlib/Makefile.am000066400000000000000000000040351402266441500151630ustar00rootroot00000000000000 bin_SCRIPTS = # Handle substitution of fully-expanded Autoconf variables. do_subst = $(SED) \ -e 's,[@]GUILE[@],$(GUILE),g' \ -e 's,[@]guilemoduledir[@],$(guilemoduledir),g' \ -e 's,[@]guileobjectdir[@],$(guileobjectdir),g' \ -e 's,[@]localedir[@],$(localedir),g' nodist_noinst_SCRIPTS = pre-inst-env GOBJECTS = $(SOURCES:%.scm=%.go) moddir=$(prefix)/share/guile/site/$(GUILE_EFFECTIVE_VERSION) godir=$(libdir)/guile/$(GUILE_EFFECTIVE_VERSION)/site-ccache ccachedir=$(libdir)/guile/$(GUILE_EFFECTIVE_VERSION)/site-ccache nobase_mod_DATA = $(SOURCES) $(NOCOMP_SOURCES) nobase_go_DATA = $(GOBJECTS) # Make sure source files are installed first, so that the mtime of # installed compiled files is greater than that of installed source # files. See # # for details. guile_install_go_files = install-nobase_goDATA $(guile_install_go_files): install-nobase_modDATA EXTRA_DIST = $(SOURCES) $(NOCOMP_SOURCES) GUILE_WARNINGS = -Wunbound-variable -Warity-mismatch -Wformat SUFFIXES = .scm .go .scm.go: $(AM_V_GEN)$(top_builddir)/pre-inst-env $(GUILE_TOOLS) compile $(GUILE_TARGET) $(GUILE_WARNINGS) -o "$@" "$<" SOURCES = zlib.scm \ zlib/config.scm TESTS = \ tests/zlib.scm TEST_EXTENSIONS = .scm SCM_LOG_DRIVER = \ $(top_builddir)/pre-inst-env \ $(GUILE) --no-auto-compile -e main \ $(top_srcdir)/build-aux/test-driver.scm # Tell 'build-aux/test-driver.scm' to display only source file names, # not indivdual test names. AM_SCM_LOG_DRIVER_FLAGS = --brief=yes AM_SCM_LOG_FLAGS = --no-auto-compile -L "$(top_srcdir)" AM_TESTS_ENVIRONMENT = abs_top_srcdir="$(abs_top_srcdir)" EXTRA_DIST += README.org \ README \ HACKING \ COPYING \ guix.scm \ hall.scm \ build-aux/test-driver.scm \ $(TESTS) clean-go: -$(RM) $(GOBJECTS) .PHONY: clean-go CLEANFILES = \ $(GOBJECTS) \ $(TESTS:tests/%.scm=%.log) guile-zlib/NEWS000066400000000000000000000020461402266441500136260ustar00rootroot00000000000000 -*- org -*- #+TITLE: Guile-zlib NEWS – history of user-visible changes #+STARTUP: content hidestars Copyright © 2021 Ludovic Courtès Copying and distribution of this file, with or without modification, are permitted in any medium without royalty provided the copyright notice and this notice are preserved. Please report bugs at . * Changes in 0.1.0 (compared to 0.0.1) ** New procedures: ‘make-zlib-input-port’, ‘make-zlib-output-port’ These procedures and the companion ‘call-with-zlib-*’ procedures provide an alternative to the ‘make-gzip-*’ and ‘call-with-gzip-*’ procedures; unlike those, they operate on all types of ports, not just file ports. These procedures also support multiple formats: raw “deflate”, “zlib”, and “gzip”. ** New ‘compress’ and ‘uncompress’ procedures These procedures support compression/decompression of individual bytevectors. guile-zlib/README000077700000000000000000000000001402266441500154462README.orgustar00rootroot00000000000000guile-zlib/README.org000066400000000000000000000007521402266441500145770ustar00rootroot00000000000000-*- mode: org; coding: utf-8; -*- #+TITLE: README for Guile Zlib * Guile-zlib Guile-zlib is a GNU Guile library providing bindings to [[https://zlib.net/][zlib]]. Copyright © 2020 Mathieu Othacehe Copying and distribution of this file, with or without modification, are permitted in any medium without royalty provided the copyright notice and this notice are preserved. This file is offered as-is, without any warranty. See [[./HACKING]] for build instructions. guile-zlib/build-aux/000077500000000000000000000000001402266441500150175ustar00rootroot00000000000000guile-zlib/build-aux/test-driver.scm000066400000000000000000000173031402266441500177770ustar00rootroot00000000000000 ;;;; test-driver.scm - Guile test driver for Automake testsuite harness (define script-version "2019-01-15.13") ;UTC ;;; Copyright © 2015, 2016 Mathieu Lirzin ;;; Copyright © 2019 Alex Sassmannshausen ;;; ;;; This program 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. ;;; ;;; This program 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 this program. If not, see . ;;;; Commentary: ;;; ;;; This script provides a Guile test driver using the SRFI-64 Scheme API for ;;; test suites. SRFI-64 is distributed with Guile since version 2.0.9. ;;; ;;; This script is a lightly modified version of the orignal written by ;;; Matthieu Lirzin. The changes make it suitable for use as part of the ;;; guile-hall infrastructure. ;;; ;;;; Code: (use-modules (ice-9 getopt-long) (ice-9 pretty-print) (srfi srfi-26) (srfi srfi-64)) (define (show-help) (display "Usage: test-driver --test-name=NAME --log-file=PATH --trs-file=PATH [--expect-failure={yes|no}] [--color-tests={yes|no}] [--enable-hard-errors={yes|no}] [--brief={yes|no}}] [--] TEST-SCRIPT [TEST-SCRIPT-ARGUMENTS] The '--test-name', '--log-file' and '--trs-file' options are mandatory. ")) (define %options '((test-name (value #t)) (log-file (value #t)) (trs-file (value #t)) (color-tests (value #t)) (expect-failure (value #t)) ;XXX: not implemented yet (enable-hard-errors (value #t)) ;not implemented in SRFI-64 (brief (value #t)) (help (single-char #\h) (value #f)) (version (single-char #\V) (value #f)))) (define (option->boolean options key) "Return #t if the value associated with KEY in OPTIONS is 'yes'." (and=> (option-ref options key #f) (cut string=? <> "yes"))) (define* (test-display field value #:optional (port (current-output-port)) #:key pretty?) "Display 'FIELD: VALUE\n' on PORT." (if pretty? (begin (format port "~A:~%" field) (pretty-print value port #:per-line-prefix "+ ")) (format port "~A: ~S~%" field value))) (define* (result->string symbol #:key colorize?) "Return SYMBOL as an upper case string. Use colors when COLORIZE is #t." (let ((result (string-upcase (symbol->string symbol)))) (if colorize? (string-append (case symbol ((pass) "") ;green ((xfail) "") ;light green ((skip) "") ;blue ((fail xpass) "") ;red ((error) "")) ;magenta result "") ;no color result))) (define* (test-runner-gnu test-name #:key color? brief? out-port trs-port) "Return an custom SRFI-64 test runner. TEST-NAME is a string specifying the file name of the current the test. COLOR? specifies whether to use colors, and BRIEF?, well, you know. OUT-PORT and TRS-PORT must be output ports. The current output port is supposed to be redirected to a '.log' file." (define (test-on-test-begin-gnu runner) ;; Procedure called at the start of an individual test case, before the ;; test expression (and expected value) are evaluated. (let ((result (cute assq-ref (test-result-alist runner) <>))) (format #t "test-name: ~A~%" (result 'test-name)) (format #t "location: ~A~%" (string-append (result 'source-file) ":" (number->string (result 'source-line)))) (test-display "source" (result 'source-form) #:pretty? #t))) (define (test-on-test-end-gnu runner) ;; Procedure called at the end of an individual test case, when the result ;; of the test is available. (let* ((results (test-result-alist runner)) (result? (cut assq <> results)) (result (cut assq-ref results <>))) (unless brief? ;; Display the result of each test case on the console. (format out-port "~A: ~A - ~A~%" (result->string (test-result-kind runner) #:colorize? color?) test-name (test-runner-test-name runner))) (when (result? 'expected-value) (test-display "expected-value" (result 'expected-value))) (when (result? 'expected-error) (test-display "expected-error" (result 'expected-error) #:pretty? #t)) (when (result? 'actual-value) (test-display "actual-value" (result 'actual-value))) (when (result? 'actual-error) (test-display "actual-error" (result 'actual-error) #:pretty? #t)) (format #t "result: ~a~%" (result->string (result 'result-kind))) (newline) (format trs-port ":test-result: ~A ~A~%" (result->string (test-result-kind runner)) (test-runner-test-name runner)))) (define (test-on-group-end-gnu runner) ;; Procedure called by a 'test-end', including at the end of a test-group. (let ((fail (or (positive? (test-runner-fail-count runner)) (positive? (test-runner-xpass-count runner)))) (skip (or (positive? (test-runner-skip-count runner)) (positive? (test-runner-xfail-count runner))))) ;; XXX: The global results need some refinements for XPASS. (format trs-port ":global-test-result: ~A~%" (if fail "FAIL" (if skip "SKIP" "PASS"))) (format trs-port ":recheck: ~A~%" (if fail "yes" "no")) (format trs-port ":copy-in-global-log: ~A~%" (if (or fail skip) "yes" "no")) (when brief? ;; Display the global test group result on the console. (format out-port "~A: ~A~%" (result->string (if fail 'fail (if skip 'skip 'pass)) #:colorize? color?) test-name)) #f)) (let ((runner (test-runner-null))) (test-runner-on-test-begin! runner test-on-test-begin-gnu) (test-runner-on-test-end! runner test-on-test-end-gnu) (test-runner-on-group-end! runner test-on-group-end-gnu) (test-runner-on-bad-end-name! runner test-on-bad-end-name-simple) runner)) ;;; ;;; Entry point. ;;; (define (main . args) (let* ((opts (getopt-long (command-line) %options)) (option (cut option-ref opts <> <>))) (cond ((option 'help #f) (show-help)) ((option 'version #f) (format #t "test-driver.scm ~A" script-version)) (else (let ((log (open-file (option 'log-file "") "w0")) (trs (open-file (option 'trs-file "") "wl")) (out (duplicate-port (current-output-port) "wl"))) (redirect-port log (current-output-port)) (redirect-port log (current-warning-port)) (redirect-port log (current-error-port)) (test-with-runner (test-runner-gnu (option 'test-name #f) #:color? (option->boolean opts 'color-tests) #:brief? (option->boolean opts 'brief) #:out-port out #:trs-port trs) (load-from-path (option 'test-name #f))) (close-port log) (close-port trs) (close-port out)))) (exit 0))) guile-zlib/configure.ac000066400000000000000000000026611402266441500154200ustar00rootroot00000000000000AC_PREREQ([2.69]) AC_INIT([Guile-zlib], [0.1.0], [guile-user@gnu.org], [guile-zlib], [https://notabug.org/guile-zlib/guile-zlib]) AC_SUBST(HVERSION, "\"0.1\"") AC_SUBST(AUTHOR, "\"Mathieu Othacehe\"") AC_SUBST(COPYRIGHT, "'(2020)") AC_SUBST(LICENSE, gpl3+) AC_CONFIG_SRCDIR(zlib.scm) AC_CONFIG_AUX_DIR([build-aux]) AM_INIT_AUTOMAKE([1.12 gnu silent-rules subdir-objects color-tests parallel-tests -Woverride -Wno-portability]) AM_SILENT_RULES([yes]) AC_CONFIG_FILES([Makefile zlib/config.scm]) AC_CONFIG_FILES([pre-inst-env], [chmod +x pre-inst-env]) dnl Search for 'guile' and 'guild'. This macro defines dnl 'GUILE_EFFECTIVE_VERSION'. GUILE_PKG([3.0 2.2 2.0]) GUILE_PROGS GUILE_SITE_DIR if test "x$GUILD" = "x"; then AC_MSG_ERROR(['guild' binary not found; please check your GNU Guile installation.]) fi if test "$cross_compiling" != no; then GUILE_TARGET="--target=$host_alias" AC_SUBST([GUILE_TARGET]) fi PKG_CHECK_MODULES([LIBZ], [zlib]) AC_MSG_CHECKING([libz library directory]) PKG_CHECK_VAR([LIBZ_LIBDIR], [zlib], [libdir]) AC_MSG_RESULT([$LIBZ_LIBDIR]) AS_IF([test "x$LIBZ_LIBDIR" = "x"], [ AC_MSG_FAILURE([Unable to identify libz lib path.]) ]) AC_SUBST([LIBZ_LIBDIR]) dnl Installation directories for .scm and .go files. guilemoduledir="${datarootdir}/guile/site/$GUILE_EFFECTIVE_VERSION" guileobjectdir="${libdir}/guile/$GUILE_EFFECTIVE_VERSION/site-ccache" AC_SUBST([guilemoduledir]) AC_SUBST([guileobjectdir]) AC_OUTPUT guile-zlib/guix.scm000066400000000000000000000013021402266441500146010ustar00rootroot00000000000000(use-modules (guix packages) ((guix licenses) #:prefix license:) (guix download) (guix build-system gnu) (gnu packages) (gnu packages autotools) (gnu packages compression) (gnu packages guile) (gnu packages guile-xyz) (gnu packages pkg-config) (gnu packages texinfo)) (package (name "guile-zlib") (version "0.1") (source "./guile-zlib-0.1.tar.gz") (build-system gnu-build-system) (arguments `()) (native-inputs `(("autoconf" ,autoconf) ("automake" ,automake) ("pkg-config" ,pkg-config))) (inputs `(("guile" ,guile-3.0) ("zlib" ,zlib))) (propagated-inputs `()) (synopsis "") (description "") (home-page "") (license license:gpl3+)) guile-zlib/hall.scm000066400000000000000000000017311402266441500145530ustar00rootroot00000000000000(hall-description (name "zlib") (prefix "guile") (version "0.1") (author "Mathieu Othacehe") (copyright (2020)) (synopsis "") (description "") (home-page "") (license gpl3+) (dependencies `()) (files (libraries ((scheme-file "zlib") (directory "zlib" ((scheme-file "config"))))) (tests ((directory "tests" ((scheme-file "zlib"))))) (programs ()) (documentation ((org-file "README") (symlink "README" "README.org") (text-file "HACKING") (text-file "COPYING") (text-file "NEWS") (text-file "AUTHORS") (text-file "ChangeLog"))) (infrastructure ((scheme-file "guix") (scheme-file "hall") (directory "build-aux" ((scheme-file "test-driver"))) (autoconf-file "configure") (automake-file "Makefile") (in-file "pre-inst-env"))))) guile-zlib/pre-inst-env.in000066400000000000000000000006621402266441500160100ustar00rootroot00000000000000 #!/bin/sh abs_top_srcdir="`cd "@abs_top_srcdir@" > /dev/null; pwd`" abs_top_builddir="`cd "@abs_top_builddir@" > /dev/null; pwd`" GUILE_LOAD_COMPILED_PATH="$abs_top_builddir${GUILE_LOAD_COMPILED_PATH:+:}$GUILE_LOAD_COMPILED_PATH" GUILE_LOAD_PATH="$abs_top_builddir:$abs_top_srcdir${GUILE_LOAD_PATH:+:}:$GUILE_LOAD_PATH" export GUILE_LOAD_COMPILED_PATH GUILE_LOAD_PATH PATH="$abs_top_builddir/scripts:$PATH" export PATH exec "$@" guile-zlib/tests/000077500000000000000000000000001402266441500142675ustar00rootroot00000000000000guile-zlib/tests/zlib.scm000066400000000000000000000100471402266441500157350ustar00rootroot00000000000000;;; Guile-zlib --- Functional package management for GNU ;;; Copyright © 2016, 2019, 2021 Ludovic Courtès ;;; ;;; This file is part of Guile-zlib. ;;; ;;; Guile-zlib 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. ;;; ;;; Guile-zlib 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 Guile-zlib. If not, see . (define-module (test-zlib) #:use-module (zlib) #:use-module (srfi srfi-1) #:use-module (srfi srfi-11) #:use-module (srfi srfi-64) #:use-module (rnrs bytevectors) #:use-module (rnrs io ports) #:use-module (ice-9 match)) (test-begin "zlib") (define (random-seed) (logxor (getpid) (car (gettimeofday)))) (define %seed (let ((seed (random-seed))) (format (current-error-port) "random seed for tests: ~a~%" seed) (seed->random-state seed))) (define (random-bytevector n) "Return a random bytevector of N bytes." (let ((bv (make-bytevector n))) (let loop ((i 0)) (if (< i n) (begin (bytevector-u8-set! bv i (random 256 %seed)) (loop (1+ i))) bv)))) (test-assert "compression/decompression pipe" (let ((data (random-bytevector (+ (random 10000) (* 20 1024))))) (match (pipe) ((parent . child) (match (primitive-fork) (0 ;compress (dynamic-wind (const #t) (lambda () (close-port parent) (call-with-gzip-output-port child (lambda (port) (put-bytevector port data)))) (lambda () (primitive-exit 0)))) (pid ;decompress (begin (close-port child) (let ((received (call-with-gzip-input-port parent (lambda (port) (get-bytevector-all port)) #:buffer-size (* 64 1024)))) (match (waitpid pid) ((_ . status) (and (zero? status) (port-closed? parent) (bytevector=? received data)))))))))))) (test-assert "raw compress/decompress" (let* ((data (random-bytevector (+ (random 10000) (* 20 1024)))) (cdata (compress data)) (ucdata (uncompress cdata))) (equal? data ucdata))) (define (test-zlib n fmt level) (test-assert (format #f "zlib ports [size: ~a, format: ~a, level: ~a]" n fmt level) (let* ((size (pk 'size (+ (random n %seed) n))) (data (random-bytevector size))) (let*-values (((port get) (open-bytevector-output-port)) ((compressed) (make-zlib-output-port port #:level level #:format fmt))) (put-bytevector compressed data) (close-port compressed) (let ((data2 (get-bytevector-all (make-zlib-input-port (open-bytevector-input-port (get)) #:format fmt)))) (pk 'sizes size 'vs (bytevector-length data2)) (bytevector=? data2 data)))))) (for-each (lambda (n) (for-each (lambda (format) (for-each (lambda (level) (test-zlib n format level)) (iota 9 1))) '(deflate zlib gzip))) (list (expt 2 8) (expt 2 10) (expt 2 12) (expt 2 14) (expt 2 18))) (test-end) guile-zlib/zlib.scm000066400000000000000000000734141402266441500146020ustar00rootroot00000000000000;;; Guile-zlib --- GNU Guile bindings of zlib ;;; Copyright © 2016, 2017, 2021 Ludovic Courtès ;;; Copyright © 2020 Mathieu Othacehe ;;; Copyright © 2013 David Thompson ;;; ;;; This file is part of Guile-zlib. ;;; ;;; Guile-zlib 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. ;;; ;;; Guile-zlib 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 Guile-zlib. If not, see . (define-module (zlib) #:use-module (zlib config) #:use-module (rnrs bytevectors) #:use-module (ice-9 binary-ports) #:use-module (ice-9 match) #:use-module (system foreign) #:use-module (ice-9 receive) #:use-module (srfi srfi-1) #:export (make-gzip-input-port make-gzip-output-port call-with-gzip-input-port call-with-gzip-output-port %default-buffer-size %default-compression-level compress uncompress adler32 crc32 make-zlib-input-port make-zlib-output-port call-with-zlib-input-port call-with-zlib-output-port)) ;;; Commentary: ;;; ;;; This file is extracted from Guix and originally written by Ludovic Courtès. ;;; 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 (delay (dynamic-link %libz))) (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 ;; Scheme counterpart of the 'gzFile' opaque type. gzip-file? pointer->gzip-file gzip-file->pointer (lambda (obj port) (format port "#" (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 . 8192) (define %default-compression-level ;; Z_DEFAULT_COMPRESSION. -1) (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 ;; 'gzclose' will eventually close the file descriptor beneath PORT. ;; 'close-port' on PORT would get EBADF if 'gzclose' already closed it, ;; so that's no good; revealed ports are no good either because they ;; leak (see ); calling 'close-port' after ;; 'gzclose' doesn't work either because it leads to a race condition ;; (see ). So we dup and close PORT right ;; away. (gzdopen (dup (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)) (close-port port) ;we no longer need it (make-custom-binary-input-port "gzip-input" read! #f #f (lambda () (gzclose gzfile)))) (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 must be a file port; it is automatically closed when the resulting port is closed." (define gzfile (begin (force-output port) ;empty PORT's buffer (gzdopen (dup (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)) (close-port port) (make-custom-binary-output-port "gzip-output" write! #f #f (lambda () (gzclose gzfile)))) (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 must be a file port; it is closed upon completion. The gzip internal buffer size is set to BUFFER-SIZE bytes. See 'call-with-zlib-input-port' for a slightly slower variant that does not require PORT to be a file port." (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 must be a file port; it is closed upon completion. The gzip internal buffer size is set to BUFFER-SIZE bytes. See 'call-with-zlib-output-port' for a slightly slower variant that does not require PORT to be a file port." (let ((gzip (make-gzip-output-port port #:level level #:buffer-size buffer-size))) (dynamic-wind (const #t) (lambda () (proc gzip)) (lambda () (close-port gzip))))) ;;; ;;; Raw operations, originally from davexunit's guile-zlib ;;; https://github.com/davexunit/guile-zlib ;;; fd28b7515efc4af6faf55854993cb0c8bed1f8c5 ;;; ;; ;; ZEXTERN int ZEXPORT uncompress OF((Bytef *dest, uLongf *destLen, ;; const Bytef *source, uLong sourceLen)); ;; ;; Decompresses the source buffer into the destination ;; buffer. sourceLen is the byte length of the source buffer. Upon ;; entry, destLen is the total size of the destination buffer, which ;; must be large enough to hold the entire uncompressed data. (The ;; size of the uncompressed data must have been saved previously by ;; the compressor and transmitted to the decompressor by some ;; mechanism outside the scope of this compression library.) Upon ;; exit, destLen is the actual size of the compressed buffer. ;; ;; uncompress returns Z_OK if success, Z_MEM_ERROR if there was not ;; enough memory, Z_BUF_ERROR if there was not enough room in the ;; output buffer, or Z_DATA_ERROR if the input data was corrupted or ;; incomplete. In the case where there is not enough room, ;; uncompress() will fill the output buffer with the uncompressed data ;; up to that point. (define %uncompress (zlib-procedure int "uncompress" (list '* '* '* unsigned-long))) ;; ;; ZEXTERN int ZEXPORT compress OF((Bytef *dest, uLongf *destLen, ;; const Bytef *source, uLong sourceLen)); ;; ;; Compresses the source buffer into the destination buffer. sourceLen ;; is the byte length of the source buffer. Upon entry, destLen is the ;; total size of the destination buffer, which must be at least the ;; value returned by compressBound(sourceLen). Upon exit, destLen is ;; the actual size of the compressed buffer. ;; ;; compress returns Z_OK if success, Z_MEM_ERROR if there was not ;; enough memory, Z_BUF_ERROR if there was not enough room in the ;; output buffer. (define %compress (zlib-procedure int "compress" (list '* '* '* unsigned-long))) ;; ;; ZEXTERN uLong ZEXPORT compressBound OF((uLong sourceLen)); ;; ;; compressBound() returns an upper bound on the compressed size after ;; compress() or compress2() on sourceLen bytes. It would be used ;; before a compress() or compress2() call to allocate the destination ;; buffer. (define %compress-bound (zlib-procedure unsigned-long "compressBound" (list unsigned-long))) ;; Update a running Adler-32 checksum with the bytes buf[0..len-1] and ;; return the updated checksum. If buf is Z_NULL, this function returns the ;; required initial value for the checksum. ;; ;; An Adler-32 checksum is almost as reliable as a CRC32 but can be computed ;; much faster. ;; ;; Usage example: ;; ;; uLong adler = adler32(0L, Z_NULL, 0); ;; ;; while (read_buffer(buffer, length) != EOF) { ;; adler = adler32(adler, buffer, length); ;; } ;; if (adler != original_adler) error(); (define %adler32 (zlib-procedure unsigned-long "adler32" (list unsigned-long '* unsigned-int))) ;; Update a running CRC-32 with the bytes buf[0..len-1] and return the ;; updated CRC-32. If buf is Z_NULL, this function returns the required ;; initial value for the crc. Pre- and post-conditioning (one's complement) is ;; performed within this function so it shouldn't be done by the application. ;; ;; Usage example: ;; ;; uLong crc = crc32(0L, Z_NULL, 0); ;; ;; while (read_buffer(buffer, length) != EOF) { ;; crc = crc32(crc, buffer, length); ;; } ;; if (crc != original_crc) error(); (define %crc32 (zlib-procedure unsigned-long "crc32" (list unsigned-long '* unsigned-int))) ;; There is a bit of guesswork involved when creating the bytevectors ;; to store compressed/uncompressed data in. This procedure provides a ;; convenient way to copy the portion of a bytevector that was ;; actually used. (define (bytevector-copy-region bv start end) (let* ((length (- end start)) (new-bv (make-bytevector length))) (bytevector-copy! bv start new-bv 0 length) new-bv)) ;; uncompress/compress take a bytevector that zlib writes the size of ;; the returned data to. This procedure saves me a few keystrokes when ;; fetching that value. (define (buffer-length bv) (bytevector-uint-ref bv 0 (native-endianness) (sizeof unsigned-long))) (define (uncompress bv) "Uncompresses bytevector and returns a bytevector containing the uncompressed data." (define (try-uncompress length) (let* ((dest (make-bytevector (* (sizeof uint8) length))) (dest-length (make-bytevector (sizeof unsigned-long)))) (bytevector-uint-set! dest-length 0 length (native-endianness) (sizeof unsigned-long)) (values (%uncompress (bytevector->pointer dest) (bytevector->pointer dest-length) (bytevector->pointer bv) length) (bytevector-copy-region dest 0 (buffer-length dest-length))))) ;; We don't know how much space we need to store the uncompressed ;; data. So, we make an initial guess and keep increasing buffer ;; size until it works. (define (step-buffer-length length) (inexact->exact (round (* length 1.5)))) (let try-again ((tries 1) (length (step-buffer-length (bytevector-length bv)))) ;; Bail after so many failed attempts. This shouldn't happen, but ;; I don't like the idea of a potentially unbounded loop that ;; keeps allocating larger and larger chunks of memory. (if (> tries 10) (throw 'zlib-error 'uncompress 0) (receive (ret-code uncompressed-data) (try-uncompress length) ;; return code -5 means that destination buffer was too small. ;; return code 0 means everything went OK. (cond ((= ret-code -5) (try-again (1+ tries) (step-buffer-length length))) ((= ret-code 0) uncompressed-data) (else (throw 'zlib-error 'uncompress ret-code))))))) (define (compress bv) "Compresses bytevector and returns a bytevector containing the compressed data." (let* ((bv-length (bytevector-length bv)) (dest-length (%compress-bound bv-length)) (dest-bv (make-bytevector dest-length)) (dest-length-bv (make-bytevector (sizeof unsigned-long))) (ret-code 0)) (bytevector-uint-set! dest-length-bv 0 dest-length (native-endianness) (sizeof unsigned-long)) (set! ret-code (%compress (bytevector->pointer dest-bv) (bytevector->pointer dest-length-bv) (bytevector->pointer bv) bv-length)) (if (= ret-code 0) (bytevector-copy-region dest-bv 0 (buffer-length dest-length-bv)) (throw 'zlib-error 'compress ret-code)))) (define %default-adler32 (%adler32 0 %null-pointer 0)) (define %default-crc32 (%crc32 0 %null-pointer 0)) (define* (adler32 bv #:optional (value %default-adler32)) "Computes adler32 checksum with optional starting value." (%adler32 value (bytevector->pointer bv) (bytevector-length bv))) (define* (crc32 bv #:optional (value %default-crc32)) "Computes crc32 checksum with optional starting value." (%crc32 value (bytevector->pointer bv) (bytevector-length bv))) ;;; ;;; Low-level zlib stream API. ;;; (define %zlib-version ;; Library version that we're targeting. "1.2.11") ;; struct zstream (define %stream-struct (list '* ;next_in unsigned-int ;avail_in unsigned-long ;total_in '* ;next_out unsigned-int ;avail_out unsigned-long ;total_out '* ;msg '* ;state '* ;zalloc '* ;zfree '* ;opaque int ;data_type unsigned-long ;adler unsigned-long)) ;reserved (define (offset-of types n) "Return the offset of the Nth field among TYPES, the list of types of a struct's fields." (if (zero? n) 0 (let* ((base (sizeof (take types n))) (align (alignof (list-ref types n))) (mod (modulo base align))) (if (zero? mod) base (+ base (- align mod)))))) (define-syntax-rule (define-stream-getter name index) "Define NAME as a procedure accessing the INDEXth field of %STREAM-STRUCT." (define name (let* ((offset (offset-of %stream-struct index)) (type (list-ref %stream-struct index)) (size (sizeof type))) (lambda (stream) (bytevector-uint-ref stream offset (native-endianness) size))))) (define-syntax-rule (define-stream-setter name index) "Define NAME as a procedure setting the INDEXth field of %STREAM-STRUCT." (define name (let* ((offset (offset-of %stream-struct index)) (type (list-ref %stream-struct index)) (size (sizeof type))) (lambda (stream value) (bytevector-uint-set! stream offset value (native-endianness) size))))) (define-stream-getter stream-avail-in 1) (define-stream-getter stream-avail-out 4) (define-stream-getter stream-error-message 6) (define-stream-setter set-stream-next-in! 0) (define-stream-setter set-stream-avail-in! 1) (define-stream-setter set-stream-next-out! 3) (define-stream-setter set-stream-avail-out! 4) (define (stream-error-message* stream) "Return the error message associated with STREAM or #f." (match (stream-error-message stream) ((? zero?) #f) (address (pointer->string (make-pointer address))))) (define inflate! (let ((proc (zlib-procedure int "inflate" `(* ,int)))) (lambda (stream flush) (proc stream flush)))) (define deflate! (let ((proc (zlib-procedure int "deflate" `(* ,int)))) (lambda (stream flush) (proc stream flush)))) (define (window-bits-for-format format) ;; Search for "windowBits" in . (define MAX_WBITS 15) ; (match format ('deflate (- MAX_WBITS)) ;raw deflate ('zlib MAX_WBITS) ;zlib header ('gzip (+ MAX_WBITS 16)))) ;gzip header (define inflate-init! (let ((proc (zlib-procedure int "inflateInit2_" `(* ,int * ,int)))) (lambda (stream window-bits) (let ((ret (proc stream window-bits (string->pointer %zlib-version) (sizeof %stream-struct)))) (unless (zero? ret) (throw 'zlib-error 'inflate-init! ret)))))) (define deflate-init! (let ((proc (zlib-procedure int "deflateInit2_" `(* ,int ,int ,int ,int ,int * ,int)))) (lambda* (stream level #:key (window-bits (window-bits-for-format 'zlib)) (memory-level 8) (strategy Z_DEFAULT_STRATEGY)) (let ((ret (proc stream level Z_DEFLATED window-bits memory-level strategy (string->pointer %zlib-version) (sizeof %stream-struct)))) (unless (zero? ret) (throw 'zlib-error 'deflate-init! ret)))))) (define inflate-end! (let ((proc (zlib-procedure int "inflateEnd" '(*)))) (lambda (stream) (let ((ret (proc stream))) (unless (zero? ret) (throw 'zlib-error 'inflate-end! ret)))))) (define deflate-end! (let ((proc (zlib-procedure int "deflateEnd" '(*)))) (lambda (stream) (let ((ret (proc stream))) (unless (zero? ret) (throw 'zlib-error 'deflate-end! ret)))))) ;; Error codes. (define Z_OK 0) (define Z_STREAM_END 1) (define Z_NEED_DICT 2) (define Z_ERRNO -1) (define Z_STREAM_ERROR -2) (define Z_DATA_ERROR -3) (define Z_MEM_ERROR -4) (define Z_BUF_ERROR -5) ;; Flush flags. (define Z_NO_FLUSH 0) (define Z_PARTIAL_FLUSH 1) (define Z_SYNC_FLUSH 2) (define Z_FULL_FLUSH 3) (define Z_FINISH 4) ;; 'deflate-init!' flags. (define Z_DEFLATED 8) (define Z_DEFAULT_STRATEGY 0) (define* (make-zlib-input-port port #:key (format 'zlib) (buffer-size %default-buffer-size) (close? #t)) "Return an input port that decompresses data read from PORT. FORMAT is a symbol denoting the header format; it must be one of 'deflate (RFC 1950), 'zlib (RFC 1951), or 'gzip (RFC 1952). When CLOSE? is true, PORT is automatically closed when the resulting port is closed." (define input-buffer (make-bytevector buffer-size)) ;; Instead of writing uncompressed data directly to the user-provided ;; buffer, keep a large-enough buffer. That way, we know we cannot stumble ;; into Z_BUF_ERROR because of insufficient output space. (define output-buffer (make-bytevector %default-buffer-size)) (define buffered 0) (define offset 0) (define eof? #f) (define stream (make-bytevector (sizeof %stream-struct))) (define pointer (let ((ptr (bytevector->pointer stream))) (lambda (bv) (if (eq? bv stream) ptr (bytevector->pointer bv))))) (define (read! bv start count) (cond ((> buffered 0) (let ((n (min count buffered))) (bytevector-copy! output-buffer offset bv start n) (set! buffered (- buffered n)) (set! offset (+ offset n)) n)) (eof? 0) (else (set! offset 0) (set-stream-next-out! stream (pointer-address (bytevector->pointer output-buffer))) (set-stream-avail-out! stream (bytevector-length output-buffer)) (let loop ((ret Z_OK) (flush? #f)) (if (and (not flush?) (or (zero? (stream-avail-in stream)) (= Z_BUF_ERROR ret))) (let ((n (get-bytevector-n! port input-buffer 0 buffer-size))) (if (eof-object? n) (loop ret #t) (begin (set-stream-next-in! stream (pointer-address (bytevector->pointer input-buffer))) (set-stream-avail-in! stream n) (loop ret flush?)))) (let ((ret (inflate! (pointer stream) (if flush? Z_SYNC_FLUSH 0)))) (set! buffered (- (bytevector-length output-buffer) (stream-avail-out stream))) (cond ((= ret Z_OK) (read! bv start count)) ((= ret Z_STREAM_END) (set! eof? #t) (read! bv start count)) ((and (not flush?) (= Z_BUF_ERROR ret)) (loop ret flush?)) (else (throw 'zlib-error ret (stream-error-message* stream)))))))))) (define result (make-custom-binary-input-port "zlib-input" read! #f #f (lambda () (inflate-end! (pointer stream)) (when close? (close-port port))))) ;; No need for extra buffering. (cond-expand ((or guile-2.2 guile-3.0) (setvbuf result 'none)) (else #t)) ;not possible on 2.0 (inflate-init! (pointer stream) (window-bits-for-format format)) (set-stream-avail-in! stream 0) result) (define* (make-zlib-output-port port #:key (format 'zlib) (buffer-size %default-buffer-size) (level %default-compression-level) (close? #t)) "Return an output port that compresses data at the given LEVEL, using PORT as its sink. FORMAT is a symbol denoting the header format; it must be one of 'deflate (RFC 1950), 'zlib (RFC 1951), or 'gzip (RFC 1952). When FORMAT is 'gzip, the gzip header takes default values, and in particular no modification time and no file name. When CLOSE? is true, PORT is automatically closed when the resulting port is closed." (define output-buffer (make-bytevector buffer-size)) (define stream (make-bytevector (sizeof %stream-struct))) (define pointer (let ((ptr (bytevector->pointer stream))) (lambda (bv) (if (eq? bv stream) ptr (bytevector->pointer bv))))) (define (output-compressed-data! stream) (put-bytevector port output-buffer 0 (- buffer-size (stream-avail-out stream))) (set-stream-avail-out! stream buffer-size) (set-stream-next-out! stream (pointer-address (bytevector->pointer output-buffer)))) (define* (write! bv start count #:optional flush?) (set-stream-next-in! stream (+ start (pointer-address (bytevector->pointer bv)))) (set-stream-avail-in! stream count) (let loop () (if (zero? (stream-avail-out stream)) (begin (output-compressed-data! stream) (loop)) (let ((ret (deflate! (pointer stream) (if flush? Z_FINISH Z_NO_FLUSH)))) (cond ((= ret Z_BUF_ERROR) (loop)) ((= ret Z_OK) (match (- count (stream-avail-in stream)) (0 (loop)) ;zero would mean EOF (n n))) ((and flush? (= ret Z_STREAM_END)) (- count (stream-avail-in stream))) (else (throw 'zlib-error 'deflate! ret (stream-error-message* stream)))))))) (define (flush) (write! #vu8() 0 0 #t) (output-compressed-data! stream)) (define (close) (flush) (deflate-end! (pointer stream)) (when close? (close-port port))) (deflate-init! (pointer stream) level #:window-bits (window-bits-for-format format)) (set-stream-avail-out! stream buffer-size) (set-stream-next-out! stream (pointer-address (bytevector->pointer output-buffer))) (make-custom-binary-output-port "zlib-output" write! #f #f close)) (define* (call-with-zlib-input-port port proc #:key (format 'zlib) (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 zlib internal buffer size is set to BUFFER-SIZE bytes." (let ((zlib (make-zlib-input-port port #:format format #:buffer-size buffer-size #:close? #t))) (dynamic-wind (const #t) (lambda () (proc zlib)) (lambda () (close-port zlib))))) (define* (call-with-zlib-output-port port proc #:key (format 'zlib) (level %default-compression-level) (buffer-size %default-buffer-size)) "Call PROC with an output port that wraps PORT and compresses data in the given FORMAT, with the given LEVEL. PORT is closed upon completion. The zlib internal buffer size is set to BUFFER-SIZE bytes." (let ((zlib (make-zlib-output-port port #:format format #:level level #:buffer-size buffer-size #:close? #t))) (dynamic-wind (const #t) (lambda () (proc zlib)) (lambda () (close-port zlib))))) ;;; zlib.scm ends here guile-zlib/zlib/000077500000000000000000000000001402266441500140655ustar00rootroot00000000000000guile-zlib/zlib/config.scm.in000066400000000000000000000015721402266441500164500ustar00rootroot00000000000000;;; Guile-zlib --- GNU Guile bindings of zlib ;;; Copyright © 2020 Mathieu Othacehe ;;; ;;; This file is part of Guile-zlib. ;;; ;;; Guile-zlib 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. ;;; ;;; Guile-zlib 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 Guile-zlib. If not, see . (define-module (zlib config) #:export (%libz)) (define %libz "@LIBZ_LIBDIR@/libz")