summaryrefslogtreecommitdiffstats
path: root/tests
diff options
context:
space:
mode:
Diffstat (limited to 'tests')
-rw-r--r--tests/gpgscm/ffi.c514
-rw-r--r--tests/gpgscm/scheme.c4
-rw-r--r--tests/gpgscm/t-child.scm39
-rw-r--r--tests/gpgscm/tests.scm93
-rw-r--r--tests/openpgp/defs.scm7
-rw-r--r--tests/tpm2dtests/defs.scm7
6 files changed, 464 insertions, 200 deletions
diff --git a/tests/gpgscm/ffi.c b/tests/gpgscm/ffi.c
index ce18e0794..cac052138 100644
--- a/tests/gpgscm/ffi.c
+++ b/tests/gpgscm/ffi.c
@@ -42,6 +42,9 @@
#endif
#include "../../common/util.h"
+#ifdef HAVE_W32_SYSTEM
+#define NEED_STRUCT_SPAWN_CB_ARG
+#endif
#include "../../common/exechelp.h"
#include "../../common/sysutils.h"
@@ -644,6 +647,7 @@ static struct foreign_object_vtable es_object_vtable =
es_object_to_string,
};
+#if 0
static pointer
es_wrap (scheme *sc, estream_t stream)
{
@@ -655,6 +659,7 @@ es_wrap (scheme *sc, estream_t stream)
box->closed = 0;
return sc->vptr->mk_foreign_object (sc, &es_object_vtable, box);
}
+#endif
static struct es_object_box *
es_unwrap (scheme *sc, pointer object)
@@ -753,25 +758,166 @@ do_es_write (scheme *sc, pointer args)
}
-
/* Process handling. */
+struct proc_object_box
+{
+ gnupg_process_t proc;
+};
+
+static void
+proc_object_finalize (scheme *sc, void *data)
+{
+ struct proc_object_box *box = data;
+ (void) sc;
+
+ if (!box->proc)
+ gnupg_process_release (box->proc);
+ xfree (box);
+}
+
+static void
+proc_object_to_string (scheme *sc, char *out, size_t size, void *data)
+{
+ struct proc_object_box *box = data;
+ (void) sc;
+
+ snprintf (out, size, "#proc %p", box->proc);
+}
+
+static struct foreign_object_vtable proc_object_vtable =
+ {
+ proc_object_finalize,
+ proc_object_to_string,
+ };
+
static pointer
-do_spawn_process (scheme *sc, pointer args)
+proc_wrap (scheme *sc, gnupg_process_t proc)
+{
+ struct proc_object_box *box = xmalloc (sizeof *box);
+ if (box == NULL)
+ return sc->NIL;
+
+ box->proc = proc;
+ return sc->vptr->mk_foreign_object (sc, &proc_object_vtable, box);
+}
+
+static struct proc_object_box *
+proc_unwrap (scheme *sc, pointer object)
+{
+ (void) sc;
+
+ if (! is_foreign_object (object))
+ return NULL;
+
+ if (sc->vptr->get_foreign_object_vtable (object) != &proc_object_vtable)
+ return NULL;
+
+ return sc->vptr->get_foreign_object_data (object);
+}
+
+#define CONVERSION_proc(SC, X) proc_unwrap (SC, X)
+#define IS_A_proc(SC, X) proc_unwrap (SC, X)
+
+
+#define SPAWN_IO_BUFSIZE 4096
+
+#ifdef HAVE_W32_SYSTEM
+struct rfp {
+ HANDLE hd;
+ char *buf;
+ size_t len;
+ off_t off;
+};
+
+static DWORD __attribute__((stdcall))
+read_from_pipe (void *arg)
+{
+ struct rfp *rfp = arg;
+ DWORD bytes_read;
+
+ if (rfp->hd == INVALID_HANDLE_VALUE)
+ goto errout;
+
+ while (1)
+ {
+ if (!ReadFile (rfp->hd, rfp->buf + rfp->off, rfp->len - rfp->off,
+ &bytes_read, NULL))
+ {
+ DWORD ec = GetLastError ();
+
+ if (ec == ERROR_BROKEN_PIPE)
+ {
+ CloseHandle (rfp->hd);
+ rfp->hd = INVALID_HANDLE_VALUE;
+ break;
+ }
+
+ goto errout;
+ }
+
+ if (bytes_read == 0)
+ /* It may occur, when it writes WriteFile with zero-byte on
+ the other end of the pipe. */
+ continue;
+ else
+ {
+ rfp->off += bytes_read;
+ if (rfp->off == rfp->len)
+ {
+ rfp->len += SPAWN_IO_BUFSIZE;
+ rfp->buf = xtryrealloc (rfp->buf, rfp->len);
+ if (rfp->buf == NULL)
+ goto errout;
+ }
+ }
+ }
+
+ return 0;
+
+ errout:
+ if (rfp->hd != INVALID_HANDLE_VALUE)
+ {
+ CloseHandle (rfp->hd);
+ rfp->hd = INVALID_HANDLE_VALUE;
+ }
+ xfree (rfp->buf);
+ rfp->buf = NULL;
+ return 1;
+}
+#endif
+
+
+static pointer
+do_process_spawn_io (scheme *sc, pointer args)
{
FFI_PROLOG ();
pointer arguments;
+ char *a_input;
char **argv;
size_t len;
unsigned int flags;
-
+ gnupg_process_t proc = NULL;
estream_t infp;
- estream_t outfp;
- estream_t errfp;
- pid_t pid;
+#ifdef HAVE_W32_SYSTEM
+ HANDLE out_hd, err_hd;
+#else
+ int out_fd, err_fd;
+#endif
+ char *out_string = NULL;
+ char *err_string = NULL;
+ size_t out_len = SPAWN_IO_BUFSIZE;
+ size_t err_len = SPAWN_IO_BUFSIZE;
+ off_t out_off = 0;
+ off_t err_off = 0;
+ int retcode = -1;
+ pointer p0, p1, p2;
FFI_ARG_OR_RETURN (sc, pointer, arguments, list, args);
- FFI_ARG_OR_RETURN (sc, unsigned int, flags, number, args);
+ FFI_ARG_OR_RETURN (sc, char *, a_input, string, args);
+ flags = (GNUPG_PROCESS_STDIN_PIPE
+ | GNUPG_PROCESS_STDOUT_PIPE
+ | GNUPG_PROCESS_STDERR_PIPE);
FFI_ARGS_DONE_OR_RETURN (sc, args);
err = ffi_list2argv (sc, arguments, &argv, &len);
@@ -791,38 +937,245 @@ do_spawn_process (scheme *sc, pointer args)
fprintf (stderr, "\n");
}
- err = gnupg_spawn_process (argv[0], (const char **) &argv[1],
- NULL,
- flags,
- &infp, &outfp, &errfp, &pid);
+ err = gnupg_process_spawn (argv[0], (const char **) &argv[1],
+ flags, NULL, NULL, &proc);
+ err = gnupg_process_get_streams (proc, 0, &infp, NULL, NULL);
+
+ err = es_write (infp, a_input, strlen (a_input), NULL);
+ es_fclose (infp);
+ if (err)
+ {
+ gnupg_process_release (proc);
+ xfree (argv);
+ FFI_RETURN_ERR (sc, err);
+ }
+
+#ifdef HAVE_W32_SYSTEM
+ err = gnupg_process_ctl (proc, GNUPG_PROCESS_GET_HANDLES,
+ NULL, &out_hd, &err_hd);
+#else
+ err = gnupg_process_get_fds (proc, 0, NULL, &out_fd, &err_fd);
+#endif
+ if (err)
+ {
+ gnupg_process_release (proc);
+ xfree (argv);
+ FFI_RETURN_ERR (sc, err);
+ }
+
+ out_string = xtrymalloc (out_len);
+ if (out_string == NULL)
+ goto errout;
+
+ err_string = xtrymalloc (err_len);
+ if (err_string == NULL)
+ goto errout;
+
+#ifdef HAVE_W32_SYSTEM
+ {
+ HANDLE h_thread_rfp_err;
+ struct rfp rfp_out;
+ struct rfp rfp_err;
+ DWORD thread_exit_code;
+
+ rfp_err.hd = err_hd;
+ rfp_err.buf = err_string;
+ rfp_err.len = err_len;
+ rfp_err.off = 0;
+ err_hd = INVALID_HANDLE_VALUE;
+ err_string = NULL;
+
+ h_thread_rfp_err = CreateThread (NULL, 0, read_from_pipe, (void *)&rfp_err,
+ 0, NULL);
+ if (h_thread_rfp_err == NULL)
+ {
+ xfree (rfp_err.buf);
+ CloseHandle (rfp_err.hd);
+ goto errout;
+ }
+
+ rfp_out.hd = out_hd;
+ rfp_out.buf = out_string;
+ rfp_out.len = out_len;
+ rfp_out.off = 0;
+ out_hd = INVALID_HANDLE_VALUE;
+ out_string = NULL;
+
+ if (read_from_pipe (&rfp_out))
+ {
+ CloseHandle (h_thread_rfp_err);
+ xfree (rfp_err.buf);
+ goto errout;
+ }
+
+ out_string = rfp_out.buf;
+ out_off = rfp_out.off;
+
+ WaitForSingleObject (h_thread_rfp_err, INFINITE);
+ GetExitCodeThread (h_thread_rfp_err, &thread_exit_code);
+ CloseHandle (h_thread_rfp_err);
+ if (thread_exit_code)
+ goto errout;
+
+ err_string = rfp_err.buf;
+ err_off = rfp_err.off;
+ }
+#else
+ {
+ fd_set read_fdset;
+ ssize_t bytes_read;
+
+ if (out_fd < 0)
+ goto errout;
+
+ if (err_fd < 0)
+ goto errout;
+
+ FD_ZERO (&read_fdset);
+
+ while (1)
+ {
+ int nfd;
+ int ret;
+
+ if (out_fd >= 0)
+ FD_SET (out_fd, &read_fdset);
+
+ if (err_fd >= 0)
+ FD_SET (err_fd, &read_fdset);
+
+ if (out_fd > err_fd)
+ nfd = out_fd;
+ else
+ nfd = err_fd;
+
+ if (nfd == -1)
+ break;
+
+ ret = select (nfd+1, &read_fdset, NULL, NULL, NULL);
+ if (ret < 0)
+ break;
+
+ if (FD_ISSET (out_fd, &read_fdset))
+ {
+ bytes_read = read (out_fd, out_string + out_off,
+ out_len - out_off);
+ if (bytes_read == 0)
+ {
+ close (out_fd);
+ out_fd = -1;
+ }
+ else if (bytes_read < 0)
+ goto errout;
+ else
+ {
+ out_off += bytes_read;
+ if (out_off == out_len)
+ {
+ out_len += SPAWN_IO_BUFSIZE;
+ out_string = xtryrealloc (out_string, out_len);
+ if (out_string == NULL)
+ goto errout;
+ }
+ }
+ }
+
+ if (FD_ISSET (err_fd, &read_fdset))
+ {
+ bytes_read = read (err_fd, err_string + err_off,
+ err_len - err_off);
+ if (bytes_read == 0)
+ {
+ close (err_fd);
+ err_fd = -1;
+ }
+ else if (bytes_read < 0)
+ goto errout;
+ else
+ {
+ err_off += bytes_read;
+ if (err_off == err_len)
+ {
+ err_len += SPAWN_IO_BUFSIZE;
+ err_string = xtryrealloc (err_string, err_len);
+ if (err_string == NULL)
+ goto errout;
+ }
+ }
+ }
+ }
+ }
+#endif
+
+ err = gnupg_process_wait (proc, 1);
+ if (!err)
+ err = gnupg_process_ctl (proc, GNUPG_PROCESS_GET_EXIT_ID, &retcode);
+
+ gnupg_process_release (proc);
xfree (argv);
-#define IMC(A, B) \
- _cons (sc, sc->vptr->mk_integer (sc, (unsigned long) (A)), (B), 1)
-#define IMS(A, B) \
- _cons (sc, es_wrap (sc, (A)), (B), 1)
- FFI_RETURN_POINTER (sc, IMS (infp,
- IMS (outfp,
- IMS (errfp,
- IMC (pid, sc->NIL)))));
-#undef IMS
-#undef IMC
+
+ p0 = sc->vptr->mk_integer (sc, (unsigned long)retcode);
+ p1 = sc->vptr->mk_counted_string (sc, out_string, out_off);
+ p2 = sc->vptr->mk_counted_string (sc, err_string, err_off);
+
+ xfree (out_string);
+ xfree (err_string);
+
+ FFI_RETURN_POINTER (sc, _cons (sc, p0,
+ _cons (sc, p1,
+ _cons (sc, p2, sc->NIL, 1), 1), 1));
+ errout:
+ xfree (out_string);
+ xfree (err_string);
+#ifdef HAVE_W32_SYSTEM
+ if (out_hd != INVALID_HANDLE_VALUE)
+ CloseHandle (out_hd);
+ if (err_hd != INVALID_HANDLE_VALUE)
+ CloseHandle (err_hd);
+#else
+ if (out_fd >= 0)
+ close (out_fd);
+ if (err_fd >= 0)
+ close (err_fd);
+#endif
+ gnupg_process_release (proc);
+ xfree (argv);
+ FFI_RETURN_ERR (sc, err);
+}
+
+static void
+setup_std_fds (struct spawn_cb_arg *sca)
+{
+ int *std_fds = sca->arg;
+
+#ifdef HAVE_W32_SYSTEM
+ sca->hd[0] = std_fds[0] == -1?
+ INVALID_HANDLE_VALUE : (HANDLE)_get_osfhandle (std_fds[0]);
+ sca->hd[1] = std_fds[1] == -1?
+ INVALID_HANDLE_VALUE : (HANDLE)_get_osfhandle (std_fds[1]);
+ sca->hd[2] = std_fds[2] == -1?
+ INVALID_HANDLE_VALUE : (HANDLE)_get_osfhandle (std_fds[2]);
+#else
+ sca->fds[0] = std_fds[0];
+ sca->fds[1] = std_fds[1];
+ sca->fds[2] = std_fds[2];
+#endif
}
static pointer
-do_spawn_process_fd (scheme *sc, pointer args)
+do_process_spawn_fd (scheme *sc, pointer args)
{
FFI_PROLOG ();
pointer arguments;
char **argv;
size_t len;
- int infd, outfd, errfd;
-
- pid_t pid;
+ int std_fds[3];
+ gnupg_process_t proc = NULL;
FFI_ARG_OR_RETURN (sc, pointer, arguments, list, args);
- FFI_ARG_OR_RETURN (sc, int, infd, number, args);
- FFI_ARG_OR_RETURN (sc, int, outfd, number, args);
- FFI_ARG_OR_RETURN (sc, int, errfd, number, args);
+ FFI_ARG_OR_RETURN (sc, int, std_fds[0], number, args);
+ FFI_ARG_OR_RETURN (sc, int, std_fds[1], number, args);
+ FFI_ARG_OR_RETURN (sc, int, std_fds[2], number, args);
FFI_ARGS_DONE_OR_RETURN (sc, args);
err = ffi_list2argv (sc, arguments, &argv, &len);
@@ -839,107 +1192,35 @@ do_spawn_process_fd (scheme *sc, pointer args)
fprintf (stderr, "Executing:");
for (p = argv; *p; p++)
fprintf (stderr, " '%s'", *p);
- fprintf (stderr, "\n");
+ fprintf (stderr, " (%d %d %d)\n", std_fds[0], std_fds[1], std_fds[2]);
}
- err = gnupg_spawn_process_fd (argv[0], (const char **) &argv[1],
- infd, outfd, errfd, &pid);
+ err = gnupg_process_spawn (argv[0], (const char **) &argv[1],
+ 0, setup_std_fds, std_fds, &proc);
xfree (argv);
- FFI_RETURN_INT (sc, pid);
+ FFI_RETURN_POINTER (sc, proc_wrap (sc, proc));
}
static pointer
-do_wait_process (scheme *sc, pointer args)
+do_process_wait (scheme *sc, pointer args)
{
FFI_PROLOG ();
- const char *name;
- pid_t pid;
+ struct proc_object_box *box;
int hang;
+ int retcode = -1;
- int retcode;
-
- FFI_ARG_OR_RETURN (sc, const char *, name, string, args);
- FFI_ARG_OR_RETURN (sc, pid_t, pid, number, args);
+ FFI_ARG_OR_RETURN (sc, struct proc_object_box *, box, proc, args);
FFI_ARG_OR_RETURN (sc, int, hang, bool, args);
FFI_ARGS_DONE_OR_RETURN (sc, args);
- err = gnupg_wait_process (name, pid, hang, &retcode);
- if (err == GPG_ERR_GENERAL)
- err = 0; /* Let the return code speak for itself. */
-
- FFI_RETURN_INT (sc, retcode);
-}
-
-
-static pointer
-do_wait_processes (scheme *sc, pointer args)
-{
- FFI_PROLOG ();
- pointer list_names;
- char **names;
- pointer list_pids;
- size_t i, count;
- pid_t *pids;
- int hang;
- int *retcodes;
- pointer retcodes_list = sc->NIL;
-
- FFI_ARG_OR_RETURN (sc, pointer, list_names, list, args);
- FFI_ARG_OR_RETURN (sc, pointer, list_pids, list, args);
- FFI_ARG_OR_RETURN (sc, int, hang, bool, args);
- FFI_ARGS_DONE_OR_RETURN (sc, args);
-
- if (sc->vptr->list_length (sc, list_names)
- != sc->vptr->list_length (sc, list_pids))
- return
- sc->vptr->mk_string (sc, "length of first two arguments must match");
-
- err = ffi_list2argv (sc, list_names, &names, &count);
- if (err == gpg_error (GPG_ERR_INV_VALUE))
- return ffi_sprintf (sc, "%lu%s element of first argument is "
- "neither string nor symbol",
- (unsigned long) count,
- ordinal_suffix ((int) count));
- if (err)
- FFI_RETURN_ERR (sc, err);
-
- err = ffi_list2intv (sc, list_pids, (int **) &pids, &count);
- if (err == gpg_error (GPG_ERR_INV_VALUE))
- return ffi_sprintf (sc, "%lu%s element of second argument is "
- "not a number",
- (unsigned long) count,
- ordinal_suffix ((int) count));
- if (err)
- FFI_RETURN_ERR (sc, err);
-
- retcodes = xtrycalloc (sizeof *retcodes, count);
- if (retcodes == NULL)
- {
- xfree (names);
- xfree (pids);
- FFI_RETURN_ERR (sc, gpg_error_from_syserror ());
- }
-
- err = gnupg_wait_processes ((const char **) names, pids, count, hang,
- retcodes);
- if (err == GPG_ERR_GENERAL)
- err = 0; /* Let the return codes speak. */
+ err = gnupg_process_wait (box->proc, hang);
+ if (!err)
+ err = gnupg_process_ctl (box->proc, GNUPG_PROCESS_GET_EXIT_ID, &retcode);
if (err == GPG_ERR_TIMEOUT)
- err = 0; /* We may have got some results. */
-
- for (i = 0; i < count; i++)
- retcodes_list =
- (sc->vptr->cons) (sc,
- sc->vptr->mk_integer (sc,
- (long) retcodes[count-1-i]),
- retcodes_list);
+ err = 0;
- xfree (names);
- xfree (pids);
- xfree (retcodes);
- FFI_RETURN_POINTER (sc, retcodes_list);
+ FFI_RETURN_INT (sc, retcode);
}
-
static pointer
do_pipe (scheme *sc, pointer args)
{
@@ -1398,13 +1679,12 @@ ffi_init (scheme *sc, const char *argv0, const char *scriptname,
ffi_define_function (sc, make_random_string);
/* Process management. */
- ffi_define_function (sc, spawn_process);
- ffi_define_function (sc, spawn_process_fd);
- ffi_define_function (sc, wait_process);
- ffi_define_function (sc, wait_processes);
ffi_define_function (sc, pipe);
ffi_define_function (sc, inbound_pipe);
ffi_define_function (sc, outbound_pipe);
+ ffi_define_function (sc, process_spawn_io);
+ ffi_define_function (sc, process_spawn_fd);
+ ffi_define_function (sc, process_wait);
/* estream functions. */
ffi_define_function_name (sc, "es-fclose", es_fclose);
diff --git a/tests/gpgscm/scheme.c b/tests/gpgscm/scheme.c
index bde39fcd0..003e85037 100644
--- a/tests/gpgscm/scheme.c
+++ b/tests/gpgscm/scheme.c
@@ -169,7 +169,11 @@ type_to_string (enum scheme_types typ)
case T_SINK: return "sink";
case T_FRAME: return "frame";
}
+#ifdef __GNUC__
+ __builtin_unreachable ();
+#else
assert (! "not reached");
+#endif
}
/* ADJ is enough slack to align cells in a TYPE_BITS-bit boundary */
diff --git a/tests/gpgscm/t-child.scm b/tests/gpgscm/t-child.scm
index fd1dcc3fe..461413b9c 100644
--- a/tests/gpgscm/t-child.scm
+++ b/tests/gpgscm/t-child.scm
@@ -69,37 +69,36 @@
(assert (string=? "" (:stderr r))))
(define (spawn what)
- (spawn-process-fd what CLOSED_FD STDOUT_FILENO STDERR_FILENO))
+ (process-spawn-fd what CLOSED_FD STDOUT_FILENO STDERR_FILENO))
-(let ((pid0 (spawn `(,(qualify "t-child") "return0")))
- (pid1 (spawn `(,(qualify "t-child") "return0"))))
- (assert (equal? '(0 0)
- (wait-processes '("child0" "child1") (list pid0 pid1) #t))))
+(let ((proc0 (spawn `(,(qualify "t-child") "return0")))
+ (proc1 (spawn `(,(qualify "t-child") "return0"))))
+ (assert (= (process-wait proc0 #t) 0))
+ (assert (= (process-wait proc1 #t) 0)))
-(let ((pid0 (spawn `(,(qualify "t-child") "return1")))
- (pid1 (spawn `(,(qualify "t-child") "return0"))))
- (assert (equal? '(1 0)
- (wait-processes '("child0" "child1") (list pid0 pid1) #t))))
+(let ((proc0 (spawn `(,(qualify "t-child") "return1")))
+ (proc1 (spawn `(,(qualify "t-child") "return0"))))
+ (assert (= (process-wait proc0 #t) 1))
+ (assert (= (process-wait proc1 #t) 0)))
-(let ((pid0 (spawn `(,(qualify "t-child") "return0")))
- (pid1 (spawn `(,(qualify "t-child") "return77")))
- (pid2 (spawn `(,(qualify "t-child") "return1"))))
- (assert (equal? '(0 77 1)
- (wait-processes '("child0" "child1" "child2")
- (list pid0 pid1 pid2) #t))))
+(let ((proc0 (spawn `(,(qualify "t-child") "return0")))
+ (proc1 (spawn `(,(qualify "t-child") "return77")))
+ (proc2 (spawn `(,(qualify "t-child") "return1"))))
+ (assert (= (process-wait proc0 #t) 0))
+ (assert (= (process-wait proc1 #t) 77))
+ (assert (= (process-wait proc2 #t) 1)))
(let* ((p (pipe))
- (pid0 (spawn-process-fd
+ (proc0 (process-spawn-fd
`(,(qualify "t-child") "hello_stdout")
CLOSED_FD (:write-end p) STDERR_FILENO))
(_ (close (:write-end p)))
- (pid1 (spawn-process-fd
+ (proc1 (process-spawn-fd
`(,(qualify "t-child") "cat")
(:read-end p) STDOUT_FILENO STDERR_FILENO)))
(close (:read-end p))
- (assert
- (equal? '(0 0)
- (wait-processes '("child0" "child1") (list pid0 pid1) #t))))
+ (assert (= (process-wait proc0 #t) 0))
+ (assert (= (process-wait proc1 #t) 0)))
(echo " world.")
(tr:do
diff --git a/tests/gpgscm/tests.scm b/tests/gpgscm/tests.scm
index db1025bbb..1e6d7fea0 100644
--- a/tests/gpgscm/tests.scm
+++ b/tests/gpgscm/tests.scm
@@ -81,7 +81,7 @@
;; Process management.
(define CLOSED_FD -1)
(define (call-with-fds what infd outfd errfd)
- (wait-process (stringify what) (spawn-process-fd what infd outfd errfd) #t))
+ (process-wait (process-spawn-fd what infd outfd errfd) #t))
(define (call what)
(call-with-fds what
CLOSED_FD
@@ -92,24 +92,16 @@
(define :stdin car)
(define :stdout cadr)
(define :stderr caddr)
-(define :pid cadddr)
(define (call-with-io what in)
- (let ((h (spawn-process what 0)))
- (es-write (:stdin h) in)
- (es-fclose (:stdin h))
- (let* ((out (es-read-all (:stdout h)))
- (err (es-read-all (:stderr h)))
- (result (wait-process (car what) (:pid h) #t)))
- (es-fclose (:stdout h))
- (es-fclose (:stderr h))
- (if (> (*verbose*) 2)
- (info "Child" (:pid h) "returned:"
- `((command ,(stringify what))
- (status ,result)
- (stdout ,out)
- (stderr ,err))))
- (list result out err))))
+ (let ((proc-result (process-spawn-io what in)))
+ (if (> (*verbose*) 2)
+ (info "Child #proc returned:"
+ `((command ,(stringify what))
+ (status ,(car proc-result))
+ (stdout ,(cadr proc-result))
+ (stderr ,(caddr proc-result)))))
+ proc-result))
;; Accessor function for the results of 'call-with-io'. ':stdout' and
;; ':stderr' can also be used.
@@ -129,17 +121,6 @@
(throw (:stderr result)))))
;;
-;; estream helpers.
-;;
-
-(define (es-read-all stream)
- (let loop
- ((acc ""))
- (if (es-feof stream)
- acc
- (loop (string-append acc (es-read stream 4096))))))
-
-;;
;; File management.
;;
(define (file-exists? name)
@@ -351,12 +332,8 @@
(define (dump)
(write (list procs source sink producer))
(newline))
- (define (add-proc command pid)
- (new (cons (list command pid) procs) source sink producer))
- (define (commands)
- (map car procs))
- (define (pids)
- (map cadr procs))
+ (define (add-proc proc)
+ (new (cons proc procs) source sink producer))
(define (set-source source')
(new procs source' sink producer))
(define (set-sink sink')
@@ -367,17 +344,19 @@
(new procs source sink producer'))))))
+(define (process-wait-list procs hang)
+ (map (lambda (p) (process-wait p hang)) procs))
+
(define (pipe:do . commands)
(let loop ((M (pipeM::new '() CLOSED_FD CLOSED_FD #f)) (cmds commands))
(if (null? cmds)
(begin
(if M::producer (M::producer))
(if (not (null? M::procs))
- (let* ((retcodes (wait-processes (map stringify (M::commands))
- (M::pids) #t))
- (results (map (lambda (p r) (append p (list r)))
+ (let* ((retcodes (process-wait-list M::procs #t))
+ (results (map (lambda (p r) (cons p r))
M::procs retcodes))
- (failed (filter (lambda (x) (not (= 0 (caddr x))))
+ (failed (filter (lambda (x) (not (= 0 (cdr x))))
results)))
(if (not (null? failed))
(throw failed))))) ; xxx nicer reporting
@@ -408,11 +387,11 @@
(define (pipe:spawn command)
(lambda (M)
(define (do-spawn M new-source)
- (let ((pid (spawn-process-fd command M::source M::sink
- (if (> (*verbose*) 0)
- STDERR_FILENO CLOSED_FD)))
+ (let ((proc (process-spawn-fd command M::source M::sink
+ (if (> (*verbose*) 0)
+ STDERR_FILENO CLOSED_FD)))
(M' (M::set-source new-source)))
- (M'::add-proc command pid)))
+ (M'::add-proc proc)))
(if (= CLOSED_FD M::sink)
(let* ((p (pipe))
(M' (do-spawn (M::set-sink (:write-end p)) (:read-end p))))
@@ -568,8 +547,8 @@
(assert (= (length enqueued) (- i 1)))
test)))))
- (define (pid->test pid)
- (let ((t (filter (lambda (x) (= pid x::pid)) procs)))
+ (define (proc->test proc)
+ (let ((t (filter (lambda (x) (eq? proc x::proc)) procs)))
(if (null? t) #f (car t))))
(define (wait)
(if (null? enqueued)
@@ -587,7 +566,7 @@
(if (null? unfinished)
(current-environment)
(let ((names (map (lambda (t) t::name) unfinished))
- (pids (map (lambda (t) t::pid) unfinished))
+ (procs (map (lambda (t) t::proc) unfinished))
(any #f))
(for-each
(lambda (test retcode)
@@ -597,8 +576,8 @@
(test::report)
(sem::release!)
(set! any #t)))
- (map pid->test pids)
- (wait-processes (map stringify names) pids hang))
+ (map proc->test procs)
+ (process-wait-list procs hang))
;; If some processes finished, try to start new ones.
(let loop ()
@@ -682,7 +661,7 @@
(define (scm setup variant name path . args)
;; Start the process.
(define (spawn-scm args' in out err)
- (spawn-process-fd `(,*argv0* ,@(verbosity (*verbose*))
+ (process-spawn-fd `(,*argv0* ,@(verbosity (*verbose*))
,(locate-test (test-name path))
,@(if setup (force setup) '())
,@args' ,@args) in out err))
@@ -691,12 +670,12 @@
(define (binary setup name path . args)
;; Start the process.
(define (spawn-binary args' in out err)
- (spawn-process-fd `(,(test-name path)
+ (process-spawn-fd `(,(test-name path)
,@(if setup (force setup) '()) ,@args' ,@args)
in out err))
(new #f name #f spawn-binary #f #f CLOSED_FD (expect-failure? name)))
- (define (new variant name directory spawn pid retcode logfd expect-failure)
+ (define (new variant name directory spawn proc retcode logfd expect-failure)
(package
;; XXX: OO glue.
@@ -721,7 +700,7 @@
;; Has the test been started yet?
(define (started?)
- (number? pid))
+ proc)
(define (open-log-file)
(unless log-file-name
@@ -738,26 +717,26 @@
(letfd ((log (open-log-file)))
(with-working-directory directory
(let* ((p (inbound-pipe))
- (pid' (spawn args 0 (:write-end p) (:write-end p))))
+ (proc' (spawn args 0 (:write-end p) (:write-end p))))
(close (:write-end p))
(splice (:read-end p) STDERR_FILENO log)
(close (:read-end p))
- (set! pid pid')
- (set! retcode (wait-process name pid' #t)))))
+ (set! proc proc')
+ (set! retcode (process-wait proc' #t)))))
(report)
(current-environment))
(define (run-sync-quiet . args)
(set-start-time!)
(with-working-directory directory
- (set! pid (spawn args CLOSED_FD CLOSED_FD CLOSED_FD)))
- (set! retcode (wait-process name pid #t))
+ (set! proc (spawn args CLOSED_FD CLOSED_FD CLOSED_FD)))
+ (set! retcode (process-wait proc #t))
(set-end-time!)
(current-environment))
(define (run-async . args)
(set-start-time!)
(let ((log (open-log-file)))
(with-working-directory directory
- (set! pid (spawn args CLOSED_FD log log)))
+ (set! proc (spawn args CLOSED_FD log log)))
(set! logfd log))
(current-environment))
(define (status)
diff --git a/tests/openpgp/defs.scm b/tests/openpgp/defs.scm
index bf3714f50..1ac25bf65 100644
--- a/tests/openpgp/defs.scm
+++ b/tests/openpgp/defs.scm
@@ -268,13 +268,14 @@
(define (gpg-pipe args0 args1 errfd)
(lambda (source sink)
(let* ((p (pipe))
- (task0 (spawn-process-fd `(,@GPG ,@args0)
+ (task0 (process-spawn-fd `(,@GPG ,@args0)
source (:write-end p) errfd))
(_ (close (:write-end p)))
- (task1 (spawn-process-fd `(,@GPG ,@args1)
+ (task1 (process-spawn-fd `(,@GPG ,@args1)
(:read-end p) sink errfd)))
(close (:read-end p))
- (wait-processes (list GPG GPG) (list task0 task1) #t))))
+ (process-wait task0 #t)
+ (process-wait task1 #t))))
(setenv "GPG_AGENT_INFO" "" #t)
(setenv "GNUPGHOME" (getcwd) #t)
diff --git a/tests/tpm2dtests/defs.scm b/tests/tpm2dtests/defs.scm
index 0fef71806..a913818f5 100644
--- a/tests/tpm2dtests/defs.scm
+++ b/tests/tpm2dtests/defs.scm
@@ -217,13 +217,14 @@
(define (gpg-pipe args0 args1 errfd)
(lambda (source sink)
(let* ((p (pipe))
- (task0 (spawn-process-fd `(,@GPG ,@args0)
+ (task0 (process-spawn-fd `(,@GPG ,@args0)
source (:write-end p) errfd))
(_ (close (:write-end p)))
- (task1 (spawn-process-fd `(,@GPG ,@args1)
+ (task1 (process-spawn-fd `(,@GPG ,@args1)
(:read-end p) sink errfd)))
(close (:read-end p))
- (wait-processes (list GPG GPG) (list task0 task1) #t))))
+ (process-wait task0 #t)
+ (process-wait task1 #t))))
;;
;; Do we have a software tpm
generated by cgit v1.2.3 (git 2.39.1) at 2025-01-30 16:19:44 +0100