guile: tests: Add 'with-child-process'.

This makes sure that child processes always exit no matter what.

* guile/modules/gnutls/build/tests.scm (define-syntax-rule) [!guile-2]:
New macro.
(call-with-child-process): New procedure.
(with-child-process): New macro.
* guile/tests/anonymous-auth.scm, guile/tests/openpgp-auth.scm,
guile/tests/session-record-port.scm, guile/tests/x509-auth.scm: Use it
instead of an explicit 'primitive-fork' call.
* guile/.dir-locals.el: New file.
* guile/Makefile.am (EXTRA_DIST): New variable.

7 files changed, 255 insertions, 210 deletions

diff --git a/guile/.dir-locals.el b/guile/.dir-locals.el
new file mode 100644
index 0000000000..54091ccaa5
--- /dev/null
+++ b/guile/.dir-locals.el
@@ -0,0 +1,12 @@
+;; Per-directory local variables for GNU Emacs 23 and later.
+
+((nil
+  . ((fill-column . 78)
+     (tab-width   .  8)))
+ (c-mode . ((c-file-style . "gnu")))
+ (scheme-mode
+  .
+  ((indent-tabs-mode . nil)
+   (eval . (put 'with-child-process 'scheme-indent-function 1))))
+ (texinfo-mode . ((indent-tabs-mode . nil)
+		  (fill-column . 72))))
diff --git a/guile/Makefile.am b/guile/Makefile.am
index a981ed5c21..ed9b8ba1d7 100644
--- a/guile/Makefile.am
+++ b/guile/Makefile.am
@@ -1,5 +1,5 @@
 #  GnuTLS --- Guile bindings for GnuTLS.
-#  Copyright (C) 2007-2012 Free Software Foundation, Inc.
+#  Copyright (C) 2007-2012, 2016 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
@@ -16,3 +16,5 @@
 #  Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA  02110-1301  USA
 
 SUBDIRS = modules src tests
+
+EXTRA_DIST = .dir-locals.el
diff --git a/guile/modules/gnutls/build/tests.scm b/guile/modules/gnutls/build/tests.scm
index f5e135b4f2..5a03ce7474 100644
--- a/guile/modules/gnutls/build/tests.scm
+++ b/guile/modules/gnutls/build/tests.scm
@@ -1,5 +1,5 @@
 ;;; GnuTLS --- Guile bindings for GnuTLS.
-;;; Copyright (C) 2011-2012 Free Software Foundation, Inc.
+;;; Copyright (C) 2011-2012, 2016 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
@@ -18,7 +18,8 @@
 ;;; Written by Ludovic Courtès <ludo@gnu.org>.
 
 (define-module (gnutls build tests)
-  #:export (run-test))
+  #:export (run-test
+            with-child-process))
 
 (define (run-test thunk)
   "Call `(exit (THUNK))'.  If THUNK raises an exception, then call `(exit 1)' and
@@ -39,3 +40,39 @@ display a backtrace.  Otherwise, return THUNK's return value."
          (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))))
+
+(cond-expand
+  ((not guile-2)                                  ;1.8, yay!
+   (use-modules (ice-9 syncase))
+
+   (define-syntax define-syntax-rule
+     (syntax-rules ()
+       ((_ (name args ...) docstring body)
+        (define-syntax name
+          (syntax-rules ()
+            ((_ args ...) body))))))
+
+   (export define-syntax-rule))
+  (else
+   #t))
+
+(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)))
diff --git a/guile/tests/anonymous-auth.scm b/guile/tests/anonymous-auth.scm
index 585b3a5cca..d01884d749 100644
--- a/guile/tests/anonymous-auth.scm
+++ b/guile/tests/anonymous-auth.scm
@@ -1,5 +1,5 @@
 ;;; GnuTLS --- Guile bindings for GnuTLS.
-;;; Copyright (C) 2007-2013 Free Software Foundation, Inc.
+;;; Copyright (C) 2007-2013, 2016 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
@@ -52,43 +52,41 @@
 ;;                       (format #t "[~a|~a] ~a" (getpid) level str)))
 
 (run-test
-    (lambda ()
-      (let ((socket-pair (socketpair PF_UNIX SOCK_STREAM 0))
-            (pid         (primitive-fork)))
-        (if (= 0 pid)
-
-            (let ((client (make-session connection-end/client)))
-              ;; client-side (child process)
-              (set-session-priorities! client priorities)
-              (set-session-server-name! client
-                                        server-name-type/dns (gethostname))
-              (set-session-transport-fd! client (port->fdes (car socket-pair)))
-              (set-session-credentials! client (make-anonymous-client-credentials))
-              (set-session-dh-prime-bits! client 1024)
-
-              (handshake client)
-              (record-send client %message)
-              (bye client close-request/rdwr)
-
-              (primitive-exit))
-
-            (let ((server (make-session connection-end/server)))
-              ;; server-side
-              (set-session-priorities! server priorities)
-
-              (set-session-transport-fd! server (port->fdes (cdr socket-pair)))
-              (let ((cred (make-anonymous-server-credentials))
-                    (dh-params (import-dh-params "dh-parameters.pem")))
-                ;; Note: DH parameter generation can take some time.
-                (set-anonymous-server-dh-parameters! cred dh-params)
-                (set-session-credentials! server cred))
-              (set-session-dh-prime-bits! server 1024)
-
-              (handshake server)
-              (let* ((buf (make-u8vector (u8vector-length %message)))
-                     (amount (record-receive! server buf)))
-                (bye server close-request/rdwr)
-                (and (= amount (u8vector-length %message))
-                     (equal? buf %message))))))))
+ (lambda ()
+   (let ((socket-pair (socketpair PF_UNIX SOCK_STREAM 0)))
+     (with-child-process pid
+       ;; server-side
+       (let ((server (make-session connection-end/server)))
+         (set-session-priorities! server priorities)
+
+         (set-session-transport-fd! server (port->fdes (cdr socket-pair)))
+         (let ((cred (make-anonymous-server-credentials))
+               (dh-params (import-dh-params "dh-parameters.pem")))
+           ;; Note: DH parameter generation can take some time.
+           (set-anonymous-server-dh-parameters! cred dh-params)
+           (set-session-credentials! server cred))
+         (set-session-dh-prime-bits! server 1024)
+
+         (handshake server)
+         (let* ((buf (make-u8vector (u8vector-length %message)))
+                (amount (record-receive! server buf)))
+           (bye server close-request/rdwr)
+           (and (= amount (u8vector-length %message))
+                (equal? buf %message))))
+
+       ;; client-side (child process)
+       (let ((client (make-session connection-end/client)))
+         (set-session-priorities! client priorities)
+         (set-session-server-name! client
+                                   server-name-type/dns (gethostname))
+         (set-session-transport-fd! client (port->fdes (car socket-pair)))
+         (set-session-credentials! client (make-anonymous-client-credentials))
+         (set-session-dh-prime-bits! client 1024)
+
+         (handshake client)
+         (record-send client %message)
+         (bye client close-request/rdwr)
+
+         (primitive-exit))))))
 
 ;;; arch-tag: 8c98de24-0a53-4290-974e-4b071ad162a0
diff --git a/guile/tests/openpgp-auth.scm b/guile/tests/openpgp-auth.scm
index a60f8856ae..49b4817435 100644
--- a/guile/tests/openpgp-auth.scm
+++ b/guile/tests/openpgp-auth.scm
@@ -1,5 +1,5 @@
 ;;; GnuTLS-extra --- Guile bindings for GnuTLS-EXTRA.
-;;; Copyright (C) 2007-2014 Free Software Foundation, Inc.
+;;; Copyright (C) 2007-2014, 2016 Free Software Foundation, Inc.
 ;;;
 ;;; GnuTLS-extra is free software; you can redistribute it and/or modify
 ;;; it under the terms of the GNU General Public License as published by
@@ -56,51 +56,49 @@
 ;;                       (format #t "[~a|~a] ~a" (getpid) level str)))
 
 (run-test
-    (lambda ()
-      (let ((socket-pair (socketpair PF_UNIX SOCK_STREAM 0))
-            (pub         (import-key import-openpgp-certificate
-                                     "openpgp-pub.asc"))
-            (sec         (import-key import-openpgp-private-key
-                                     "openpgp-sec.asc")))
-        (let ((pid (primitive-fork)))
-          (if (= 0 pid)
-
-              (let ((client (make-session connection-end/client))
-                    (cred   (make-certificate-credentials)))
-                ;; client-side (child process)
-                (set-session-priorities! client priorities)
-
-                (set-certificate-credentials-openpgp-keys! cred pub sec)
-                (set-session-credentials! client cred)
-                (set-session-dh-prime-bits! client 1024)
-
-                (set-session-transport-fd! client (port->fdes (car socket-pair)))
-
-                (handshake client)
-                (write %message (session-record-port client))
-                (bye client close-request/rdwr)
-
-                (primitive-exit))
-
-              (let ((server (make-session connection-end/server))
-                    (dh     (import-dh-params "dh-parameters.pem")))
-                ;; server-side
-                (set-session-priorities! server priorities)
-                (set-server-session-certificate-request! server
-                         certificate-request/require)
-
-                (set-session-transport-fd! server (port->fdes (cdr socket-pair)))
-                (let ((cred (make-certificate-credentials)))
-                  (set-certificate-credentials-dh-parameters! cred dh)
-                  (set-certificate-credentials-openpgp-keys! cred pub sec)
-                  (set-session-credentials! server cred))
-                (set-session-dh-prime-bits! server 1024)
-
-                (handshake server)
-                (let ((msg (read (session-record-port server)))
-                      (auth-type (session-authentication-type server)))
-                  (bye server close-request/rdwr)
-                  (and (eq? auth-type credentials/certificate)
-                       (equal? msg %message)))))))))
+ (lambda ()
+   (let ((socket-pair (socketpair PF_UNIX SOCK_STREAM 0))
+         (pub         (import-key import-openpgp-certificate
+                                  "openpgp-pub.asc"))
+         (sec         (import-key import-openpgp-private-key
+                                  "openpgp-sec.asc")))
+     (with-child-process pid
+       ;; server-side
+       (let ((server (make-session connection-end/server))
+             (dh     (import-dh-params "dh-parameters.pem")))
+         (set-session-priorities! server priorities)
+         (set-server-session-certificate-request! server
+                                                  certificate-request/require)
+
+         (set-session-transport-fd! server (port->fdes (cdr socket-pair)))
+         (let ((cred (make-certificate-credentials)))
+           (set-certificate-credentials-dh-parameters! cred dh)
+           (set-certificate-credentials-openpgp-keys! cred pub sec)
+           (set-session-credentials! server cred))
+         (set-session-dh-prime-bits! server 1024)
+
+         (handshake server)
+         (let ((msg (read (session-record-port server)))
+               (auth-type (session-authentication-type server)))
+           (bye server close-request/rdwr)
+           (and (eq? auth-type credentials/certificate)
+                (equal? msg %message))))
+
+       ;; client-side (child process)
+       (let ((client (make-session connection-end/client))
+             (cred   (make-certificate-credentials)))
+         (set-session-priorities! client priorities)
+
+         (set-certificate-credentials-openpgp-keys! cred pub sec)
+         (set-session-credentials! client cred)
+         (set-session-dh-prime-bits! client 1024)
+
+         (set-session-transport-fd! client (port->fdes (car socket-pair)))
+
+         (handshake client)
+         (write %message (session-record-port client))
+         (bye client close-request/rdwr)
+
+         (primitive-exit))))))
 
 ;;; arch-tag: 1a973ed5-f45d-45a4-8160-900b6a8c27ff
diff --git a/guile/tests/session-record-port.scm b/guile/tests/session-record-port.scm
index bb3f25f844..8291880e27 100644
--- a/guile/tests/session-record-port.scm
+++ b/guile/tests/session-record-port.scm
@@ -1,5 +1,5 @@
 ;;; GnuTLS --- Guile bindings for GnuTLS.
-;;; Copyright (C) 2007-2012, 2014 Free Software Foundation, Inc.
+;;; Copyright (C) 2007-2012, 2014, 2016 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
@@ -51,73 +51,72 @@
 ;;                       (format #t "[~a|~a] ~a" (getpid) level str)))
 
 (run-test
-    (lambda ()
-      ;; Stress the GC.  In 0.0, this triggered an abort due to
-      ;; "scm_unprotect_object called during GC".
-      (let ((sessions (map (lambda (i)
-                             (make-session connection-end/server))
-                           (iota 123))))
-        (for-each session-record-port sessions)
-        (gc)(gc)(gc))
-
-      ;; Stress the GC.  The session associated to each port in PORTS should
-      ;; remain reachable.
-      (let ((ports (map session-record-port
-                        (map (lambda (i)
-                               (make-session connection-end/server))
-                             (iota 123)))))
-        (gc)(gc)(gc)
-        (for-each (lambda (p)
-                    (catch 'gnutls-error
-                      (lambda ()
-                        (read p))
-                      (lambda (key . args)
-                        #t)))
-                  ports))
-
-      ;; Try using the record port for I/O.
-      (let ((socket-pair (socketpair PF_UNIX SOCK_STREAM 0))
-            (pid         (primitive-fork)))
-        (if (= 0 pid)
-
-            (let ((client (make-session connection-end/client)))
-              ;; client-side (child process)
-              (set-session-priorities! client priorities)
-
-              (set-session-transport-port! client (car socket-pair))
-              (set-session-credentials! client (make-anonymous-client-credentials))
-              (set-session-dh-prime-bits! client 1024)
-
-              (handshake client)
-              (uniform-vector-write %message (session-record-port client))
-              (bye client close-request/rdwr)
-
-              (primitive-exit))
-
-            (let ((server (make-session connection-end/server)))
-              ;; server-side
-              (set-session-priorities! server priorities)
-
-              (set-session-transport-port! server (cdr socket-pair))
-              (let ((cred (make-anonymous-server-credentials))
-                    (dh-params (import-dh-params "dh-parameters.pem")))
-                ;; Note: DH parameter generation can take some time.
-                (set-anonymous-server-dh-parameters! cred dh-params)
-                (set-session-credentials! server cred))
-              (set-session-dh-prime-bits! server 1024)
-
-              (handshake server)
-              (let* ((buf (make-u8vector (u8vector-length %message)))
-                     (amount
-                      (uniform-vector-read! buf (session-record-port server))))
-                (bye server close-request/rdwr)
-
-                ;; Make sure we got everything right.
-                (and (eq? (session-record-port server)
-                          (session-record-port server))
-                     (= amount (u8vector-length %message))
-                     (equal? buf %message)
-                     (eof-object?
-                      (read-char (session-record-port server))))))))))
+ (lambda ()
+   ;; Stress the GC.  In 0.0, this triggered an abort due to
+   ;; "scm_unprotect_object called during GC".
+   (let ((sessions (map (lambda (i)
+                          (make-session connection-end/server))
+                        (iota 123))))
+     (for-each session-record-port sessions)
+     (gc)(gc)(gc))
+
+   ;; Stress the GC.  The session associated to each port in PORTS should
+   ;; remain reachable.
+   (let ((ports (map session-record-port
+                     (map (lambda (i)
+                            (make-session connection-end/server))
+                          (iota 123)))))
+     (gc)(gc)(gc)
+     (for-each (lambda (p)
+                 (catch 'gnutls-error
+                   (lambda ()
+                     (read p))
+                   (lambda (key . args)
+                     #t)))
+               ports))
+
+   ;; Try using the record port for I/O.
+   (let ((socket-pair (socketpair PF_UNIX SOCK_STREAM 0)))
+     (with-child-process pid
+
+       ;; server-side
+       (let ((server (make-session connection-end/server)))
+         (set-session-priorities! server priorities)
+
+         (set-session-transport-port! server (cdr socket-pair))
+         (let ((cred (make-anonymous-server-credentials))
+               (dh-params (import-dh-params "dh-parameters.pem")))
+           ;; Note: DH parameter generation can take some time.
+           (set-anonymous-server-dh-parameters! cred dh-params)
+           (set-session-credentials! server cred))
+         (set-session-dh-prime-bits! server 1024)
+
+         (handshake server)
+         (let* ((buf (make-u8vector (u8vector-length %message)))
+                (amount
+                 (uniform-vector-read! buf (session-record-port server))))
+           (bye server close-request/rdwr)
+
+           ;; Make sure we got everything right.
+           (and (eq? (session-record-port server)
+                     (session-record-port server))
+                (= amount (u8vector-length %message))
+                (equal? buf %message)
+                (eof-object?
+                 (read-char (session-record-port server))))))
+
+       ;; client-side (child process)
+       (let ((client (make-session connection-end/client)))
+         (set-session-priorities! client priorities)
+
+         (set-session-transport-port! client (car socket-pair))
+         (set-session-credentials! client (make-anonymous-client-credentials))
+         (set-session-dh-prime-bits! client 1024)
+
+         (handshake client)
+         (uniform-vector-write %message (session-record-port client))
+         (bye client close-request/rdwr)
+
+         (primitive-exit))))))
 
 ;;; arch-tag: e873226a-d0b6-4a93-87ec-a1b5ad2ae8a2
diff --git a/guile/tests/x509-auth.scm b/guile/tests/x509-auth.scm
index 71c8d1500a..609251d473 100644
--- a/guile/tests/x509-auth.scm
+++ b/guile/tests/x509-auth.scm
@@ -1,5 +1,5 @@
 ;;; GnuTLS --- Guile bindings for GnuTLS.
-;;; Copyright (C) 2007-2014 Free Software Foundation, Inc.
+;;; Copyright (C) 2007-2014, 2016 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
@@ -55,56 +55,55 @@
 ;;                       (format #t "[~a|~a] ~a" (getpid) level str)))
 
 (run-test
-    (lambda ()
-      (let ((socket-pair (socketpair PF_UNIX SOCK_STREAM 0))
-            (pub         (import-key import-x509-certificate
-                                     "x509-certificate.pem"))
-            (sec         (import-key import-x509-private-key
-                                     "x509-key.pem")))
-        (let ((pid (primitive-fork)))
-          (if (= 0 pid)
-
-              (let ((client (make-session connection-end/client))
-                    (cred   (make-certificate-credentials)))
-                ;; client-side (child process)
-                (set-session-priorities! client priorities)
-                (set-certificate-credentials-x509-keys! cred (list pub) sec)
-                (set-session-credentials! client cred)
-                (set-session-dh-prime-bits! client 1024)
-
-                (set-session-transport-fd! client (port->fdes (car socket-pair)))
-
-                (handshake client)
-                (write %message (session-record-port client))
-                (bye client close-request/rdwr)
-
-                (primitive-exit))
-
-              (let ((server (make-session connection-end/server))
-                    (dh     (import-dh-params "dh-parameters.pem")))
-                ;; server-side
-                (set-session-priorities! server priorities)
-                (set-server-session-certificate-request! server
-                         certificate-request/require)
-
-                (set-session-transport-fd! server (port->fdes (cdr socket-pair)))
-                (let ((cred (make-certificate-credentials))
-                      (trust-file (search-path %load-path
-                                               "x509-certificate.pem"))
-                      (trust-fmt  x509-certificate-format/pem))
-                  (set-certificate-credentials-dh-parameters! cred dh)
-                  (set-certificate-credentials-x509-keys! cred (list pub) sec)
-                  (set-certificate-credentials-x509-trust-file! cred
-                                                                trust-file
-                                                                trust-fmt)
-                  (set-session-credentials! server cred))
-                (set-session-dh-prime-bits! server 1024)
-
-                (handshake server)
-                (let ((msg (read (session-record-port server)))
-                      (auth-type (session-authentication-type server)))
-                  (bye server close-request/rdwr)
-                  (and (eq? auth-type credentials/certificate)
-                       (equal? msg %message)))))))))
+ (lambda ()
+   (let ((socket-pair (socketpair PF_UNIX SOCK_STREAM 0))
+         (pub         (import-key import-x509-certificate
+                                  "x509-certificate.pem"))
+         (sec         (import-key import-x509-private-key
+                                  "x509-key.pem")))
+     (with-child-process pid
+
+       ;; server-side
+       (let ((server (make-session connection-end/server))
+             (dh     (import-dh-params "dh-parameters.pem")))
+         (set-session-priorities! server priorities)
+         (set-server-session-certificate-request! server
+                                                  certificate-request/require)
+
+         (set-session-transport-fd! server (port->fdes (cdr socket-pair)))
+         (let ((cred (make-certificate-credentials))
+               (trust-file (search-path %load-path
+                                        "x509-certificate.pem"))
+               (trust-fmt  x509-certificate-format/pem))
+           (set-certificate-credentials-dh-parameters! cred dh)
+           (set-certificate-credentials-x509-keys! cred (list pub) sec)
+           (set-certificate-credentials-x509-trust-file! cred
+                                                         trust-file
+                                                         trust-fmt)
+           (set-session-credentials! server cred))
+         (set-session-dh-prime-bits! server 1024)
+
+         (handshake server)
+         (let ((msg (read (session-record-port server)))
+               (auth-type (session-authentication-type server)))
+           (bye server close-request/rdwr)
+           (and (eq? auth-type credentials/certificate)
+                (equal? msg %message))))
+
+       ;; client-side (child process)
+       (let ((client (make-session connection-end/client))
+             (cred   (make-certificate-credentials)))
+         (set-session-priorities! client priorities)
+         (set-certificate-credentials-x509-keys! cred (list pub) sec)
+         (set-session-credentials! client cred)
+         (set-session-dh-prime-bits! client 1024)
+
+         (set-session-transport-fd! client (port->fdes (car socket-pair)))
+
+         (handshake client)
+         (write %message (session-record-port client))
+         (bye client close-request/rdwr)
+
+         (primitive-exit))))))
 
 ;;; arch-tag: 1f88f835-a5c8-4fd6-94b6-5a13571ba03d