Adding upstream version 3.7.9.upstream/3.7.9upstream

Signed-off-by: Daniel Baumann <daniel.baumann@progress-linux.org>

1 files changed, 93 insertions, 0 deletions

diff --git a/guile/modules/gnutls/build/tests.scm b/guile/modules/gnutls/build/tests.scm
new file mode 100644
index 0000000..7dd7991
--- /dev/null
+++ b/guile/modules/gnutls/build/tests.scm
@@ -0,0 +1,93 @@
+;;; GnuTLS --- Guile bindings for GnuTLS.
+;;; Copyright (C) 2011-2012, 2016, 2021-2022 Free Software Foundation, Inc.
+;;;
+;;; GnuTLS is free software; you can redistribute it and/or
+;;; modify it under the terms of the GNU Lesser General Public
+;;; License as published by the Free Software Foundation; either
+;;; version 2.1 of the License, or (at your option) any later version.
+;;;
+;;; GnuTLS 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
+;;; Lesser General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU Lesser General Public
+;;; License along with GnuTLS; if not, write to the Free Software
+;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA  02110-1301  USA
+
+;;; Written by Ludovic Courtès <ludo@gnu.org>.
+
+(define-module (gnutls build tests)
+  #:export (run-test
+            with-child-process))
+
+(define (run-test thunk)
+  "Call `(exit (THUNK))'.  If THUNK raises an exception, then call `(exit 1)' and
+display a backtrace.  Otherwise, return THUNK's return value."
+  (exit
+   (catch #t
+     thunk
+     (lambda (key . args)
+       ;; Never reached.
+       (exit 1))
+     (lambda (key . args)
+       (dynamic-wind ;; to be on the safe side
+         (lambda () #t)
+         (lambda ()
+           (format (current-error-port)
+                   "~%throw to `~a' with args ~s [PID ~a]~%"
+                   key args (getpid))
+           (display-backtrace (make-stack #t) (current-output-port)))
+         (lambda ()
+           (exit 1)))
+       (exit 1)))))
+
+(define (call-with-child-process child parent)
+  "Run thunk CHILD in a child process and invoke PARENT from the parent
+process, passing it the PID of the child process.  Make sure the child
+process exits upon failure."
+  (let ((pid (primitive-fork)))
+    (if (zero? pid)
+        (dynamic-wind
+          (const #t)
+          (lambda ()
+            (primitive-exit (if (child) 0 1)))
+          (lambda ()
+            (primitive-exit 2)))
+        (parent pid))))
+
+(use-modules (rnrs io ports)
+             (rnrs bytevectors)
+             (ice-9 match))
+
+(define-syntax-rule (define-replacement (name args ...) body ...)
+  ;; Define a compatibility replacement for NAME, if needed.
+  (define-public name
+    (if (module-defined? the-scm-module 'name)
+        (module-ref the-scm-module 'name)
+        (lambda (args ...)
+          body ...))))
+
+;; 'uniform-vector-read!' and 'uniform-vector-write' are deprecated in 2.0
+;; and absent in 2.2.
+;; TODO: Switch to the R6RS bytevector and I/O interface.
+
+(define-replacement (uniform-vector-read! buf port)
+  (match (get-bytevector-n! port buf
+                            0 (bytevector-length buf))
+    ((? eof-object?) 0)
+    ((? integer? n)  n)))
+
+(define-replacement (uniform-vector-write buf port)
+  (put-bytevector port buf))
+
+(define-syntax-rule (with-child-process pid parent child)
+  "Fork and evaluate expression PARENT in the current process, with PID bound
+to the PID of its child process; the child process evaluated CHILD."
+  (call-with-child-process
+   (lambda () child)
+   (lambda (pid) parent)))
+
+;;; Local Variables:
+;;; eval: (put 'define-replacement 'scheme-indent-function 1)
+;;; End: