tests: Refactor test runner.

* tests/openpgp/run-tests.scm (locate-test): New function.
(test): Factor-out the code starting the child process.
(test::binary): New function.

Signed-off-by: Justus Winter <justus@g10code.com>

tests/openpgp/run-tests.scm

@@ -36,12 +36,12 @@
 	(let ((unfinished (filter (lambda (t) (not t::retcode)) procs)))
 	  (if (null? unfinished)
 	      (package)
-	      (let* ((commands (map (lambda (t) t::command) unfinished))
+	      (let* ((names (map (lambda (t) t::name) unfinished))
 		     (pids (map (lambda (t) t::pid) unfinished))
 		     (results
 		      (map (lambda (pid retcode) (list pid retcode))
 			   pids
-			   (wait-processes (map stringify commands) pids #t))))
+			   (wait-processes (map stringify names) pids #t))))
 		(new
 		 (map (lambda (t)
 			(if t::retcode
@@ -69,31 +69,43 @@
 (define (verbosity n)
   (if (= 0 n) '() (cons '--verbose (verbosity (- n 1)))))
 
+(define (locate-test path)
+  (if (absolute-path? path) path (in-srcdir path)))
+
 (define test
   (package
-   (define (scm name . args)
+   (define (scm path . args)
-     (new name #f `(,*argv0* ,@(verbosity (*verbose*)) ,@args
+     ;; Start the process.
-			     ,(in-srcdir name)) #f #f CLOSED_FD))
+     (define (spawn-scm args in out err)
-   (define (new name directory command pid retcode logfd)
+       (spawn-process-fd `(,*argv0* ,@(verbosity (*verbose*))
+				    ,(locate-test path) ,@args) in out err))
+     (new (basename path) #f spawn-scm #f #f CLOSED_FD))
+
+   (define (binary path . args)
+     ;; Start the process.
+     (define (spawn-binary args in out err)
+       (spawn-process-fd `(path ,@args) in out err))
+     (new (basename path) #f spawn-binary #f #f CLOSED_FD))
+
+   (define (new name directory spawn pid retcode logfd)
      (package
       (define (set-directory x)
-	(new name x command pid retcode logfd))
+	(new name x spawn pid retcode logfd))
       (define (set-retcode x)
-	(new name directory command pid x logfd))
+	(new name directory spawn pid x logfd))
       (define (set-pid x)
-	(new name directory command x retcode logfd))
+	(new name directory spawn x retcode logfd))
       (define (set-logfd x)
-	(new name directory command pid retcode x))
+	(new name directory spawn pid retcode x))
       (define (open-log-file)
-	(let ((filename (string-append name ".log")))
+	(let ((filename (string-append (basename name) ".log")))
 	  (catch '() (unlink filename))
 	  (open filename (logior O_RDWR O_BINARY O_CREAT) #o600)))
       (define (run-sync . args)
 	(letfd ((log (open-log-file)))
 	  (with-working-directory directory
 	    (let* ((p (inbound-pipe))
-		   (pid (spawn-process-fd (append command args) 0
+		   (pid (spawn args 0 (:write-end p) (:write-end p))))
-					  (:write-end p) (:write-end p))))
 	      (close (:write-end p))
 	      (splice (:read-end p) STDERR_FILENO log)
 	      (close (:read-end p))
@@ -104,13 +116,12 @@
 	(with-working-directory directory
 	  (set-retcode
 	   (wait-process
-	    name (spawn-process-fd (append command args)
+	    name (spawn args CLOSED_FD CLOSED_FD CLOSED_FD) #t))))
-				   CLOSED_FD CLOSED_FD CLOSED_FD) #t))))
       (define (run-async . args)
 	(let ((log (open-log-file)))
 	  (with-working-directory directory
-	    (new name directory command
+	    (new name directory spawn
-		 (spawn-process-fd (append command args) CLOSED_FD log log)
+		 (spawn args CLOSED_FD log log)
 		 retcode log))))
       (define (status)
 	(let ((t (assoc retcode '((0 "PASS") (77 "SKIP") (99 "ERROR")))))