tests: Improve handling of Windows newlines.
[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 . args)
86         (with-working-directory directory
87           (let* ((p (inbound-pipe))
88                  (pid (spawn-process-fd (append command args) 0
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 . args)
97         (with-working-directory directory
98           (set-retcode
99            (wait-process
100             name (spawn-process-fd (append command args)
101                                    CLOSED_FD CLOSED_FD CLOSED_FD) #t))))
102       (define (run-async . args)
103         (with-working-directory directory
104           (set-pid (spawn-process-fd (append command args)
105                                      CLOSED_FD CLOSED_FD CLOSED_FD))))
106       (define (status)
107         (let ((t (assoc retcode '((0 "PASS") (77 "SKIP") (99 "ERROR")))))
108           (if (not t) "FAIL" (cadr t))))
109       (define (report)
110         (echo (string-append (status retcode) ":") name))))))
111
112 (define (run-tests-parallel-shared setup teardown . tests)
113   (setup::run-sync)
114   (let loop ((pool (test-pool::new '())) (tests' tests))
115     (if (null? tests')
116         (let ((results (pool::wait)))
117           (for-each (lambda (t) (t::report)) results::procs)
118           (teardown::run-sync)
119           (exit (results::report)))
120         (let ((test (car tests')))
121           (loop (pool::add (test::run-async)) (cdr tests'))))))
122
123 (define (run-tests-parallel-isolated setup teardown . tests)
124   (lettmp (gpghome-tar)
125     (setup::run-sync '--create-tarball gpghome-tar)
126     (let loop ((pool (test-pool::new '())) (tests' tests))
127       (if (null? tests')
128           (let ((results (pool::wait)))
129             (for-each (lambda (t)
130                         (let ((teardown' (teardown::set-directory
131                                           t::directory)))
132                           (teardown'::run-sync-quiet))
133                         (unlink-recursively t::directory)
134                         (t::report)) results::procs)
135             (exit (results::report)))
136           (let* ((wd (mkdtemp))
137                  (test (car tests'))
138                  (test' (test::set-directory wd))
139                  (setup' (setup::set-directory wd)))
140             (setup'::run-sync-quiet '--unpack-tarball gpghome-tar)
141             (loop (pool::add (test'::run-async)) (cdr tests')))))))
142
143 (define (run-tests-sequential-shared setup teardown . tests)
144   (let loop ((pool (test-pool::new '()))
145              (tests' `(,setup ,@tests ,teardown)))
146     (if (null? tests')
147         (let ((results (pool::wait)))
148           (exit (results::report)))
149         (let ((test (car tests')))
150           (loop (pool::add (test::run-sync)) (cdr tests'))))))
151
152 (define (run-tests-sequential-isolated setup teardown . tests)
153   (lettmp (gpghome-tar)
154     (setup::run-sync '--create-tarball gpghome-tar)
155     (let loop ((pool (test-pool::new '())) (tests' tests))
156       (if (null? tests')
157           (let ((results (pool::wait)))
158             (for-each (lambda (t)
159                         (let ((teardown' (teardown::set-directory
160                                           t::directory)))
161                           (teardown'::run-sync-quiet))
162                         (unlink-recursively t::directory))
163                       results::procs)
164             (exit (results::report)))
165           (let* ((wd (mkdtemp))
166                  (test (car tests'))
167                  (test' (test::set-directory wd))
168                  (setup' (setup::set-directory wd)))
169             (setup'::run-sync-quiet '--unpack-tarball gpghome-tar)
170             (loop (pool::add (test'::run-sync)) (cdr tests')))))))
171
172 (let* ((runner (if (member "--parallel" *args*)
173                   (if (member "--shared" *args*)
174                       run-tests-parallel-shared
175                       run-tests-parallel-isolated)
176                   (if (member "--shared" *args*)
177                       run-tests-sequential-shared
178                       run-tests-sequential-isolated)))
179        (tests (filter (lambda (arg) (not (string-prefix? arg "--"))) *args*)))
180   (apply runner (append (list (test::scm "setup.scm") (test::scm "finish.scm"))
181                         (map test::scm tests))))