security-and-privacy/gnupg
security-and-privacy
/
gnupg
mirror of git://git.gnupg.org/gnupg.git
1
0
Fork 0
Code Activity

tests: Log and display output from tests when run in parallel. 

* 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>
This commit is contained in:
Justus Winter 2016-11-08 15:54:56 +01:00
parent 4dd4801bfa
commit 2a7615c48e
1 changed files with 22 additions and 11 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

33
tests/openpgp/run-tests.scm
View File

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