tests: Log and display output from tests when run in parallel.
authorJustus Winter <justus@g10code.com>
Tue, 8 Nov 2016 14:54:56 +0000 (15:54 +0100)
committerJustus Winter <justus@g10code.com>
Tue, 8 Nov 2016 15:03:16 +0000 (16:03 +0100)
* tests/openpgp/run-tests.scm (test): Add field 'logfd'.
(test::new, test::set-*): Adapt accordingly.
(test::set-logfd): New function.
(test::open-log-file): Likewise.
(test::run-sync): Use the new function.
(test::run-async): Likewise.
(test::report): Replay the log.
(run-tests-parallel): Reverse the results to restore the original
order.

Signed-off-by: Justus Winter <justus@g10code.com>
tests/openpgp/run-tests.scm

index 23ff8a2..90879a6 100644 (file)
   (package
    (define (scm name . args)
      (new name #f `(,*argv0* ,@(verbosity (*verbose*)) ,@args
-                            ,(in-srcdir name)) #f #f))
-   (define (new name directory command pid retcode)
+                            ,(in-srcdir name)) #f #f CLOSED_FD))
+   (define (new name directory command pid retcode logfd)
      (package
       (define (set-directory x)
-       (new name x command pid retcode))
+       (new name x command pid retcode logfd))
       (define (set-retcode x)
-       (new name directory command pid x))
+       (new name directory command pid x logfd))
       (define (set-pid x)
-       (new name directory command x retcode))
+       (new name directory command x retcode logfd))
+      (define (set-logfd x)
+       (new name directory command pid retcode x))
+      (define (open-log-file)
+       (let ((filename (string-append name ".log")))
+         (catch '() (unlink filename))
+         (open filename (logior O_RDWR O_BINARY O_CREAT) #o600)))
       (define (run-sync . args)
-       (letfd ((log (open (string-append name ".log")
-                          (logior O_WRONLY O_BINARY O_CREAT) #o600)))
+       (letfd ((log (open-log-file)))
          (with-working-directory directory
            (let* ((p (inbound-pipe))
                   (pid (spawn-process-fd (append command args) 0
            name (spawn-process-fd (append command args)
                                   CLOSED_FD CLOSED_FD CLOSED_FD) #t))))
       (define (run-async . args)
-       (with-working-directory directory
-         (set-pid (spawn-process-fd (append command args)
-                                    CLOSED_FD CLOSED_FD CLOSED_FD))))
+       (let ((log (open-log-file)))
+         (with-working-directory directory
+           (new name directory command
+                (spawn-process-fd (append command args) CLOSED_FD log log)
+                retcode log))))
       (define (status)
        (let ((t (assoc retcode '((0 "PASS") (77 "SKIP") (99 "ERROR")))))
          (if (not t) "FAIL" (cadr t))))
       (define (report)
+       (unless (= logfd CLOSED_FD)
+               (seek logfd 0 SEEK_SET)
+               (splice logfd STDERR_FILENO)
+               (close logfd))
        (echo (string-append (status retcode) ":") name))))))
 
 (define (run-tests-parallel setup tests)
            (for-each (lambda (t)
                        (catch (echo "Removing" t::directory "failed:" *error*)
                               (unlink-recursively t::directory))
-                       (t::report)) results::procs)
+                       (t::report)) (reverse results::procs))
            (exit (results::report)))
          (let* ((wd (mkdtemp))
                 (test (car tests'))