tests: Refactor test runner.
[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* ((names (map (lambda (t) t::name) 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 names) 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 (locate-test path)
73   (if (absolute-path? path) path (in-srcdir path)))
74
75 (define test
76   (package
77    (define (scm path . args)
78      ;; Start the process.
79      (define (spawn-scm args in out err)
80        (spawn-process-fd `(,*argv0* ,@(verbosity (*verbose*))
81                                     ,(locate-test path) ,@args) in out err))
82      (new (basename path) #f spawn-scm #f #f CLOSED_FD))
83
84    (define (binary path . args)
85      ;; Start the process.
86      (define (spawn-binary args in out err)
87        (spawn-process-fd `(path ,@args) in out err))
88      (new (basename path) #f spawn-binary #f #f CLOSED_FD))
89
90    (define (new name directory spawn pid retcode logfd)
91      (package
92       (define (set-directory x)
93         (new name x spawn pid retcode logfd))
94       (define (set-retcode x)
95         (new name directory spawn pid x logfd))
96       (define (set-pid x)
97         (new name directory spawn x retcode logfd))
98       (define (set-logfd x)
99         (new name directory spawn pid retcode x))
100       (define (open-log-file)
101         (let ((filename (string-append (basename name) ".log")))
102           (catch '() (unlink filename))
103           (open filename (logior O_RDWR O_BINARY O_CREAT) #o600)))
104       (define (run-sync . args)
105         (letfd ((log (open-log-file)))
106           (with-working-directory directory
107             (let* ((p (inbound-pipe))
108                    (pid (spawn args 0 (:write-end p) (:write-end p))))
109               (close (:write-end p))
110               (splice (:read-end p) STDERR_FILENO log)
111               (close (:read-end p))
112               (let ((t' (set-retcode (wait-process name pid #t))))
113                 (t'::report)
114                 t')))))
115       (define (run-sync-quiet . args)
116         (with-working-directory directory
117           (set-retcode
118            (wait-process
119             name (spawn args CLOSED_FD CLOSED_FD CLOSED_FD) #t))))
120       (define (run-async . args)
121         (let ((log (open-log-file)))
122           (with-working-directory directory
123             (new name directory spawn
124                  (spawn args CLOSED_FD log log)
125                  retcode log))))
126       (define (status)
127         (let ((t (assoc retcode '((0 "PASS") (77 "SKIP") (99 "ERROR")))))
128           (if (not t) "FAIL" (cadr t))))
129       (define (report)
130         (unless (= logfd CLOSED_FD)
131                 (seek logfd 0 SEEK_SET)
132                 (splice logfd STDERR_FILENO)
133                 (close logfd))
134         (echo (string-append (status retcode) ":") name))))))
135
136 (define (run-tests-parallel setup tests)
137   (lettmp (gpghome-tar)
138     (setup::run-sync '--create-tarball gpghome-tar)
139     (let loop ((pool (test-pool::new '())) (tests' tests))
140       (if (null? tests')
141           (let ((results (pool::wait)))
142             (for-each (lambda (t)
143                         (catch (echo "Removing" t::directory "failed:" *error*)
144                                (unlink-recursively t::directory))
145                         (t::report)) (reverse results::procs))
146             (exit (results::report)))
147           (let* ((wd (mkdtemp))
148                  (test (car tests'))
149                  (test' (test::set-directory wd)))
150             (loop (pool::add (test'::run-async '--unpack-tarball gpghome-tar))
151                   (cdr tests')))))))
152
153 (define (run-tests-sequential setup tests)
154   (lettmp (gpghome-tar)
155     (setup::run-sync '--create-tarball gpghome-tar)
156     (let loop ((pool (test-pool::new '())) (tests' tests))
157       (if (null? tests')
158           (let ((results (pool::wait)))
159             (for-each (lambda (t)
160                         (catch (echo "Removing" t::directory "failed:" *error*)
161                                (unlink-recursively t::directory)))
162                       results::procs)
163             (exit (results::report)))
164           (let* ((wd (mkdtemp))
165                  (test (car tests'))
166                  (test' (test::set-directory wd)))
167             (loop (pool::add (test'::run-sync '--unpack-tarball gpghome-tar))
168                   (cdr tests')))))))
169
170 (let* ((runner (if (member "--parallel" *args*)
171                    run-tests-parallel
172                    run-tests-sequential))
173        (tests (filter (lambda (arg) (not (string-prefix? arg "--"))) *args*)))
174   (runner (test::scm "setup.scm") (map test::scm tests)))