1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
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:
|
