mirror of
git://git.gnupg.org/gnupg.git
synced 2024-11-12 21:58:50 +01:00
tests: Replace spawn_process_fd functions by the new spawn_process.
-- Signed-off-by: NIIBE Yutaka <gniibe@fsij.org>
This commit is contained in:
NIIBE Yutaka
parent
b35c3980c1
commit
8bd75655cb
@ -748,9 +748,68 @@ 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
|
||||
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)
|
||||
|
||||
|
||||
static pointer
|
||||
do_spawn_process (scheme *sc, pointer args)
|
||||
{
|
||||
@ -803,21 +862,30 @@ do_spawn_process (scheme *sc, pointer args)
|
||||
#undef IMC
|
||||
}
|
||||
|
||||
static void
|
||||
setup_std_fds (struct spawn_cb_arg *sca)
|
||||
{
|
||||
int *std_fds = sca->arg;
|
||||
|
||||
sca->fds[0] = std_fds[0];
|
||||
sca->fds[1] = std_fds[1];
|
||||
sca->fds[2] = std_fds[2];
|
||||
}
|
||||
|
||||
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);
|
||||
@ -834,13 +902,31 @@ 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_process_wait (scheme *sc, pointer args)
|
||||
{
|
||||
FFI_PROLOG ();
|
||||
struct proc_object_box *box;
|
||||
int hang;
|
||||
int retcode = -1;
|
||||
|
||||
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_process_wait (box->proc, hang);
|
||||
if (!err)
|
||||
err = gnupg_process_ctl (box->proc, GNUPG_PROCESS_GET_EXIT_ID, &retcode);
|
||||
|
||||
FFI_RETURN_INT (sc, retcode);
|
||||
}
|
||||
|
||||
static pointer
|
||||
@ -1394,12 +1480,13 @@ ffi_init (scheme *sc, const char *argv0, const char *scriptname,
|
||||
|
||||
/* 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_fd);
|
||||
ffi_define_function (sc, process_wait);
|
||||
|
||||
/* estream functions. */
|
||||
ffi_define_function_name (sc, "es-fclose", es_fclose);
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
@ -351,12 +351,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 +363,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 +406,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 +566,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 +585,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 +595,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 +680,7 @@
|
||||
(define (scm setup 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 +689,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 name #f spawn-binary #f #f CLOSED_FD (expect-failure? name)))
|
||||
|
||||
(define (new name directory spawn pid retcode logfd expect-failure)
|
||||
(define (new name directory spawn proc retcode logfd expect-failure)
|
||||
(package
|
||||
|
||||
;; XXX: OO glue.
|
||||
@ -721,7 +719,7 @@
|
||||
|
||||
;; Has the test been started yet?
|
||||
(define (started?)
|
||||
(number? pid))
|
||||
proc)
|
||||
|
||||
(define (open-log-file)
|
||||
(unless log-file-name
|
||||
@ -734,26 +732,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)
|
||||
|
||||
@ -265,13 +265,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)
|
||||
|
||||
@ -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
|
||||
|
||||
Loading…
Reference in New Issue
Block a user