40ba7e394f613f26d491e145a6b1a79a457110ca
[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 (length procs) "tests run,"
617                 (length (filter-tests 'PASS)) "succeeded,"
618                 (length failed) "failed,"
619                 (length xfailed) "failed expectedly,"
620                 (length xpassed) "succeeded unexpectedly,"
621                 (length skipped) "skipped.")
622           (print-tests failed "Failed tests:")
623           (print-tests xfailed "Expectedly failed tests:")
624           (print-tests xpassed "Unexpectedly passed tests:")
625           (print-tests skipped "Skipped tests:")
626           (+ (length failed) (length xpassed))))
627
628       (define (xml)
629         (xx::document
630          (xx::tag 'testsuites
631                   `((xmlns:xsi "http://www.w3.org/2001/XMLSchema-instance")
632                     ("xsi:noNamespaceSchemaLocation"
633                      "https://windyroad.com.au/dl/Open%20Source/JUnit.xsd"))
634                   (map (lambda (t) (t::xml)) procs))))))))
635
636 (define (verbosity n)
637   (if (= 0 n) '() (cons '--verbose (verbosity (- n 1)))))
638
639 (define (locate-test path)
640   (if (absolute-path? path) path (in-srcdir path)))
641
642 ;; A single test.
643 (define test
644  (begin
645
646   ;; Private definitions.
647
648   (define (isotime->junit t)
649     "[0-9]{4}-[0-9]{2}-[0-9]{2}T[0-9]{2}:[0-9]{2}:[0-9]{2}"
650     "20170418T145809"
651     (string-append (substring t 0 4)
652                    "-"
653                    (substring t 4 6)
654                    "-"
655                    (substring t 6 11)
656                    ":"
657                    (substring t 11 13)
658                    ":"
659                    (substring t 13 15)))
660
661   ;; If a tests name ends with a bang (!), it is expected to fail.
662   (define (expect-failure? name)
663     (string-suffix? name "!"))
664   ;; Strips the bang (if any).
665   (define (test-name name)
666     (if (expect-failure? name)
667         (substring name 0 (- (string-length name) 1))
668         name))
669
670   (package
671    (define (scm setup name path . args)
672      ;; Start the process.
673      (define (spawn-scm args' in out err)
674        (spawn-process-fd `(,*argv0* ,@(verbosity (*verbose*))
675                                     ,(locate-test (test-name path))
676                                     ,@(if setup (force setup) '())
677                                     ,@args' ,@args) in out err))
678      (new name #f spawn-scm #f #f CLOSED_FD (expect-failure? name)))
679
680    (define (binary setup name path . args)
681      ;; Start the process.
682      (define (spawn-binary args' in out err)
683        (spawn-process-fd `(,(test-name path)
684                            ,@(if setup (force setup) '()) ,@args' ,@args)
685                          in out err))
686      (new name #f spawn-binary #f #f CLOSED_FD (expect-failure? name)))
687
688    (define (new name directory spawn pid retcode logfd expect-failure)
689      (package
690
691       ;; XXX: OO glue.
692       (define self (current-environment))
693       (define (:set! key value)
694         (eval `(set! ,key ,value) (current-environment))
695         (current-environment))
696
697       ;; The log is written here.
698       (define log-file-name #f)
699
700       ;; Record time stamps.
701       (define timestamp #f)
702       (define start-time 0)
703       (define end-time 0)
704
705       (define (set-start-time!)
706         (set! timestamp (isotime->junit (get-isotime)))
707         (set! start-time (get-time)))
708       (define (set-end-time!)
709         (set! end-time (get-time)))
710
711       ;; Has the test been started yet?
712       (define (started?)
713         (number? pid))
714
715       (define (open-log-file)
716         (unless log-file-name
717                 (set! log-file-name (string-append (basename name) ".log")))
718         (catch '() (unlink log-file-name))
719         (open log-file-name (logior O_RDWR O_BINARY O_CREAT) #o600))
720
721       (define (run-sync . args)
722         (set-start-time!)
723         (letfd ((log (open-log-file)))
724           (with-working-directory directory
725             (let* ((p (inbound-pipe))
726                    (pid' (spawn args 0 (:write-end p) (:write-end p))))
727               (close (:write-end p))
728               (splice (:read-end p) STDERR_FILENO log)
729               (close (:read-end p))
730               (set! pid pid')
731               (set! retcode (wait-process name pid' #t)))))
732         (report)
733         (current-environment))
734       (define (run-sync-quiet . args)
735         (set-start-time!)
736         (with-working-directory directory
737           (set! pid (spawn args CLOSED_FD CLOSED_FD CLOSED_FD)))
738         (set! retcode (wait-process name pid #t))
739         (set-end-time!)
740         (current-environment))
741       (define (run-async . args)
742         (set-start-time!)
743         (let ((log (open-log-file)))
744           (with-working-directory directory
745             (set! pid (spawn args CLOSED_FD log log)))
746           (set! logfd log))
747         (current-environment))
748       (define (status)
749         (let* ((t' (assoc retcode '((0 PASS) (77 SKIP) (99 ERROR))))
750                (t (if (not t') 'FAIL (cadr t'))))
751           (if expect-failure
752               (case t ((PASS) 'XPASS) ((FAIL) 'XFAIL) (else t))
753               t)))
754       (define (status-string)
755         (cadr (assoc (status) '((PASS "PASS")
756                                (SKIP "SKIP")
757                                (ERROR "ERROR")
758                                (FAIL "FAIL")
759                                (XPASS "XPASS")
760                                (XFAIL "XFAIL")))))
761       (define (report)
762         (unless (= logfd CLOSED_FD)
763                 (seek logfd 0 SEEK_SET)
764                 (splice logfd STDERR_FILENO)
765                 (close logfd))
766         (echo (string-append (status-string) ":") name))
767
768       (define (xml)
769         (xx::tag
770          'testsuite
771          `((name ,name)
772            (time ,(- end-time start-time))
773            (package ,(dirname name))
774            (id 0)
775            (timestamp ,timestamp)
776            (hostname "unknown")
777            (tests 1)
778            (failures ,(if (eq? FAIL (status)) 1 0))
779            (errors ,(if (eq? ERROR (status)) 1 0)))
780          (list
781           (xx::tag 'properties)
782           (xx::tag 'testcase
783                    `((name ,(basename name))
784                      (classname ,(string-translate (dirname name) "/" "."))
785                      (time ,(- end-time start-time)))
786                    `(,@(case (status)
787                          ((PASS XFAIL) '())
788                          ((SKIP) (list (xx::tag 'skipped)))
789                          ((ERROR) (list
790                                    (xx::tag 'error '((message "Unknown error.")))))
791                          (else
792                           (list (xx::tag 'failure '((message "Unknown error."))))))))
793           (xx::tag 'system-out '()
794                    (list (xx::textnode (read-all (open-input-file log-file-name)))))
795           (xx::tag 'system-err '() (list (xx::textnode "")))))))))))
796
797 ;; Run the setup target to create an environment, then run all given
798 ;; tests in parallel.
799 (define (run-tests-parallel tests n)
800   (let loop ((pool (test-pool::new n)) (tests' tests))
801     (if (null? tests')
802         (let ((results (pool::wait)))
803           ((results::xml) (open-output-file "report.xml"))
804           (exit (results::report)))
805         (let ((wd (mkdtemp-autoremove))
806               (test (car tests')))
807           (test:::set! 'directory wd)
808           (loop (pool::add test)
809                 (cdr tests'))))))
810
811 ;; Run the setup target to create an environment, then run all given
812 ;; tests in sequence.
813 (define (run-tests-sequential tests)
814   (let loop ((pool (test-pool::new 1)) (tests' tests))
815     (if (null? tests')
816         (let ((results (pool::wait)))
817           ((results::xml) (open-output-file "report.xml"))
818           (exit (results::report)))
819         (let ((wd (mkdtemp-autoremove))
820               (test (car tests')))
821           (test:::set! 'directory wd)
822           (loop (pool::add (test::run-sync))
823                 (cdr tests'))))))
824
825 ;; Run tests either in sequence or in parallel, depending on the
826 ;; number of tests and the command line flags.
827 (define (run-tests tests)
828   (let ((parallel (flag "--parallel" *args*))
829         (default-parallel-jobs 32))
830     (if (and parallel (> (length tests) 1))
831         (run-tests-parallel tests (if (and (pair? parallel)
832                                            (string->number (car parallel)))
833                                       (string->number (car parallel))
834                                       default-parallel-jobs))
835         (run-tests-sequential tests))))
836
837 ;; Load all tests from the given path.
838 (define (load-tests . path)
839   (load (apply in-srcdir `(,@path "all-tests.scm")))
840   all-tests)
841
842 ;; Helper to create environment caches from test functions.  SETUP
843 ;; must be a test implementing the producer side cache protocol.
844 ;; Returns a promise containing the arguments that must be passed to a
845 ;; test implementing the consumer side of the cache protocol.
846 (define (make-environment-cache setup)
847   (delay (with-temporary-working-directory
848           (let ((tarball (make-temporary-file "environment-cache")))
849             (atexit (lambda () (remove-temporary-file tarball)))
850             (setup::run-sync '--create-tarball tarball)
851             (if (not (equal? 'PASS (setup::status)))
852                 (fail "Setup failed."))
853             `(--unpack-tarball ,tarball)))))
854
855 ;; Command line flag handling.  Returns the elements following KEY in
856 ;; ARGUMENTS up to the next argument, or #f if KEY is not in
857 ;; ARGUMENTS.  If 'KEY=XYZ' is encountered, then the singleton list
858 ;; containing 'XYZ' is returned.
859 (define (flag key arguments)
860   (cond
861    ((null? arguments)
862     #f)
863    ((string=? key (car arguments))
864     (let loop ((acc '())
865                (args (cdr arguments)))
866       (if (or (null? args) (string-prefix? (car args) "--"))
867           (reverse acc)
868           (loop (cons (car args) acc) (cdr args)))))
869    ((string-prefix? (car arguments) (string-append key "="))
870     (list (substring (car arguments)
871                      (+ (string-length key) 1)
872                      (string-length (car arguments)))))
873    ((string=? "--" (car arguments))
874     #f)
875    (else
876     (flag key (cdr arguments)))))
877 (assert (equal? (flag "--xxx" '("--yyy")) #f))
878 (assert (equal? (flag "--xxx" '("--xxx")) '()))
879 (assert (equal? (flag "--xxx" '("--xxx" "yyy")) '("yyy")))
880 (assert (equal? (flag "--xxx" '("--xxx=foo" "yyy")) '("foo")))
881 (assert (equal? (flag "--xxx" '("--xxx" "yyy" "zzz")) '("yyy" "zzz")))
882 (assert (equal? (flag "--xxx" '("--xxx" "yyy" "zzz" "--")) '("yyy" "zzz")))
883 (assert (equal? (flag "--xxx" '("--xxx" "yyy" "--" "zzz")) '("yyy")))
884 (assert (equal? (flag "--" '("--" "xxx" "yyy" "--" "zzz")) '("xxx" "yyy")))