tests: Replace spawn_process_fd functions by the new spawn_process.

--

Signed-off-by: NIIBE Yutaka <gniibe@fsij.org>

tests/gpgscm/ffi.c

@@ -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;
+  int std_fds[3];
-
+  gnupg_process_t proc = NULL;
-  pid_t pid;
 
   FFI_ARG_OR_RETURN (sc, pointer, arguments, list, args);
-  FFI_ARG_OR_RETURN (sc, int, infd, number, args);
+  FFI_ARG_OR_RETURN (sc, int, std_fds[0], number, args);
-  FFI_ARG_OR_RETURN (sc, int, outfd, number, args);
+  FFI_ARG_OR_RETURN (sc, int, std_fds[1], number, args);
-  FFI_ARG_OR_RETURN (sc, int, errfd, 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],
+  err = gnupg_process_spawn (argv[0], (const char **) &argv[1],
-                                infd, outfd, errfd, &pid);
+                             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);

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")))
+(let ((proc0 (spawn `(,(qualify "t-child") "return0")))
-      (pid1 (spawn `(,(qualify "t-child") "return0"))))
+      (proc1 (spawn `(,(qualify "t-child") "return0"))))
-  (assert (equal? '(0 0)
+  (assert (= (process-wait proc0 #t) 0))
-		  (wait-processes '("child0" "child1") (list pid0 pid1) #t))))
+  (assert (= (process-wait proc1 #t) 0)))
 
-(let ((pid0 (spawn `(,(qualify "t-child") "return1")))
+(let ((proc0 (spawn `(,(qualify "t-child") "return1")))
-      (pid1 (spawn `(,(qualify "t-child") "return0"))))
+      (proc1 (spawn `(,(qualify "t-child") "return0"))))
-  (assert (equal? '(1 0)
+  (assert (= (process-wait proc0 #t) 1))
-		  (wait-processes '("child0" "child1") (list pid0 pid1) #t))))
+  (assert (= (process-wait proc1 #t) 0)))
 
-(let ((pid0 (spawn `(,(qualify "t-child") "return0")))
+(let ((proc0 (spawn `(,(qualify "t-child") "return0")))
-      (pid1 (spawn `(,(qualify "t-child") "return77")))
+      (proc1 (spawn `(,(qualify "t-child") "return77")))
-      (pid2 (spawn `(,(qualify "t-child") "return1"))))
+      (proc2 (spawn `(,(qualify "t-child") "return1"))))
-  (assert (equal? '(0 77 1)
+  (assert (= (process-wait proc0 #t) 0))
-		  (wait-processes '("child0" "child1" "child2")
+  (assert (= (process-wait proc1 #t) 77))
-				  (list pid0 pid1 pid2) #t))))
+  (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
+  (assert (= (process-wait proc0 #t) 0))
-   (equal? '(0 0)
+  (assert (= (process-wait proc1 #t) 0)))
-	   (wait-processes '("child0" "child1") (list pid0 pid1) #t))))
 (echo " world.")
 
 (tr:do

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
@@ -351,12 +351,8 @@
       (define (dump)
 	(write (list procs source sink producer))
 	(newline))
-      (define (add-proc command pid)
+      (define (add-proc proc)
-	(new (cons (list command pid) procs) source sink producer))
+	(new (cons proc procs) source sink producer))
-      (define (commands)
-	(map car procs))
-      (define (pids)
-	(map cadr procs))
       (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))
+	      (let* ((retcodes (process-wait-list M::procs #t))
-					       (M::pids) #t))
+		     (results (map (lambda (p r) (cons p r))
-		     (results (map (lambda (p r) (append p (list 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
+      (let ((proc (process-spawn-fd command M::source M::sink
-				   (if (> (*verbose*) 0)
+				    (if (> (*verbose*) 0)
-				       STDERR_FILENO CLOSED_FD)))
+				        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)
+      (define (proc->test proc)
-	(let ((t (filter (lambda (x) (= pid x::pid)) procs)))
+	(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)
+		 (map proc->test procs)
-		 (wait-processes (map stringify names) pids hang))
+		 (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! proc proc')
-	      (set! retcode (wait-process name pid' #t)))))
+	      (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! proc (spawn args CLOSED_FD CLOSED_FD CLOSED_FD)))
-	(set! retcode (wait-process name pid #t))
+	(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)

tests/openpgp/defs.scm

@@ -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)

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