doc: Fix description of the field 11.
[gnupg.git] / tests / gpgscm / tests.scm
1 ;; Common definitions for writing tests.
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 ;; Reporting.
21 (define (echo . msg)
22   (for-each (lambda (x) (display x) (display " ")) msg)
23   (newline))
24
25 (define (info . msg)
26   (apply echo msg)
27   (flush-stdio))
28
29 (define (log . msg)
30   (if (> (*verbose*) 0)
31       (apply info msg)))
32
33 (define (fail . msg)
34   (apply info msg)
35   (exit 1))
36
37 (define (skip . msg)
38   (apply info msg)
39   (exit 77))
40
41 (define (make-counter)
42   (let ((c 0))
43     (lambda ()
44       (let ((r c))
45         (set! c (+ 1 c))
46         r))))
47
48 (define *progress-nesting* 0)
49
50 (define (call-with-progress msg what)
51   (set! *progress-nesting* (+ 1 *progress-nesting*))
52   (if (= 1 *progress-nesting*)
53       (begin
54         (info msg)
55         (display "    > ")
56         (flush-stdio)
57         (what (lambda (item)
58               (display item)
59               (display " ")
60               (flush-stdio)))
61         (info "< "))
62       (begin
63         (what (lambda (item) (display ".") (flush-stdio)))
64         (display " ")
65         (flush-stdio)))
66   (set! *progress-nesting* (- *progress-nesting* 1)))
67
68 (define (for-each-p msg proc lst . lsts)
69   (apply for-each-p' `(,msg ,proc ,(lambda (x . xs) x) ,lst ,@lsts)))
70
71 (define (for-each-p' msg proc fmt lst . lsts)
72   (call-with-progress
73    msg
74    (lambda (progress)
75      (apply for-each
76             `(,(lambda args
77                  (progress (apply fmt args))
78                  (apply proc args))
79               ,lst ,@lsts)))))
80
81 ;; Process management.
82 (define CLOSED_FD -1)
83 (define (call-with-fds what infd outfd errfd)
84   (wait-process (stringify what) (spawn-process-fd what infd outfd errfd) #t))
85 (define (call what)
86   (call-with-fds what
87                  CLOSED_FD
88                  (if (< (*verbose*) 0) STDOUT_FILENO CLOSED_FD)
89                  (if (< (*verbose*) 0) STDERR_FILENO CLOSED_FD)))
90
91 ;; Accessor functions for the results of 'spawn-process'.
92 (define :stdin car)
93 (define :stdout cadr)
94 (define :stderr caddr)
95 (define :pid cadddr)
96
97 (define (call-with-io what in)
98   (let ((h (spawn-process what 0)))
99     (es-write (:stdin h) in)
100     (es-fclose (:stdin h))
101     (let* ((out (es-read-all (:stdout h)))
102            (err (es-read-all (:stderr h)))
103            (result (wait-process (car what) (:pid h) #t)))
104       (es-fclose (:stdout h))
105       (es-fclose (:stderr h))
106       (if (> (*verbose*) 2)
107           (info "Child" (:pid h) "returned:"
108                 `((command ,(stringify what))
109                   (status ,result)
110                   (stdout ,out)
111                   (stderr ,err))))
112       (list result out err))))
113
114 ;; Accessor function for the results of 'call-with-io'.  ':stdout' and
115 ;; ':stderr' can also be used.
116 (define :retcode car)
117
118 (define (call-check what)
119   (let ((result (call-with-io what "")))
120     (if (= 0 (:retcode result))
121         (:stdout result)
122         (throw (string-append (stringify what) " failed")
123                (:stderr result)))))
124
125 (define (call-popen command input-string)
126   (let ((result (call-with-io command input-string)))
127     (if (= 0 (:retcode result))
128         (:stdout result)
129         (throw (:stderr result)))))
130
131 ;;
132 ;; estream helpers.
133 ;;
134
135 (define (es-read-all stream)
136   (let loop
137       ((acc ""))
138     (if (es-feof stream)
139         acc
140         (loop (string-append acc (es-read stream 4096))))))
141
142 ;;
143 ;; File management.
144 ;;
145 (define (file-exists? name)
146   (call-with-input-file name (lambda (port) #t)))
147
148 (define (file=? a b)
149   (file-equal a b #t))
150
151 (define (text-file=? a b)
152   (file-equal a b #f))
153
154 (define (file-copy from to)
155   (catch '() (unlink to))
156   (letfd ((source (open from (logior O_RDONLY O_BINARY)))
157           (sink (open to (logior O_WRONLY O_CREAT O_BINARY) #o600)))
158     (splice source sink)))
159
160 (define (text-file-copy from to)
161   (catch '() (unlink to))
162   (letfd ((source (open from O_RDONLY))
163           (sink (open to (logior O_WRONLY O_CREAT) #o600)))
164     (splice source sink)))
165
166 (define (path-join . components)
167   (let loop ((acc #f) (rest (filter (lambda (s)
168                                       (not (string=? "" s))) components)))
169     (if (null? rest)
170         acc
171         (loop (if (string? acc)
172                   (string-append acc "/" (car rest))
173                   (car rest))
174               (cdr rest)))))
175 (assert (string=? (path-join "foo" "bar" "baz") "foo/bar/baz"))
176 (assert (string=? (path-join "" "bar" "baz") "bar/baz"))
177
178 ;; Is PATH an absolute path?
179 (define (absolute-path? path)
180   (or (char=? #\/ (string-ref path 0))
181       (and *win32* (char=? #\\ (string-ref path 0)))
182       (and *win32*
183            (char-alphabetic? (string-ref path 0))
184            (char=? #\: (string-ref path 1))
185            (or (char=? #\/ (string-ref path 2))
186                (char=? #\\ (string-ref path 2))))))
187
188 ;; Make PATH absolute.
189 (define (canonical-path path)
190   (if (absolute-path? path) path (path-join (getcwd) path)))
191
192 (define (in-srcdir . names)
193   (canonical-path (apply path-join (cons (getenv "abs_top_srcdir") names))))
194
195 ;; Split a list of paths.
196 (define (pathsep-split s)
197   (string-split s *pathsep*))
198
199 ;; Join a list of paths.
200 (define (pathsep-join paths)
201   (foldr (lambda (a b) (string-append a (string *pathsep*) b))
202          (car paths)
203          (cdr paths)))
204
205 ;; Try to find NAME in PATHS.  Returns the full path name on success,
206 ;; or raises an error.
207 (define (path-expand name paths)
208   (let loop ((path paths))
209     (if (null? path)
210         (throw "Could not find" name "in" paths)
211         (let* ((qualified-name (path-join (car path) name))
212                (file-exists (call-with-input-file qualified-name
213                               (lambda (x) #t))))
214           (if file-exists
215               qualified-name
216               (loop (cdr path)))))))
217
218 ;; Expand NAME using the gpgscm load path.  Use like this:
219 ;;   (load (with-path "library.scm"))
220 (define (with-path name)
221   (catch name
222          (path-expand name (pathsep-split (getenv "GPGSCM_PATH")))))
223
224 (define (basename path)
225   (let ((i (string-index path #\/)))
226     (if (equal? i #f)
227         path
228         (basename (substring path (+ 1 i) (string-length path))))))
229
230 (define (basename-suffix path suffix)
231   (basename
232    (if (string-suffix? path suffix)
233        (substring path 0 (- (string-length path) (string-length suffix)))
234        path)))
235
236 (define (dirname path)
237   (let ((i (string-rindex path #\/)))
238     (if i (substring path 0 i) ".")))
239 (assert (string=? "foo/bar" (dirname "foo/bar/baz")))
240
241 ;; Helper for (pipe).
242 (define :read-end car)
243 (define :write-end cadr)
244
245 ;; let-like macro that manages file descriptors.
246 ;;
247 ;; (letfd <bindings> <body>)
248 ;;
249 ;; Bind all variables given in <bindings> and initialize each of them
250 ;; to the given initial value, and close them after evaluating <body>.
251 (define-macro (letfd bindings . body)
252   (let bind ((bindings' bindings))
253     (if (null? bindings')
254         `(begin ,@body)
255         (let* ((binding (car bindings'))
256                (name (car binding))
257                (initializer (cadr binding)))
258           `(let ((,name ,initializer))
259              (finally (close ,name)
260                       ,(bind (cdr bindings'))))))))
261
262 (define-macro (with-working-directory new-directory . expressions)
263   (let ((new-dir (gensym))
264         (old-dir (gensym)))
265     `(let* ((,new-dir ,new-directory)
266             (,old-dir (getcwd)))
267        (dynamic-wind
268            (lambda () (if ,new-dir (chdir ,new-dir)))
269            (lambda () ,@expressions)
270            (lambda () (chdir ,old-dir))))))
271
272 ;; Make a temporary directory.  If arguments are given, they are
273 ;; joined using path-join, and must end in a component ending in
274 ;; "XXXXXX".  If no arguments are given, a suitable location and
275 ;; generic name is used.  Returns an absolute path.
276 (define (mkdtemp . components)
277   (canonical-path (_mkdtemp (if (null? components)
278                                 (path-join
279                                  (get-temp-path)
280                                  (string-append "gpgscm-" (get-isotime) "-"
281                                                 (basename-suffix *scriptname* ".scm")
282                                                 "-XXXXXX"))
283                                 (apply path-join components)))))
284
285 ;; Make a temporary directory and remove it at interpreter shutdown.
286 ;; Note that there are macros that limit the lifetime of temporary
287 ;; directories and files to a lexical scope.  Use those if possible.
288 ;; Otherwise this works like mkdtemp.
289 (define (mkdtemp-autoremove . components)
290   (let ((dir (apply mkdtemp components)))
291     (atexit (lambda () (unlink-recursively dir)))
292     dir))
293
294 (define-macro (with-temporary-working-directory . expressions)
295   (let ((tmp-sym (gensym)))
296     `(let* ((,tmp-sym (mkdtemp)))
297        (finally (unlink-recursively ,tmp-sym)
298                 (with-working-directory ,tmp-sym
299                                         ,@expressions)))))
300
301 (define (make-temporary-file . args)
302   (canonical-path (path-join
303                    (mkdtemp)
304                    (if (null? args) "a" (car args)))))
305
306 (define (remove-temporary-file filename)
307   (catch '()
308     (unlink filename))
309   (let ((dirname (substring filename 0 (string-rindex filename #\/))))
310     (catch (echo "removing temporary directory" dirname "failed")
311       (rmdir dirname))))
312
313 ;; let-like macro that manages temporary files.
314 ;;
315 ;; (lettmp <bindings> <body>)
316 ;;
317 ;; Bind all variables given in <bindings>, initialize each of them to
318 ;; a string representing an unique path in the filesystem, and delete
319 ;; them after evaluating <body>.
320 (define-macro (lettmp bindings . body)
321   (let bind ((bindings' bindings))
322     (if (null? bindings')
323         `(begin ,@body)
324         (let ((name (car bindings'))
325               (rest (cdr bindings')))
326           `(let ((,name (make-temporary-file ,(symbol->string name))))
327              (finally (remove-temporary-file ,name)
328                       ,(bind rest)))))))
329
330 (define (check-execution source transformer)
331   (lettmp (sink)
332           (transformer source sink)))
333
334 (define (check-identity source transformer)
335   (lettmp (sink)
336           (transformer source sink)
337           (if (not (file=? source sink))
338               (fail "mismatch"))))
339
340 ;;
341 ;; Monadic pipe support.
342 ;;
343
344 (define pipeM
345   (package
346    (define (new procs source sink producer)
347      (package
348       (define (dump)
349         (write (list procs source sink producer))
350         (newline))
351       (define (add-proc command pid)
352         (new (cons (list command pid) procs) source sink producer))
353       (define (commands)
354         (map car procs))
355       (define (pids)
356         (map cadr procs))
357       (define (set-source source')
358         (new procs source' sink producer))
359       (define (set-sink sink')
360         (new procs source sink' producer))
361       (define (set-producer producer')
362         (if producer
363             (throw "producer already set"))
364         (new procs source sink producer'))))))
365
366
367 (define (pipe:do . commands)
368   (let loop ((M (pipeM::new '() CLOSED_FD CLOSED_FD #f)) (cmds commands))
369     (if (null? cmds)
370         (begin
371           (if M::producer (M::producer))
372           (if (not (null? M::procs))
373               (let* ((retcodes (wait-processes (map stringify (M::commands))
374                                                (M::pids) #t))
375                      (results (map (lambda (p r) (append p (list r)))
376                                    M::procs retcodes))
377                      (failed (filter (lambda (x) (not (= 0 (caddr x))))
378                                      results)))
379                 (if (not (null? failed))
380                     (throw failed))))) ; xxx nicer reporting
381         (if (and (= 2 (length cmds)) (number? (cadr cmds)))
382             ;; hack: if it's an fd, use it as sink
383             (let ((M' ((car cmds) (M::set-sink (cadr cmds)))))
384               (if (> M::source 2) (close M::source))
385               (if (> (cadr cmds) 2) (close (cadr cmds)))
386               (loop M' '()))
387             (let ((M' ((car cmds) M)))
388               (if (> M::source 2) (close M::source))
389               (loop M' (cdr cmds)))))))
390
391 (define (pipe:open pathname flags)
392   (lambda (M)
393     (M::set-source (open pathname flags))))
394
395 (define (pipe:defer producer)
396   (lambda (M)
397     (let* ((p (outbound-pipe))
398            (M' (M::set-source (:read-end p))))
399       (M'::set-producer (lambda ()
400                           (producer (:write-end p))
401                           (close (:write-end p)))))))
402 (define (pipe:echo data)
403  (pipe:defer (lambda (sink) (display data (fdopen sink "wb")))))
404
405 (define (pipe:spawn command)
406   (lambda (M)
407     (define (do-spawn M new-source)
408       (let ((pid (spawn-process-fd command M::source M::sink
409                                    (if (> (*verbose*) 0)
410                                        STDERR_FILENO CLOSED_FD)))
411             (M' (M::set-source new-source)))
412         (M'::add-proc command pid)))
413     (if (= CLOSED_FD M::sink)
414         (let* ((p (pipe))
415                (M' (do-spawn (M::set-sink (:write-end p)) (:read-end p))))
416           (close (:write-end p))
417           (M'::set-sink CLOSED_FD))
418         (do-spawn M CLOSED_FD))))
419
420 (define (pipe:splice sink)
421   (lambda (M)
422     (splice M::source sink)
423     (M::set-source CLOSED_FD)))
424
425 (define (pipe:write-to pathname flags mode)
426   (open pathname flags mode))
427
428 ;;
429 ;; Monadic transformer support.
430 ;;
431
432 (define (tr:do . commands)
433   (let loop ((tmpfiles '()) (source  #f) (cmds commands))
434     (if (null? cmds)
435         (for-each remove-temporary-file tmpfiles)
436         (let* ((v ((car cmds) tmpfiles source))
437                (tmpfiles' (car v))
438                (sink (cadr v))
439                (error (caddr v)))
440           (if error
441               (begin
442                 (for-each remove-temporary-file tmpfiles')
443                 (apply throw error)))
444           (loop tmpfiles' sink (cdr cmds))))))
445
446 (define (tr:open pathname)
447   (lambda (tmpfiles source)
448     (list tmpfiles pathname #f)))
449
450 (define (tr:spawn input command)
451   (lambda (tmpfiles source)
452     (if (and (member '**in** command) (not source))
453         (fail (string-append (stringify cmd) " needs an input")))
454     (let* ((t (make-temporary-file))
455            (cmd (map (lambda (x)
456                        (cond
457                         ((equal? '**in** x) source)
458                         ((equal? '**out** x) t)
459                         (else x))) command)))
460       (catch (list (cons t tmpfiles) t *error*)
461              (call-popen cmd input)
462              (if (and (member '**out** command) (not (file-exists? t)))
463                  (fail (string-append (stringify cmd)
464                                        " did not produce '" t "'.")))
465              (list (cons t tmpfiles) t #f)))))
466
467 (define (tr:write-to pathname)
468   (lambda (tmpfiles source)
469     (rename source pathname)
470     (list tmpfiles pathname #f)))
471
472 (define (tr:pipe-do . commands)
473   (lambda (tmpfiles source)
474     (let ((t (make-temporary-file)))
475       (apply pipe:do
476         `(,@(if source `(,(pipe:open source (logior O_RDONLY O_BINARY))) '())
477           ,@commands
478           ,(pipe:write-to t (logior O_WRONLY O_BINARY O_CREAT) #o600)))
479       (list (cons t tmpfiles) t #f))))
480
481 (define (tr:assert-identity reference)
482   (lambda (tmpfiles source)
483     (if (not (file=? source reference))
484         (fail "mismatch"))
485     (list tmpfiles source #f)))
486
487 (define (tr:assert-weak-identity reference)
488   (lambda (tmpfiles source)
489     (if (not (text-file=? source reference))
490         (fail "mismatch"))
491     (list tmpfiles source #f)))
492
493 (define (tr:call-with-content function . args)
494   (lambda (tmpfiles source)
495     (catch (list tmpfiles source *error*)
496            (apply function `(,(call-with-input-file source read-all) ,@args)))
497     (list tmpfiles source #f)))
498
499 ;;
500 ;; Developing and debugging tests.
501 ;;
502
503 ;; Spawn an os shell.
504 (define (interactive-shell)
505   (call-with-fds `(,(getenv "SHELL") -i) 0 1 2))
506
507 ;;
508 ;; The main test framework.
509 ;;
510
511 (define semaphore
512   (package
513    (define (new n)
514      (package
515       (define (acquire!?)
516         (if (> n 0)
517             (begin
518               (set! n (- n 1))
519               #t)
520             #f))
521       (define (release!)
522         (set! n (+ n 1)))))))
523
524 ;; A pool of tests.
525 (define test-pool
526   (package
527    (define (new n)
528      (package
529       ;; A semaphore to restrict the number of spawned processes.
530       (define sem (semaphore::new n))
531
532       ;; A list of enqueued, but not yet run tests.
533       (define enqueued '())
534
535       ;; A list of running or finished processes.
536       (define procs '())
537
538       (define (add test)
539         (if (test::started?)
540             (set! procs (cons test procs))
541             (if (sem::acquire!?)
542                 (add (test::run-async))
543                 (set! enqueued (cons test enqueued))))
544         (current-environment))
545
546       ;; Pop the last of the enqueued tests off the fifo queue.
547       (define (pop-test!)
548         (let ((i (length enqueued)))
549           (assert (> i 0))
550           (cond
551            ((= i 1)
552             (let ((test (car enqueued)))
553               (set! enqueued '())
554               test))
555            (else
556             (let* ((tail (list-tail enqueued (- i 2)))
557                    (test (cadr tail)))
558               (set-cdr! tail '())
559               (assert (= (length enqueued) (- i 1)))
560               test)))))
561
562       (define (pid->test pid)
563         (let ((t (filter (lambda (x) (= pid x::pid)) procs)))
564           (if (null? t) #f (car t))))
565       (define (wait)
566         (if (null? enqueued)
567             ;; If no tests are enqueued, we can just block until all
568             ;; of them finished.
569             (wait' #t)
570             ;; Otherwise, we must not block, but give some tests the
571             ;; chance to finish so that we can start new ones.
572             (begin
573               (wait' #f)
574               (usleep (/ 1000000 10))
575               (wait))))
576       (define (wait' hang)
577         (let ((unfinished (filter (lambda (t) (not t::retcode)) procs)))
578           (if (null? unfinished)
579               (current-environment)
580               (let ((names (map (lambda (t) t::name) unfinished))
581                     (pids (map (lambda (t) t::pid) unfinished))
582                     (any #f))
583                 (for-each
584                  (lambda (test retcode)
585                    (unless (< retcode 0)
586                            (test::set-end-time!)
587                            (test:::set! 'retcode retcode)
588                            (test::report)
589                            (sem::release!)
590                            (set! any #t)))
591                  (map pid->test pids)
592                  (wait-processes (map stringify names) pids hang))
593
594                 ;; If some processes finished, try to start new ones.
595                 (let loop ()
596                   (cond
597                    ((not any) #f)
598                    ((pair? enqueued)
599                     (if (sem::acquire!?)
600                         (let ((test (pop-test!)))
601                           (add (test::run-async))
602                           (loop)))))))))
603         (current-environment))
604       (define (filter-tests status)
605         (filter (lambda (p) (eq? status (p::status))) procs))
606       (define (report)
607         (define (print-tests tests message)
608           (unless (null? tests)
609                   (apply echo (cons message
610                                     (map (lambda (t) t::name) tests)))))
611
612         (let ((failed (filter-tests 'FAIL))
613               (xfailed (filter-tests 'XFAIL))
614               (xpassed (filter-tests 'XPASS))
615               (skipped (filter-tests 'SKIP)))
616           (echo "===================")
617           (echo (length procs) "tests run,"
618                 (length (filter-tests 'PASS)) "succeeded,"
619                 (length failed) "failed,"
620                 (length xfailed) "failed expectedly,"
621                 (length xpassed) "succeeded unexpectedly,"
622                 (length skipped) "skipped.")
623           (print-tests failed "Failed tests:")
624           (print-tests xfailed "Expectedly failed tests:")
625           (print-tests xpassed "Unexpectedly passed tests:")
626           (print-tests skipped "Skipped tests:")
627           (echo "===================")
628           (+ (length failed) (length xpassed))))
629
630       (define (xml)
631         (xx::document
632          (xx::tag 'testsuites
633                   `((xmlns:xsi "http://www.w3.org/2001/XMLSchema-instance")
634                     ("xsi:noNamespaceSchemaLocation"
635                      "https://windyroad.com.au/dl/Open%20Source/JUnit.xsd"))
636                   (map (lambda (t) (t::xml)) procs))))))))
637
638 (define (verbosity n)
639   (if (= 0 n) '() (cons '--verbose (verbosity (- n 1)))))
640
641 (define (locate-test path)
642   (if (absolute-path? path) path (in-srcdir path)))
643
644 ;; A single test.
645 (define test
646  (begin
647
648   ;; Private definitions.
649
650   (define (isotime->junit t)
651     "[0-9]{4}-[0-9]{2}-[0-9]{2}T[0-9]{2}:[0-9]{2}:[0-9]{2}"
652     "20170418T145809"
653     (string-append (substring t 0 4)
654                    "-"
655                    (substring t 4 6)
656                    "-"
657                    (substring t 6 11)
658                    ":"
659                    (substring t 11 13)
660                    ":"
661                    (substring t 13 15)))
662
663   ;; If a tests name ends with a bang (!), it is expected to fail.
664   (define (expect-failure? name)
665     (string-suffix? name "!"))
666   ;; Strips the bang (if any).
667   (define (test-name name)
668     (if (expect-failure? name)
669         (substring name 0 (- (string-length name) 1))
670         name))
671
672   (package
673    (define (scm setup name path . args)
674      ;; Start the process.
675      (define (spawn-scm args' in out err)
676        (spawn-process-fd `(,*argv0* ,@(verbosity (*verbose*))
677                                     ,(locate-test (test-name path))
678                                     ,@(if setup (force setup) '())
679                                     ,@args' ,@args) in out err))
680      (new name #f spawn-scm #f #f CLOSED_FD (expect-failure? name)))
681
682    (define (binary setup name path . args)
683      ;; Start the process.
684      (define (spawn-binary args' in out err)
685        (spawn-process-fd `(,(test-name path)
686                            ,@(if setup (force setup) '()) ,@args' ,@args)
687                          in out err))
688      (new name #f spawn-binary #f #f CLOSED_FD (expect-failure? name)))
689
690    (define (new name directory spawn pid retcode logfd expect-failure)
691      (package
692
693       ;; XXX: OO glue.
694       (define self (current-environment))
695       (define (:set! key value)
696         (eval `(set! ,key ,value) (current-environment))
697         (current-environment))
698
699       ;; The log is written here.
700       (define log-file-name #f)
701
702       ;; Record time stamps.
703       (define timestamp #f)
704       (define start-time 0)
705       (define end-time 0)
706
707       (define (set-start-time!)
708         (set! timestamp (isotime->junit (get-isotime)))
709         (set! start-time (get-time)))
710       (define (set-end-time!)
711         (set! end-time (get-time)))
712
713       ;; Has the test been started yet?
714       (define (started?)
715         (number? pid))
716
717       (define (open-log-file)
718         (unless log-file-name
719                 (set! log-file-name (string-append (basename name) ".log")))
720         (catch '() (unlink log-file-name))
721         (open log-file-name (logior O_RDWR O_BINARY O_CREAT) #o600))
722
723       (define (run-sync . args)
724         (set-start-time!)
725         (letfd ((log (open-log-file)))
726           (with-working-directory directory
727             (let* ((p (inbound-pipe))
728                    (pid' (spawn args 0 (:write-end p) (:write-end p))))
729               (close (:write-end p))
730               (splice (:read-end p) STDERR_FILENO log)
731               (close (:read-end p))
732               (set! pid pid')
733               (set! retcode (wait-process name pid' #t)))))
734         (report)
735         (current-environment))
736       (define (run-sync-quiet . args)
737         (set-start-time!)
738         (with-working-directory directory
739           (set! pid (spawn args CLOSED_FD CLOSED_FD CLOSED_FD)))
740         (set! retcode (wait-process name pid #t))
741         (set-end-time!)
742         (current-environment))
743       (define (run-async . args)
744         (set-start-time!)
745         (let ((log (open-log-file)))
746           (with-working-directory directory
747             (set! pid (spawn args CLOSED_FD log log)))
748           (set! logfd log))
749         (current-environment))
750       (define (status)
751         (let* ((t' (assoc retcode '((0 PASS) (77 SKIP) (99 ERROR))))
752                (t (if (not t') 'FAIL (cadr t'))))
753           (if expect-failure
754               (case t ((PASS) 'XPASS) ((FAIL) 'XFAIL) (else t))
755               t)))
756       (define (status-string)
757         (cadr (assoc (status) '((PASS "PASS")
758                                (SKIP "SKIP")
759                                (ERROR "ERROR")
760                                (FAIL "FAIL")
761                                (XPASS "XPASS")
762                                (XFAIL "XFAIL")))))
763       (define (report)
764         (unless (= logfd CLOSED_FD)
765                 (seek logfd 0 SEEK_SET)
766                 (splice logfd STDERR_FILENO)
767                 (close logfd))
768         (echo (string-append (status-string) ":") name))
769
770       (define (xml)
771         (xx::tag
772          'testsuite
773          `((name ,name)
774            (time ,(- end-time start-time))
775            (package ,(dirname name))
776            (id 0)
777            (timestamp ,timestamp)
778            (hostname "unknown")
779            (tests 1)
780            (failures ,(if (eq? FAIL (status)) 1 0))
781            (errors ,(if (eq? ERROR (status)) 1 0)))
782          (list
783           (xx::tag 'properties)
784           (xx::tag 'testcase
785                    `((name ,(basename name))
786                      (classname ,(string-translate (dirname name) "/" "."))
787                      (time ,(- end-time start-time)))
788                    `(,@(case (status)
789                          ((PASS XFAIL) '())
790                          ((SKIP) (list (xx::tag 'skipped)))
791                          ((ERROR) (list
792                                    (xx::tag 'error '((message "Unknown error.")))))
793                          (else
794                           (list (xx::tag 'failure '((message "Unknown error."))))))))
795           (xx::tag 'system-out '()
796                    (list (xx::textnode (read-all (open-input-file log-file-name)))))
797           (xx::tag 'system-err '() (list (xx::textnode "")))))))))))
798
799 ;; Run the setup target to create an environment, then run all given
800 ;; tests in parallel.
801 (define (run-tests-parallel tests n)
802   (let loop ((pool (test-pool::new n)) (tests' tests))
803     (if (null? tests')
804         (let ((results (pool::wait)))
805           ((results::xml) (open-output-file "report.xml"))
806           (exit (results::report)))
807         (let ((wd (mkdtemp-autoremove))
808               (test (car tests')))
809           (test:::set! 'directory wd)
810           (loop (pool::add test)
811                 (cdr tests'))))))
812
813 ;; Run the setup target to create an environment, then run all given
814 ;; tests in sequence.
815 (define (run-tests-sequential tests)
816   (let loop ((pool (test-pool::new 1)) (tests' tests))
817     (if (null? tests')
818         (let ((results (pool::wait)))
819           ((results::xml) (open-output-file "report.xml"))
820           (exit (results::report)))
821         (let ((wd (mkdtemp-autoremove))
822               (test (car tests')))
823           (test:::set! 'directory wd)
824           (loop (pool::add (test::run-sync))
825                 (cdr tests'))))))
826
827 ;; Run tests either in sequence or in parallel, depending on the
828 ;; number of tests and the command line flags.
829 (define (run-tests tests)
830   (let ((parallel (flag "--parallel" *args*))
831         (default-parallel-jobs 32))
832     (if (and parallel (> (length tests) 1))
833         (run-tests-parallel tests (if (and (pair? parallel)
834                                            (string->number (car parallel)))
835                                       (string->number (car parallel))
836                                       default-parallel-jobs))
837         (run-tests-sequential tests))))
838
839 ;; Load all tests from the given path.
840 (define (load-tests . path)
841   (load (apply in-srcdir `(,@path "all-tests.scm")))
842   all-tests)
843
844 ;; Helper to create environment caches from test functions.  SETUP
845 ;; must be a test implementing the producer side cache protocol.
846 ;; Returns a promise containing the arguments that must be passed to a
847 ;; test implementing the consumer side of the cache protocol.
848 (define (make-environment-cache setup)
849   (delay (with-temporary-working-directory
850           (let ((tarball (make-temporary-file "environment-cache")))
851             (atexit (lambda () (remove-temporary-file tarball)))
852             (setup::run-sync '--create-tarball tarball)
853             (if (not (equal? 'PASS (setup::status)))
854                 (fail "Setup failed."))
855             `(--unpack-tarball ,tarball)))))
856
857 ;; Command line flag handling.  Returns the elements following KEY in
858 ;; ARGUMENTS up to the next argument, or #f if KEY is not in
859 ;; ARGUMENTS.  If 'KEY=XYZ' is encountered, then the singleton list
860 ;; containing 'XYZ' is returned.
861 (define (flag key arguments)
862   (cond
863    ((null? arguments)
864     #f)
865    ((string=? key (car arguments))
866     (let loop ((acc '())
867                (args (cdr arguments)))
868       (if (or (null? args) (string-prefix? (car args) "--"))
869           (reverse acc)
870           (loop (cons (car args) acc) (cdr args)))))
871    ((string-prefix? (car arguments) (string-append key "="))
872     (list (substring (car arguments)
873                      (+ (string-length key) 1)
874                      (string-length (car arguments)))))
875    ((string=? "--" (car arguments))
876     #f)
877    (else
878     (flag key (cdr arguments)))))
879 (assert (equal? (flag "--xxx" '("--yyy")) #f))
880 (assert (equal? (flag "--xxx" '("--xxx")) '()))
881 (assert (equal? (flag "--xxx" '("--xxx" "yyy")) '("yyy")))
882 (assert (equal? (flag "--xxx" '("--xxx=foo" "yyy")) '("foo")))
883 (assert (equal? (flag "--xxx" '("--xxx" "yyy" "zzz")) '("yyy" "zzz")))
884 (assert (equal? (flag "--xxx" '("--xxx" "yyy" "zzz" "--")) '("yyy" "zzz")))
885 (assert (equal? (flag "--xxx" '("--xxx" "yyy" "--" "zzz")) '("yyy")))
886 (assert (equal? (flag "--" '("--" "xxx" "yyy" "--" "zzz")) '("xxx" "yyy")))