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 ;; Trace displays and returns the given value.  A debugging aid.
  21 (define (trace x)
  22   (display x)
  23   (newline)
  24   x)
  25
  26 ;; Stringification.
  27 (define (stringify expression)
  28   (let ((p (open-output-string)))
  29     (write expression p)
  30     (get-output-string p)))
  31
  32 ;; Reporting.
  33 (define (echo . msg)
  34   (for-each (lambda (x) (display x) (display " ")) msg)
  35   (newline))
  36
  37 (define (info . msg)
  38   (apply echo msg)
  39   (flush-stdio))
  40
  41 (define (log . msg)
  42   (if (> (*verbose*) 0)
  43       (apply info msg)))
  44
  45 (define (fail . msg)
  46   (apply info msg)
  47   (exit 1))
  48
  49 (define (skip . msg)
  50   (apply info msg)
  51   (exit 77))
  52
  53 (define (make-counter)
  54   (let ((c 0))
  55     (lambda ()
  56       (let ((r c))
  57         (set! c (+ 1 c))
  58         r))))
  59
  60 (define *progress-nesting* 0)
  61
  62 (define (call-with-progress msg what)
  63   (set! *progress-nesting* (+ 1 *progress-nesting*))
  64   (if (= 1 *progress-nesting*)
  65       (begin
  66         (info msg)
  67         (display "    > ")
  68         (flush-stdio)
  69         (what (lambda (item)
  70               (display item)
  71               (display " ")
  72               (flush-stdio)))
  73         (info "< "))
  74       (begin
  75         (what (lambda (item) (display ".") (flush-stdio)))
  76         (display " ")
  77         (flush-stdio)))
  78   (set! *progress-nesting* (- *progress-nesting* 1)))
  79
  80 (define (for-each-p msg proc lst . lsts)
  81   (apply for-each-p' `(,msg ,proc ,(lambda (x . xs) x) ,lst ,@lsts)))
  82
  83 (define (for-each-p' msg proc fmt lst . lsts)
  84   (call-with-progress
  85    msg
  86    (lambda (progress)
  87      (apply for-each
  88             `(,(lambda args
  89                  (progress (apply fmt args))
  90                  (apply proc args))
  91               ,lst ,@lsts)))))
  92
  93 ;; Process management.
  94 (define CLOSED_FD -1)
  95 (define (call-with-fds what infd outfd errfd)
  96   (wait-process (stringify what) (spawn-process-fd what infd outfd errfd) #t))
  97 (define (call what)
  98   (call-with-fds what
  99                  CLOSED_FD
 100                  (if (< (*verbose*) 0) STDOUT_FILENO CLOSED_FD)
 101                  (if (< (*verbose*) 0) STDERR_FILENO CLOSED_FD)))
 102
 103 ;; Accessor functions for the results of 'spawn-process'.
 104 (define :stdin car)
 105 (define :stdout cadr)
 106 (define :stderr caddr)
 107 (define :pid cadddr)
 108
 109 (define (call-with-io what in)
 110   (let ((h (spawn-process what 0)))
 111     (es-write (:stdin h) in)
 112     (es-fclose (:stdin h))
 113     (let* ((out (es-read-all (:stdout h)))
 114            (err (es-read-all (:stderr h)))
 115            (result (wait-process (car what) (:pid h) #t)))
 116       (es-fclose (:stdout h))
 117       (es-fclose (:stderr h))
 118       (if (> (*verbose*) 2)
 119           (begin
 120             (echo (stringify what) "returned:" result)
 121             (echo (stringify what) "wrote to stdout:" out)
 122             (echo (stringify what) "wrote to stderr:" err)))
 123       (list result out err))))
 124
 125 ;; Accessor function for the results of 'call-with-io'.  ':stdout' and
 126 ;; ':stderr' can also be used.
 127 (define :retcode car)
 128
 129 (define (call-check what)
 130   (let ((result (call-with-io what "")))
 131     (if (= 0 (:retcode result))
 132         (:stdout result)
 133         (throw (string-append (stringify what) " failed")
 134                (:stderr result)))))
 135
 136 (define (call-popen command input-string)
 137   (let ((result (call-with-io command input-string)))
 138     (if (= 0 (:retcode result))
 139         (:stdout result)
 140         (throw (:stderr result)))))
 141
 142 ;;
 143 ;; estream helpers.
 144 ;;
 145
 146 (define (es-read-all stream)
 147   (let loop
 148       ((acc ""))
 149     (if (es-feof stream)
 150         acc
 151         (loop (string-append acc (es-read stream 4096))))))
 152
 153 ;;
 154 ;; File management.
 155 ;;
 156 (define (file-exists? name)
 157   (call-with-input-file name (lambda (port) #t)))
 158
 159 (define (file=? a b)
 160   (file-equal a b #t))
 161
 162 (define (text-file=? a b)
 163   (file-equal a b #f))
 164
 165 (define (file-copy from to)
 166   (catch '() (unlink to))
 167   (letfd ((source (open from (logior O_RDONLY O_BINARY)))
 168           (sink (open to (logior O_WRONLY O_CREAT O_BINARY) #o600)))
 169     (splice source sink)))
 170
 171 (define (text-file-copy from to)
 172   (catch '() (unlink to))
 173   (letfd ((source (open from O_RDONLY))
 174           (sink (open to (logior O_WRONLY O_CREAT) #o600)))
 175     (splice source sink)))
 176
 177 (define (path-join . components)
 178   (let loop ((acc #f) (rest (filter (lambda (s)
 179                                       (not (string=? "" s))) components)))
 180     (if (null? rest)
 181         acc
 182         (loop (if (string? acc)
 183                   (string-append acc "/" (car rest))
 184                   (car rest))
 185               (cdr rest)))))
 186 (assert (string=? (path-join "foo" "bar" "baz") "foo/bar/baz"))
 187 (assert (string=? (path-join "" "bar" "baz") "bar/baz"))
 188
 189 ;; Is PATH an absolute path?
 190 (define (absolute-path? path)
 191   (or (char=? #\/ (string-ref path 0))
 192       (and *win32* (char=? #\\ (string-ref path 0)))
 193       (and *win32*
 194            (char-alphabetic? (string-ref path 0))
 195            (char=? #\: (string-ref path 1))
 196            (or (char=? #\/ (string-ref path 2))
 197                (char=? #\\ (string-ref path 2))))))
 198
 199 ;; Make PATH absolute.
 200 (define (canonical-path path)
 201   (if (absolute-path? path) path (path-join (getcwd) path)))
 202
 203 (define (in-srcdir . names)
 204   (canonical-path (apply path-join (cons (getenv "srcdir") names))))
 205
 206 ;; Try to find NAME in PATHS.  Returns the full path name on success,
 207 ;; or raises an error.
 208 (define (path-expand name paths)
 209   (let loop ((path paths))
 210     (if (null? path)
 211         (throw "Could not find" name "in" paths)
 212         (let* ((qualified-name (path-join (car path) name))
 213                (file-exists (call-with-input-file qualified-name
 214                               (lambda (x) #t))))
 215           (if file-exists
 216               qualified-name
 217               (loop (cdr path)))))))
 218
 219 ;; Expand NAME using the gpgscm load path.  Use like this:
 220 ;;   (load (with-path "library.scm"))
 221 (define (with-path name)
 222   (catch name
 223          (path-expand name (string-split (getenv "GPGSCM_PATH") *pathsep*))))
 224
 225 (define (basename path)
 226   (let ((i (string-index path #\/)))
 227     (if (equal? i #f)
 228         path
 229         (basename (substring path (+ 1 i) (string-length path))))))
 230
 231 (define (basename-suffix path suffix)
 232   (basename
 233    (if (string-suffix? path suffix)
 234        (substring path 0 (- (string-length path) (string-length suffix)))
 235        path)))
 236
 237 ;; Helper for (pipe).
 238 (define :read-end car)
 239 (define :write-end cadr)
 240
 241 ;; let-like macro that manages file descriptors.
 242 ;;
 243 ;; (letfd <bindings> <body>)
 244 ;;
 245 ;; Bind all variables given in <bindings> and initialize each of them
 246 ;; to the given initial value, and close them after evaluting <body>.
 247 (macro (letfd form)
 248   (let ((result-sym (gensym)))
 249     `((lambda (,(caaadr form))
 250         (let ((,result-sym
 251                ,(if (= 1 (length (cadr form)))
 252                     `(catch (begin (close ,(caaadr form))
 253                                    (rethrow *error*))
 254                             ,@(cddr form))
 255                     `(letfd ,(cdadr form) ,@(cddr form)))))
 256           (close ,(caaadr form))
 257           ,result-sym)) ,@(cdaadr form))))
 258
 259 (macro (with-working-directory form)
 260   (let ((result-sym (gensym)) (cwd-sym (gensym)))
 261     `(let* ((,cwd-sym (getcwd))
 262             (_ (if ,(cadr form) (chdir ,(cadr form))))
 263             (,result-sym (catch (begin (chdir ,cwd-sym)
 264                                        (rethrow *error*))
 265                                 ,@(cddr form))))
 266        (chdir ,cwd-sym)
 267        ,result-sym)))
 268
 269 ;; Make a temporary directory.  If arguments are given, they are
 270 ;; joined using path-join, and must end in a component ending in
 271 ;; "XXXXXX".  If no arguments are given, a suitable location and
 272 ;; generic name is used.
 273 (define (mkdtemp . components)
 274   (_mkdtemp (if (null? components)
 275                 (path-join (getenv "TMP")
 276                            (string-append "gpgscm-" (get-isotime) "-"
 277                                           (basename-suffix *scriptname* ".scm")
 278                                           "-XXXXXX"))
 279                 (apply path-join components))))
 280
 281 (macro (with-temporary-working-directory form)
 282   (let ((result-sym (gensym)) (cwd-sym (gensym)) (tmp-sym (gensym)))
 283     `(let* ((,cwd-sym (getcwd))
 284             (,tmp-sym (mkdtemp))
 285             (_ (chdir ,tmp-sym))
 286             (,result-sym (catch (begin (chdir ,cwd-sym)
 287                                        (unlink-recursively ,tmp-sym)
 288                                        (rethrow *error*))
 289                                 ,@(cdr form))))
 290        (chdir ,cwd-sym)
 291        (unlink-recursively ,tmp-sym)
 292        ,result-sym)))
 293
 294 (define (make-temporary-file . args)
 295   (canonical-path (path-join
 296                    (mkdtemp)
 297                    (if (null? args) "a" (car args)))))
 298
 299 (define (remove-temporary-file filename)
 300   (catch '()
 301     (unlink filename))
 302   (let ((dirname (substring filename 0 (string-rindex filename #\/))))
 303     (catch (echo "removing temporary directory" dirname "failed")
 304       (rmdir dirname))))
 305
 306 ;; let-like macro that manages temporary files.
 307 ;;
 308 ;; (lettmp <bindings> <body>)
 309 ;;
 310 ;; Bind all variables given in <bindings>, initialize each of them to
 311 ;; a string representing an unique path in the filesystem, and delete
 312 ;; them after evaluting <body>.
 313 (macro (lettmp form)
 314   (let ((result-sym (gensym)))
 315     `((lambda (,(caadr form))
 316         (let ((,result-sym
 317                ,(if (= 1 (length (cadr form)))
 318                     `(catch (begin (remove-temporary-file ,(caadr form))
 319                                    (rethrow *error*))
 320                             ,@(cddr form))
 321                     `(lettmp ,(cdadr form) ,@(cddr form)))))
 322           (remove-temporary-file ,(caadr form))
 323           ,result-sym)) (make-temporary-file ,(symbol->string (caadr form))))))
 324
 325 (define (check-execution source transformer)
 326   (lettmp (sink)
 327           (transformer source sink)))
 328
 329 (define (check-identity source transformer)
 330   (lettmp (sink)
 331           (transformer source sink)
 332           (if (not (file=? source sink))
 333               (fail "mismatch"))))
 334
 335 ;;
 336 ;; Monadic pipe support.
 337 ;;
 338
 339 (define pipeM
 340   (package
 341    (define (new procs source sink producer)
 342      (package
 343       (define (dump)
 344         (write (list procs source sink producer))
 345         (newline))
 346       (define (add-proc command pid)
 347         (new (cons (list command pid) procs) source sink producer))
 348       (define (commands)
 349         (map car procs))
 350       (define (pids)
 351         (map cadr procs))
 352       (define (set-source source')
 353         (new procs source' sink producer))
 354       (define (set-sink sink')
 355         (new procs source sink' producer))
 356       (define (set-producer producer')
 357         (if producer
 358             (throw "producer already set"))
 359         (new procs source sink producer'))))))
 360
 361
 362 (define (pipe:do . commands)
 363   (let loop ((M (pipeM::new '() CLOSED_FD CLOSED_FD #f)) (cmds commands))
 364     (if (null? cmds)
 365         (begin
 366           (if M::producer (M::producer))
 367           (if (not (null? M::procs))
 368               (let* ((retcodes (wait-processes (map stringify (M::commands))
 369                                                (M::pids) #t))
 370                      (results (map (lambda (p r) (append p (list r)))
 371                                    M::procs retcodes))
 372                      (failed (filter (lambda (x) (not (= 0 (caddr x))))
 373                                      results)))
 374                 (if (not (null? failed))
 375                     (throw failed))))) ; xxx nicer reporting
 376         (if (and (= 2 (length cmds)) (number? (cadr cmds)))
 377             ;; hack: if it's an fd, use it as sink
 378             (let ((M' ((car cmds) (M::set-sink (cadr cmds)))))
 379               (if (> M::source 2) (close M::source))
 380               (if (> (cadr cmds) 2) (close (cadr cmds)))
 381               (loop M' '()))
 382             (let ((M' ((car cmds) M)))
 383               (if (> M::source 2) (close M::source))
 384               (loop M' (cdr cmds)))))))
 385
 386 (define (pipe:open pathname flags)
 387   (lambda (M)
 388     (M::set-source (open pathname flags))))
 389
 390 (define (pipe:defer producer)
 391   (lambda (M)
 392     (let* ((p (outbound-pipe))
 393            (M' (M::set-source (:read-end p))))
 394       (M'::set-producer (lambda ()
 395                           (producer (:write-end p))
 396                           (close (:write-end p)))))))
 397 (define (pipe:echo data)
 398  (pipe:defer (lambda (sink) (display data (fdopen sink "wb")))))
 399
 400 (define (pipe:spawn command)
 401   (lambda (M)
 402     (define (do-spawn M new-source)
 403       (let ((pid (spawn-process-fd command M::source M::sink
 404                                    (if (> (*verbose*) 0)
 405                                        STDERR_FILENO CLOSED_FD)))
 406             (M' (M::set-source new-source)))
 407         (M'::add-proc command pid)))
 408     (if (= CLOSED_FD M::sink)
 409         (let* ((p (pipe))
 410                (M' (do-spawn (M::set-sink (:write-end p)) (:read-end p))))
 411           (close (:write-end p))
 412           (M'::set-sink CLOSED_FD))
 413         (do-spawn M CLOSED_FD))))
 414
 415 (define (pipe:splice sink)
 416   (lambda (M)
 417     (splice M::source sink)
 418     (M::set-source CLOSED_FD)))
 419
 420 (define (pipe:write-to pathname flags mode)
 421   (open pathname flags mode))
 422
 423 ;;
 424 ;; Monadic transformer support.
 425 ;;
 426
 427 (define (tr:do . commands)
 428   (let loop ((tmpfiles '()) (source  #f) (cmds commands))
 429     (if (null? cmds)
 430         (for-each remove-temporary-file tmpfiles)
 431         (let* ((v ((car cmds) tmpfiles source))
 432                (tmpfiles' (car v))
 433                (sink (cadr v))
 434                (error (caddr v)))
 435           (if error
 436               (begin
 437                 (for-each remove-temporary-file tmpfiles')
 438                 (apply throw error)))
 439           (loop tmpfiles' sink (cdr cmds))))))
 440
 441 (define (tr:open pathname)
 442   (lambda (tmpfiles source)
 443     (list tmpfiles pathname #f)))
 444
 445 (define (tr:spawn input command)
 446   (lambda (tmpfiles source)
 447     (if (and (member '**in** command) (not source))
 448         (fail (string-append (stringify cmd) " needs an input")))
 449     (let* ((t (make-temporary-file))
 450            (cmd (map (lambda (x)
 451                        (cond
 452                         ((equal? '**in** x) source)
 453                         ((equal? '**out** x) t)
 454                         (else x))) command)))
 455       (catch (list (cons t tmpfiles) t *error*)
 456              (call-popen cmd input)
 457              (if (and (member '**out** command) (not (file-exists? t)))
 458                  (fail (string-append (stringify cmd)
 459                                        " did not produce '" t "'.")))
 460              (list (cons t tmpfiles) t #f)))))
 461
 462 (define (tr:write-to pathname)
 463   (lambda (tmpfiles source)
 464     (rename source pathname)
 465     (list tmpfiles pathname #f)))
 466
 467 (define (tr:pipe-do . commands)
 468   (lambda (tmpfiles source)
 469     (let ((t (make-temporary-file)))
 470       (apply pipe:do
 471         `(,@(if source `(,(pipe:open source (logior O_RDONLY O_BINARY))) '())
 472           ,@commands
 473           ,(pipe:write-to t (logior O_WRONLY O_BINARY O_CREAT) #o600)))
 474       (list (cons t tmpfiles) t #f))))
 475
 476 (define (tr:assert-identity reference)
 477   (lambda (tmpfiles source)
 478     (if (not (file=? source reference))
 479         (fail "mismatch"))
 480     (list tmpfiles source #f)))
 481
 482 (define (tr:assert-weak-identity reference)
 483   (lambda (tmpfiles source)
 484     (if (not (text-file=? source reference))
 485         (fail "mismatch"))
 486     (list tmpfiles source #f)))
 487
 488 (define (tr:call-with-content function . args)
 489   (lambda (tmpfiles source)
 490     (catch (list tmpfiles source *error*)
 491            (apply function `(,(call-with-input-file source read-all) ,@args)))
 492     (list tmpfiles source #f)))
 493
 494 ;;
 495 ;; Developing and debugging tests.
 496 ;;
 497
 498 ;; Spawn an os shell.
 499 (define (interactive-shell)
 500   (call-with-fds `(,(getenv "SHELL") -i) 0 1 2))
 501
 502 ;;
 503 ;; The main test framework.
 504 ;;
 505
 506 ;; A pool of tests.
 507 (define test-pool
 508   (package
 509    (define (new procs)
 510      (package
 511       (define (add test)
 512         (new (cons test procs)))
 513       (define (wait)
 514         (let ((unfinished (filter (lambda (t) (not t::retcode)) procs)))
 515           (if (null? unfinished)
 516               (package)
 517               (let* ((names (map (lambda (t) t::name) unfinished))
 518                      (pids (map (lambda (t) t::pid) unfinished))
 519                      (results
 520                       (map (lambda (pid retcode) (list pid retcode))
 521                            pids
 522                            (wait-processes (map stringify names) pids #t))))
 523                 (new
 524                  (map (lambda (t)
 525                         (if t::retcode
 526                             t
 527                             (t::set-retcode (cadr (assoc t::pid results)))))
 528                       procs))))))
 529       (define (passed)
 530         (filter (lambda (p) (= 0 p::retcode)) procs))
 531       (define (skipped)
 532         (filter (lambda (p) (= 77 p::retcode)) procs))
 533       (define (hard-errored)
 534         (filter (lambda (p) (= 99 p::retcode)) procs))
 535       (define (failed)
 536         (filter (lambda (p)
 537                   (not (or (= 0 p::retcode) (= 77 p::retcode)
 538                            (= 99 p::retcode))))
 539                 procs))
 540       (define (report)
 541         (define (print-tests tests message)
 542           (unless (null? tests)
 543                   (apply echo (cons message
 544                                     (map (lambda (t) t::name) tests)))))
 545
 546         (let ((failed' (failed)) (skipped' (skipped)))
 547           (echo (length procs) "tests run,"
 548                 (length (passed)) "succeeded,"
 549                 (length failed') "failed,"
 550                 (length skipped') "skipped.")
 551           (print-tests failed' "Failed tests:")
 552           (print-tests skipped' "Skipped tests:")
 553           (length failed')))))))
 554
 555 (define (verbosity n)
 556   (if (= 0 n) '() (cons '--verbose (verbosity (- n 1)))))
 557
 558 (define (locate-test path)
 559   (if (absolute-path? path) path (in-srcdir path)))
 560
 561 ;; A single test.
 562 (define test
 563   (package
 564    (define (scm name path . args)
 565      ;; Start the process.
 566      (define (spawn-scm args' in out err)
 567        (spawn-process-fd `(,*argv0* ,@(verbosity (*verbose*))
 568                                     ,(locate-test path)
 569                                     ,@args' ,@args) in out err))
 570      (new name #f spawn-scm #f #f CLOSED_FD))
 571
 572    (define (binary name path . args)
 573      ;; Start the process.
 574      (define (spawn-binary args' in out err)
 575        (spawn-process-fd `(,path ,@args' ,@args) in out err))
 576      (new name #f spawn-binary #f #f CLOSED_FD))
 577
 578    (define (new name directory spawn pid retcode logfd)
 579      (package
 580       (define (set-directory x)
 581         (new name x spawn pid retcode logfd))
 582       (define (set-retcode x)
 583         (new name directory spawn pid x logfd))
 584       (define (set-pid x)
 585         (new name directory spawn x retcode logfd))
 586       (define (set-logfd x)
 587         (new name directory spawn pid retcode x))
 588       (define (open-log-file)
 589         (let ((filename (string-append (basename name) ".log")))
 590           (catch '() (unlink filename))
 591           (open filename (logior O_RDWR O_BINARY O_CREAT) #o600)))
 592       (define (run-sync . args)
 593         (letfd ((log (open-log-file)))
 594           (with-working-directory directory
 595             (let* ((p (inbound-pipe))
 596                    (pid (spawn args 0 (:write-end p) (:write-end p))))
 597               (close (:write-end p))
 598               (splice (:read-end p) STDERR_FILENO log)
 599               (close (:read-end p))
 600               (let ((t' (set-retcode (wait-process name pid #t))))
 601                 (t'::report)
 602                 t')))))
 603       (define (run-sync-quiet . args)
 604         (with-working-directory directory
 605           (set-retcode
 606            (wait-process
 607             name (spawn args CLOSED_FD CLOSED_FD CLOSED_FD) #t))))
 608       (define (run-async . args)
 609         (let ((log (open-log-file)))
 610           (with-working-directory directory
 611             (new name directory spawn
 612                  (spawn args CLOSED_FD log log)
 613                  retcode log))))
 614       (define (status)
 615         (let ((t (assoc retcode '((0 "PASS") (77 "SKIP") (99 "ERROR")))))
 616           (if (not t) "FAIL" (cadr t))))
 617       (define (report)
 618         (unless (= logfd CLOSED_FD)
 619                 (seek logfd 0 SEEK_SET)
 620                 (splice logfd STDERR_FILENO)
 621                 (close logfd))
 622         (echo (string-append (status retcode) ":") name))))))
 623
 624 ;; Run the setup target to create an environment, then run all given
 625 ;; tests in parallel.
 626 (define (run-tests-parallel setup tests)
 627   (lettmp (gpghome-tar)
 628     (setup::run-sync '--create-tarball gpghome-tar)
 629     (let loop ((pool (test-pool::new '())) (tests' tests))
 630       (if (null? tests')
 631           (let ((results (pool::wait)))
 632             (for-each (lambda (t)
 633                         (catch (echo "Removing" t::directory "failed:" *error*)
 634                                (unlink-recursively t::directory))
 635                         (t::report)) (reverse results::procs))
 636             (exit (results::report)))
 637           (let* ((wd (mkdtemp))
 638                  (test (car tests'))
 639                  (test' (test::set-directory wd)))
 640             (loop (pool::add (test'::run-async '--unpack-tarball gpghome-tar))
 641                   (cdr tests')))))))
 642
 643 ;; Run the setup target to create an environment, then run all given
 644 ;; tests in sequence.
 645 (define (run-tests-sequential setup tests)
 646   (lettmp (gpghome-tar)
 647     (setup::run-sync '--create-tarball gpghome-tar)
 648     (let loop ((pool (test-pool::new '())) (tests' tests))
 649       (if (null? tests')
 650           (let ((results (pool::wait)))
 651             (for-each (lambda (t)
 652                         (catch (echo "Removing" t::directory "failed:" *error*)
 653                                (unlink-recursively t::directory)))
 654                       results::procs)
 655             (exit (results::report)))
 656           (let* ((wd (mkdtemp))
 657                  (test (car tests'))
 658                  (test' (test::set-directory wd)))
 659             (loop (pool::add (test'::run-sync '--unpack-tarball gpghome-tar))
 660                   (cdr tests')))))))