[gnunet-scheme] 12/324: [guile-zlib] Bind the uncompress function

[gnunet]

This is an automated email from the git hooks/post-receive script.

maxime-devos pushed a commit to branch master
in repository gnunet-scheme.

commit 0c9b61388cbc7987be4d6b806da578bf63a33475
Author: Maxime Devos <maximedevos@telenet.be>
AuthorDate: Sun Nov 8 17:17:02 2020 +0000

    [guile-zlib] Bind the uncompress function
---
 gnu/gnunet/utils/decompress.scm | 142 ++++++++++++++++++++++++++++++++++++++++
 1 file changed, 142 insertions(+)

diff --git a/gnu/gnunet/utils/decompress.scm b/gnu/gnunet/utils/decompress.scm
new file mode 100644
index 0000000..03a4a43
--- /dev/null
+++ b/gnu/gnunet/utils/decompress.scm
@@ -0,0 +1,142 @@
+;;; Zlib bindings, adapted from Guile-zlib
+;;; Copyright © 2016, 2017 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2020 Mathieu Othacehe <othacehe@gnu.org>
+;;; Copyright © 2020 Maxime Devos <maxime.devos@student.kuleuven.be>
+;;;
+;;; 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 <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+;;;
+;;; This file is extracted from Guile-zlib, which was extracted from Guix
+;;; and originally writen 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 bytevector as the source or sink.
+;;;
+;;; Code:
+
+(library (gnu gnunet utils decompress)
+  (export decompress)
+  (import (system foreign)
+         (only (guile) dynamic-link false-if-exception
+               dynamic-func)
+         (only (ice-9 match) match)
+         (only (srfi srfi-45) delay force)
+         (only (zlib config) %libz)
+         (rnrs base)
+         (rnrs control)
+         (rnrs exceptions)
+         (rnrs bytevectors)
+         (rnrs conditions))
+
+  (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-condition-type &z-error &error
+    make-z-error z-error?)
+  (define-condition-type &z-oom-error &z-error
+    make-z-oom-error z-oom-error?)
+  (define-condition-type &z-buf-error &z-error
+    make-z-buf-error z-buf-error?)
+  (define-condition-type &z-data-error &z-error
+    make-z-data-error z-data-error?)
+  (define-condition-type &z-bogus-error &violation
+    make-z-bogus-error z-bogus-error?
+    (value z-bogus-error-value))
+
+  (define Z_OK 0)
+  (define Z_DATA_ERROR -3)
+  (define Z_MEM_ERROR -4)
+  (define Z_BUF_ERROR -5)
+
+  (define uncompress!
+    (let ((proc (zlib-procedure int "uncompress" `(* * * ,unsigned-long))))
+      (lambda (dest-bv dest-offset dest-length
+                      source-bv source-offset source-length)
+       "Uncompress the source buffer into the destination buffer.
+
+Return the actual buffer size on success, raise an appropriate
+&z-error otherwise.
+
+&z-oom-error: out of memory
+&z-data-error: corrupted or incomplete data
+&z-buf-error: output buffer too small
+
+@var{dest-bv}: destination buffer, as a bytevector
+@var{dest-offset}: position of the first byte in @var{dest-bv}
+@var{dest-length}: size of @var{dest-bv}. Possibly more than
+strictly required."
+       ;; Verify bounds
+       (assert (and (exact? dest-offset)
+                    (integer? dest-offset)))
+       (assert (and (exact? dest-length)
+                    (integer? dest-length)))
+       (assert (and (exact? source-offset)
+                    (integer? source-offset)))
+       (assert (and (exact? source-length)
+                    (integer? source-length)))
+       (assert (and (<= 0 dest-offset)
+                    (<= dest-offset (bytevector-length dest-bv))))
+       (assert (and (<= 0 source-offset)
+                    (<= source-offset (bytevector-length source-bv))))
+       (assert (and (<= (+ source-offset source-length)
+                        (bytevector-length source-bv))))
+       (assert (and (<= (+ dest-offset dest-length)
+                        (bytevector-length dest-bv))))
+       (let* ((dest-len-buf
+               (make-c-struct `(,unsigned-long) `(,dest-length)))
+              (ret (proc (bytevector->pointer dest-bv dest-offset)
+                         dest-len-buf
+                         (bytevector->pointer source-bv source-offset)
+                         source-length)))
+         (cond ((= ret Z_OK)
+                (list-ref (parse-c-struct dest-len-buf `(,unsigned-long))
+                          0))
+               ((= ret Z_MEM_ERROR) (raise (make-z-oom-error)))
+               ((= ret Z_BUF_ERROR) (raise (make-z-buf-error)))
+               ((= ret Z_DATA_ERROR) (raise (make-z-data-error)))
+               (else (raise
+                      (condition
+                       (make-z-bogus-error ret)
+                       (make-message-condition "bogus zlib error value")
+                       (make-who-condition 'uncompress!)))))))))
+
+  (define decompress
+    (case-lambda
+      "Uncompress a bytevector with deflate"
+      ((input-size output-size input-bv)
+       (decompress input-size output-size input-bv 0))
+      ((input-size output-size input-bv input-offset)
+       "Decompress a source buffer
+
+Return the decompressed buffer as a fresh bytevector.
+In case the input is invalid, return #f"
+       (guard (ex ((z-buf-error? ex) #f)
+                 ((z-data-error? ex) #f))
+        (let* ((bv (make-bytevector output-size))
+               (bv-used (uncompress! bv 0 output-size input-bv input-offset
+                                     input-size)))
+          (and (= bv-used output-size)
+               bv)))))))
+

-- 
To stop receiving notification emails like this one, please contact
gnunet@gnunet.org.