367c64116b5d49e46610476426d01715b74a9a9d
[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))
77    (define (new name directory command pid retcode)
78      (package
79       (define (set-directory x)
80         (new name x command pid retcode))
81       (define (set-retcode x)
82         (new name directory command pid x))
83       (define (set-pid x)
84         (new name directory command x retcode))
85       (define (run-sync)
86         (with-working-directory directory
87           (let* ((p (inbound-pipe))
88                  (pid (spawn-process-fd command CLOSED_FD
89                                         (:write-end p) (:write-end p))))
90             (close (:write-end p))
91             (splice (:read-end p) STDERR_FILENO)
92             (close (:read-end p))
93             (let ((t' (set-retcode (wait-process name pid #t))))
94               (t'::report)
95               t'))))
96       (define (run-sync-quiet)
97         (with-working-directory directory
98           (set-retcode
99            (wait-process
100             name (spawn-process-fd command CLOSED_FD CLOSED_FD CLOSED_FD) #t))))
101       (define (run-async)
102         (with-working-directory directory
103           (set-pid (spawn-process-fd command CLOSED_FD CLOSED_FD CLOSED_FD))))
104       (define (status)
105         (let ((t (assoc retcode '((0 "PASS") (77 "SKIP") (99 "ERROR")))))
106           (if (not t) "FAIL" (cadr t))))
107       (define (report)
108         (echo (string-append (status retcode) ":") name))))))
109
110 (define (run-tests-parallel-shared setup teardown . tests)
111   (setup::run-sync)
112   (let loop ((pool (test-pool::new '())) (tests' tests))
113     (if (null? tests')
114         (let ((results (pool::wait)))
115           (for-each (lambda (t) (t::report)) results::procs)
116           (teardown::run-sync)
117           (exit (results::report)))
118         (let ((test (car tests')))
119           (loop (pool::add (test::run-async)) (cdr tests'))))))
120
121 (define (run-tests-parallel-isolated setup teardown . tests)
122   (let loop ((pool (test-pool::new '())) (tests' tests))
123     (if (null? tests')
124         (let ((results (pool::wait)))
125           (for-each (lambda (t)
126                       (let ((teardown' (teardown::set-directory t::directory)))
127                         (teardown'::run-sync-quiet))
128                       (unlink-recursively t::directory)
129                       (t::report)) results::procs)
130           (exit (results::report)))
131         (let* ((wd (mkdtemp "gpgscm-XXXXXX"))
132                (test (car tests'))
133                (test' (test::set-directory wd))
134                (setup' (setup::set-directory wd)))
135           (setup'::run-sync-quiet)
136           (loop (pool::add (test'::run-async)) (cdr tests'))))))
137
138 (define (run-tests-sequential-shared setup teardown . tests)
139   (let loop ((pool (test-pool::new '()))
140              (tests' `(,setup ,@tests ,teardown)))
141     (if (null? tests')
142         (let ((results (pool::wait)))
143           (exit (results::report)))
144         (let ((test (car tests')))
145           (loop (pool::add (test::run-sync)) (cdr tests'))))))
146
147 (define (run-tests-sequential-isolated setup teardown . tests)
148   (let loop ((pool (test-pool::new '())) (tests' tests))
149     (if (null? tests')
150         (let ((results (pool::wait)))
151           (for-each (lambda (t)
152                       (let ((teardown' (teardown::set-directory t::directory)))
153                         (teardown'::run-sync-quiet))
154                       (unlink-recursively t::directory))
155                     results::procs)
156           (exit (results::report)))
157         (let* ((wd (mkdtemp "gpgscm-XXXXXX"))
158                (test (car tests'))
159                (test' (test::set-directory wd))
160                (setup' (setup::set-directory wd)))
161           (setup'::run-sync-quiet)
162           (loop (pool::add (test'::run-sync)) (cdr tests'))))))
163
164 (define all-tests
165   '("version.scm"
166     "mds.scm"
167     "decrypt.scm"
168     "decrypt-dsa.scm"
169     "sigs.scm"
170     "sigs-dsa.scm"
171     "encrypt.scm"
172     "encrypt-dsa.scm"
173     "seat.scm"
174     "clearsig.scm"
175     "encryptp.scm"
176     "detach.scm"
177     "detachm.scm"
178     "armsigs.scm"
179     "armencrypt.scm"
180     "armencryptp.scm"
181     "signencrypt.scm"
182     "signencrypt-dsa.scm"
183     "armsignencrypt.scm"
184     "armdetach.scm"
185     "armdetachm.scm"
186     "genkey1024.scm"
187     "conventional.scm"
188     "conventional-mdc.scm"
189     "multisig.scm"
190     "verify.scm"
191     "armor.scm"
192     "import.scm"
193     "ecc.scm"
194     "4gb-packet.scm"
195     "tofu.scm"
196     "gpgtar.scm"
197     "use-exact-key.scm"
198     "default-key.scm"
199     "export.scm"
200     "ssh.scm"
201     "issue2015.scm"
202     "issue2346.scm"
203     "issue2419.scm"))
204
205 (let* ((runner (if (member "--parallel" *args*)
206                   (if (member "--shared" *args*)
207                       run-tests-parallel-shared
208                       run-tests-parallel-isolated)
209                   (if (member "--shared" *args*)
210                       run-tests-sequential-shared
211                       run-tests-sequential-isolated)))
212        (tests' (filter (lambda (arg) (not (string-prefix? arg "--"))) *args*))
213        (tests (if (null? tests') all-tests tests')))
214   (apply runner (append (list (test::scm "setup.scm") (test::scm "finish.scm"))
215                         (map test::scm tests))))