tests: Log and display output from tests when run in parallel.
[gnupg.git] / tests / openpgp / run-tests.scm
1 ;; Test-suite runner.
2 ;;
3 ;; Copyright (C) 2016 g10 Code GmbH
4 ;;
5 ;; This file is part of GnuPG.
6 ;;
7 ;; GnuPG is free software; you can redistribute it and/or modify
8 ;; it under the terms of the GNU General Public License as published by
9 ;; the Free Software Foundation; either version 3 of the License, or
10 ;; (at your option) any later version.
11 ;;
12 ;; GnuPG is distributed in the hope that it will be useful,
13 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
14 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
15 ;; GNU General Public License for more details.
16 ;;
17 ;; You should have received a copy of the GNU General Public License
18 ;; along with this program; if not, see <http://www.gnu.org/licenses/>.
19
20 (if (string=? "" (getenv "srcdir"))
21     (begin
22       (echo "Environment variable 'srcdir' not set.  Please point it to"
23             "tests/openpgp.")
24       (exit 2)))
25
26 ;; Set objdir so that the tests can locate built programs.
27 (setenv "objdir" (getcwd) #f)
28
29 (define test-pool
30   (package
31    (define (new procs)
32      (package
33       (define (add test)
34         (new (cons test procs)))
35       (define (wait)
36         (let ((unfinished (filter (lambda (t) (not t::retcode)) procs)))
37           (if (null? unfinished)
38               (package)
39               (let* ((commands (map (lambda (t) t::command) unfinished))
40                      (pids (map (lambda (t) t::pid) unfinished))
41                      (results
42                       (map (lambda (pid retcode) (list pid retcode))
43                            pids
44                            (wait-processes (map stringify commands) pids #t))))
45                 (new
46                  (map (lambda (t)
47                         (if t::retcode
48                             t
49                             (t::set-retcode (cadr (assoc t::pid results)))))
50                       procs))))))
51       (define (passed)
52         (filter (lambda (p) (= 0 p::retcode)) procs))
53       (define (skipped)
54         (filter (lambda (p) (= 77 p::retcode)) procs))
55       (define (hard-errored)
56         (filter (lambda (p) (= 99 p::retcode)) procs))
57       (define (failed)
58         (filter (lambda (p)
59                   (not (or (= 0 p::retcode) (= 77 p::retcode)
60                            (= 99 p::retcode))))
61                 procs))
62       (define (report)
63         (echo (length procs) "tests run,"
64               (length (passed)) "succeeded,"
65               (length (failed)) "failed,"
66               (length (skipped)) "skipped.")
67         (length (failed)))))))
68
69 (define (verbosity n)
70   (if (= 0 n) '() (cons '--verbose (verbosity (- n 1)))))
71
72 (define test
73   (package
74    (define (scm name . args)
75      (new name #f `(,*argv0* ,@(verbosity (*verbose*)) ,@args
76                              ,(in-srcdir name)) #f #f CLOSED_FD))
77    (define (new name directory command pid retcode logfd)
78      (package
79       (define (set-directory x)
80         (new name x command pid retcode logfd))
81       (define (set-retcode x)
82         (new name directory command pid x logfd))
83       (define (set-pid x)
84         (new name directory command x retcode logfd))
85       (define (set-logfd x)
86         (new name directory command pid retcode x))
87       (define (open-log-file)
88         (let ((filename (string-append name ".log")))
89           (catch '() (unlink filename))
90           (open filename (logior O_RDWR O_BINARY O_CREAT) #o600)))
91       (define (run-sync . args)
92         (letfd ((log (open-log-file)))
93           (with-working-directory directory
94             (let* ((p (inbound-pipe))
95                    (pid (spawn-process-fd (append command args) 0
96                                           (:write-end p) (:write-end p))))
97               (close (:write-end p))
98               (splice (:read-end p) STDERR_FILENO log)
99               (close (:read-end p))
100               (let ((t' (set-retcode (wait-process name pid #t))))
101                 (t'::report)
102                 t')))))
103       (define (run-sync-quiet . args)
104         (with-working-directory directory
105           (set-retcode
106            (wait-process
107             name (spawn-process-fd (append command args)
108                                    CLOSED_FD CLOSED_FD CLOSED_FD) #t))))
109       (define (run-async . args)
110         (let ((log (open-log-file)))
111           (with-working-directory directory
112             (new name directory command
113                  (spawn-process-fd (append command args) CLOSED_FD log log)
114                  retcode log))))
115       (define (status)
116         (let ((t (assoc retcode '((0 "PASS") (77 "SKIP") (99 "ERROR")))))
117           (if (not t) "FAIL" (cadr t))))
118       (define (report)
119         (unless (= logfd CLOSED_FD)
120                 (seek logfd 0 SEEK_SET)
121                 (splice logfd STDERR_FILENO)
122                 (close logfd))
123         (echo (string-append (status retcode) ":") name))))))
124
125 (define (run-tests-parallel setup tests)
126   (lettmp (gpghome-tar)
127     (setup::run-sync '--create-tarball gpghome-tar)
128     (let loop ((pool (test-pool::new '())) (tests' tests))
129       (if (null? tests')
130           (let ((results (pool::wait)))
131             (for-each (lambda (t)
132                         (catch (echo "Removing" t::directory "failed:" *error*)
133                                (unlink-recursively t::directory))
134                         (t::report)) (reverse results::procs))
135             (exit (results::report)))
136           (let* ((wd (mkdtemp))
137                  (test (car tests'))
138                  (test' (test::set-directory wd)))
139             (loop (pool::add (test'::run-async '--unpack-tarball gpghome-tar))
140                   (cdr tests')))))))
141
142 (define (run-tests-sequential setup tests)
143   (lettmp (gpghome-tar)
144     (setup::run-sync '--create-tarball gpghome-tar)
145     (let loop ((pool (test-pool::new '())) (tests' tests))
146       (if (null? tests')
147           (let ((results (pool::wait)))
148             (for-each (lambda (t)
149                         (catch (echo "Removing" t::directory "failed:" *error*)
150                                (unlink-recursively t::directory)))
151                       results::procs)
152             (exit (results::report)))
153           (let* ((wd (mkdtemp))
154                  (test (car tests'))
155                  (test' (test::set-directory wd)))
156             (loop (pool::add (test'::run-sync '--unpack-tarball gpghome-tar))
157                   (cdr tests')))))))
158
159 (let* ((runner (if (member "--parallel" *args*)
160                    run-tests-parallel
161                    run-tests-sequential))
162        (tests (filter (lambda (arg) (not (string-prefix? arg "--"))) *args*)))
163   (runner (test::scm "setup.scm") (map test::scm tests)))