23ff8a2b0dabe3a7c9add99da186132b84613319
[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         (letfd ((log (open (string-append name ".log")
87                            (logior O_WRONLY O_BINARY O_CREAT) #o600)))
88           (with-working-directory directory
89             (let* ((p (inbound-pipe))
90                    (pid (spawn-process-fd (append command args) 0
91                                           (:write-end p) (:write-end p))))
92               (close (:write-end p))
93               (splice (:read-end p) STDERR_FILENO log)
94               (close (:read-end p))
95               (let ((t' (set-retcode (wait-process name pid #t))))
96                 (t'::report)
97                 t')))))
98       (define (run-sync-quiet . args)
99         (with-working-directory directory
100           (set-retcode
101            (wait-process
102             name (spawn-process-fd (append command args)
103                                    CLOSED_FD CLOSED_FD CLOSED_FD) #t))))
104       (define (run-async . args)
105         (with-working-directory directory
106           (set-pid (spawn-process-fd (append command args)
107                                      CLOSED_FD CLOSED_FD CLOSED_FD))))
108       (define (status)
109         (let ((t (assoc retcode '((0 "PASS") (77 "SKIP") (99 "ERROR")))))
110           (if (not t) "FAIL" (cadr t))))
111       (define (report)
112         (echo (string-append (status retcode) ":") name))))))
113
114 (define (run-tests-parallel setup tests)
115   (lettmp (gpghome-tar)
116     (setup::run-sync '--create-tarball gpghome-tar)
117     (let loop ((pool (test-pool::new '())) (tests' tests))
118       (if (null? tests')
119           (let ((results (pool::wait)))
120             (for-each (lambda (t)
121                         (catch (echo "Removing" t::directory "failed:" *error*)
122                                (unlink-recursively t::directory))
123                         (t::report)) results::procs)
124             (exit (results::report)))
125           (let* ((wd (mkdtemp))
126                  (test (car tests'))
127                  (test' (test::set-directory wd)))
128             (loop (pool::add (test'::run-async '--unpack-tarball gpghome-tar))
129                   (cdr tests')))))))
130
131 (define (run-tests-sequential setup tests)
132   (lettmp (gpghome-tar)
133     (setup::run-sync '--create-tarball gpghome-tar)
134     (let loop ((pool (test-pool::new '())) (tests' tests))
135       (if (null? tests')
136           (let ((results (pool::wait)))
137             (for-each (lambda (t)
138                         (catch (echo "Removing" t::directory "failed:" *error*)
139                                (unlink-recursively t::directory)))
140                       results::procs)
141             (exit (results::report)))
142           (let* ((wd (mkdtemp))
143                  (test (car tests'))
144                  (test' (test::set-directory wd)))
145             (loop (pool::add (test'::run-sync '--unpack-tarball gpghome-tar))
146                   (cdr tests')))))))
147
148 (let* ((runner (if (member "--parallel" *args*)
149                    run-tests-parallel
150                    run-tests-sequential))
151        (tests (filter (lambda (arg) (not (string-prefix? arg "--"))) *args*)))
152   (runner (test::scm "setup.scm") (map test::scm tests)))