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 (define-macro (letfd bindings . body)
 248   (let bind ((bindings' bindings))
 249     (if (null? bindings')
 250         `(begin ,@body)
 251         (let* ((binding (car bindings'))
 252                (name (car binding))
 253                (initializer (cadr binding)))
 254           `(let ((,name ,initializer))
 255              (finally (close ,name)
 256                       ,(bind (cdr bindings'))))))))
 257
 258 (define-macro (with-working-directory new-directory . expressions)
 259   (let ((new-dir (gensym))
 260         (old-dir (gensym)))
 261     `(let* ((,new-dir ,new-directory)
 262             (,old-dir (getcwd)))
 263        (dynamic-wind
 264            (lambda () (if ,new-dir (chdir ,new-dir)))
 265            (lambda () ,@expressions)
 266            (lambda () (chdir ,old-dir))))))
 267
 268 ;; Make a temporary directory.  If arguments are given, they are
 269 ;; joined using path-join, and must end in a component ending in
 270 ;; "XXXXXX".  If no arguments are given, a suitable location and
 271 ;; generic name is used.
 272 (define (mkdtemp . components)
 273   (_mkdtemp (if (null? components)
 274                 (path-join (getenv "TMP")
 275                            (string-append "gpgscm-" (get-isotime) "-"
 276                                           (basename-suffix *scriptname* ".scm")
 277                                           "-XXXXXX"))
 278                 (apply path-join components))))
 279
 280 (define-macro (with-temporary-working-directory . expressions)
 281   (let ((tmp-sym (gensym)))
 282     `(let* ((,tmp-sym (mkdtemp)))
 283        (finally (unlink-recursively ,tmp-sym)
 284                 (with-working-directory ,tmp-sym
 285                                         ,@expressions)))))
 286
 287 (define (make-temporary-file . args)
 288   (canonical-path (path-join
 289                    (mkdtemp)
 290                    (if (null? args) "a" (car args)))))
 291
 292 (define (remove-temporary-file filename)
 293   (catch '()
 294     (unlink filename))
 295   (let ((dirname (substring filename 0 (string-rindex filename #\/))))
 296     (catch (echo "removing temporary directory" dirname "failed")
 297       (rmdir dirname))))
 298
 299 ;; let-like macro that manages temporary files.
 300 ;;
 301 ;; (lettmp <bindings> <body>)
 302 ;;
 303 ;; Bind all variables given in <bindings>, initialize each of them to
 304 ;; a string representing an unique path in the filesystem, and delete
 305 ;; them after evaluting <body>.
 306 (define-macro (lettmp bindings . body)
 307   (let bind ((bindings' bindings))
 308     (if (null? bindings')
 309         `(begin ,@body)
 310         (let ((name (car bindings'))
 311               (rest (cdr bindings')))
 312           `(let ((,name (make-temporary-file ,(symbol->string name))))
 313              (finally (remove-temporary-file ,name)
 314                       ,(bind rest)))))))
 315
 316 (define (check-execution source transformer)
 317   (lettmp (sink)
 318           (transformer source sink)))
 319
 320 (define (check-identity source transformer)
 321   (lettmp (sink)
 322           (transformer source sink)
 323           (if (not (file=? source sink))
 324               (fail "mismatch"))))
 325
 326 ;;
 327 ;; Monadic pipe support.
 328 ;;
 329
 330 (define pipeM
 331   (package
 332    (define (new procs source sink producer)
 333      (package
 334       (define (dump)
 335         (write (list procs source sink producer))
 336         (newline))
 337       (define (add-proc command pid)
 338         (new (cons (list command pid) procs) source sink producer))
 339       (define (commands)
 340         (map car procs))
 341       (define (pids)
 342         (map cadr procs))
 343       (define (set-source source')
 344         (new procs source' sink producer))
 345       (define (set-sink sink')
 346         (new procs source sink' producer))
 347       (define (set-producer producer')
 348         (if producer
 349             (throw "producer already set"))
 350         (new procs source sink producer'))))))
 351
 352
 353 (define (pipe:do . commands)
 354   (let loop ((M (pipeM::new '() CLOSED_FD CLOSED_FD #f)) (cmds commands))
 355     (if (null? cmds)
 356         (begin
 357           (if M::producer (M::producer))
 358           (if (not (null? M::procs))
 359               (let* ((retcodes (wait-processes (map stringify (M::commands))
 360                                                (M::pids) #t))
 361                      (results (map (lambda (p r) (append p (list r)))
 362                                    M::procs retcodes))
 363                      (failed (filter (lambda (x) (not (= 0 (caddr x))))
 364                                      results)))
 365                 (if (not (null? failed))
 366                     (throw failed))))) ; xxx nicer reporting
 367         (if (and (= 2 (length cmds)) (number? (cadr cmds)))
 368             ;; hack: if it's an fd, use it as sink
 369             (let ((M' ((car cmds) (M::set-sink (cadr cmds)))))
 370               (if (> M::source 2) (close M::source))
 371               (if (> (cadr cmds) 2) (close (cadr cmds)))
 372               (loop M' '()))
 373             (let ((M' ((car cmds) M)))
 374               (if (> M::source 2) (close M::source))
 375               (loop M' (cdr cmds)))))))
 376
 377 (define (pipe:open pathname flags)
 378   (lambda (M)
 379     (M::set-source (open pathname flags))))
 380
 381 (define (pipe:defer producer)
 382   (lambda (M)
 383     (let* ((p (outbound-pipe))
 384            (M' (M::set-source (:read-end p))))
 385       (M'::set-producer (lambda ()
 386                           (producer (:write-end p))
 387                           (close (:write-end p)))))))
 388 (define (pipe:echo data)
 389  (pipe:defer (lambda (sink) (display data (fdopen sink "wb")))))
 390
 391 (define (pipe:spawn command)
 392   (lambda (M)
 393     (define (do-spawn M new-source)
 394       (let ((pid (spawn-process-fd command M::source M::sink
 395                                    (if (> (*verbose*) 0)
 396                                        STDERR_FILENO CLOSED_FD)))
 397             (M' (M::set-source new-source)))
 398         (M'::add-proc command pid)))
 399     (if (= CLOSED_FD M::sink)
 400         (let* ((p (pipe))
 401                (M' (do-spawn (M::set-sink (:write-end p)) (:read-end p))))
 402           (close (:write-end p))
 403           (M'::set-sink CLOSED_FD))
 404         (do-spawn M CLOSED_FD))))
 405
 406 (define (pipe:splice sink)
 407   (lambda (M)
 408     (splice M::source sink)
 409     (M::set-source CLOSED_FD)))
 410
 411 (define (pipe:write-to pathname flags mode)
 412   (open pathname flags mode))
 413
 414 ;;
 415 ;; Monadic transformer support.
 416 ;;
 417
 418 (define (tr:do . commands)
 419   (let loop ((tmpfiles '()) (source  #f) (cmds commands))
 420     (if (null? cmds)
 421         (for-each remove-temporary-file tmpfiles)
 422         (let* ((v ((car cmds) tmpfiles source))
 423                (tmpfiles' (car v))
 424                (sink (cadr v))
 425                (error (caddr v)))
 426           (if error
 427               (begin
 428                 (for-each remove-temporary-file tmpfiles')
 429                 (apply throw error)))
 430           (loop tmpfiles' sink (cdr cmds))))))
 431
 432 (define (tr:open pathname)
 433   (lambda (tmpfiles source)
 434     (list tmpfiles pathname #f)))
 435
 436 (define (tr:spawn input command)
 437   (lambda (tmpfiles source)
 438     (if (and (member '**in** command) (not source))
 439         (fail (string-append (stringify cmd) " needs an input")))
 440     (let* ((t (make-temporary-file))
 441            (cmd (map (lambda (x)
 442                        (cond
 443                         ((equal? '**in** x) source)
 444                         ((equal? '**out** x) t)
 445                         (else x))) command)))
 446       (catch (list (cons t tmpfiles) t *error*)
 447              (call-popen cmd input)
 448              (if (and (member '**out** command) (not (file-exists? t)))
 449                  (fail (string-append (stringify cmd)
 450                                        " did not produce '" t "'.")))
 451              (list (cons t tmpfiles) t #f)))))
 452
 453 (define (tr:write-to pathname)
 454   (lambda (tmpfiles source)
 455     (rename source pathname)
 456     (list tmpfiles pathname #f)))
 457
 458 (define (tr:pipe-do . commands)
 459   (lambda (tmpfiles source)
 460     (let ((t (make-temporary-file)))
 461       (apply pipe:do
 462         `(,@(if source `(,(pipe:open source (logior O_RDONLY O_BINARY))) '())
 463           ,@commands
 464           ,(pipe:write-to t (logior O_WRONLY O_BINARY O_CREAT) #o600)))
 465       (list (cons t tmpfiles) t #f))))
 466
 467 (define (tr:assert-identity reference)
 468   (lambda (tmpfiles source)
 469     (if (not (file=? source reference))
 470         (fail "mismatch"))
 471     (list tmpfiles source #f)))
 472
 473 (define (tr:assert-weak-identity reference)
 474   (lambda (tmpfiles source)
 475     (if (not (text-file=? source reference))
 476         (fail "mismatch"))
 477     (list tmpfiles source #f)))
 478
 479 (define (tr:call-with-content function . args)
 480   (lambda (tmpfiles source)
 481     (catch (list tmpfiles source *error*)
 482            (apply function `(,(call-with-input-file source read-all) ,@args)))
 483     (list tmpfiles source #f)))
 484
 485 ;;
 486 ;; Developing and debugging tests.
 487 ;;
 488
 489 ;; Spawn an os shell.
 490 (define (interactive-shell)
 491   (call-with-fds `(,(getenv "SHELL") -i) 0 1 2))
 492
 493 ;;
 494 ;; The main test framework.
 495 ;;
 496
 497 ;; A pool of tests.
 498 (define test-pool
 499   (package
 500    (define (new procs)
 501      (package
 502       (define (add test)
 503         (new (cons test procs)))
 504       (define (wait)
 505         (let ((unfinished (filter (lambda (t) (not t::retcode)) procs)))
 506           (if (null? unfinished)
 507               (package)
 508               (let* ((names (map (lambda (t) t::name) unfinished))
 509                      (pids (map (lambda (t) t::pid) unfinished))
 510                      (results
 511                       (map (lambda (pid retcode) (list pid retcode))
 512                            pids
 513                            (wait-processes (map stringify names) pids #t))))
 514                 (new
 515                  (map (lambda (t)
 516                         (if t::retcode
 517                             t
 518                             (t::set-retcode (cadr (assoc t::pid results)))))
 519                       procs))))))
 520       (define (passed)
 521         (filter (lambda (p) (= 0 p::retcode)) procs))
 522       (define (skipped)
 523         (filter (lambda (p) (= 77 p::retcode)) procs))
 524       (define (hard-errored)
 525         (filter (lambda (p) (= 99 p::retcode)) procs))
 526       (define (failed)
 527         (filter (lambda (p)
 528                   (not (or (= 0 p::retcode) (= 77 p::retcode)
 529                            (= 99 p::retcode))))
 530                 procs))
 531       (define (report)
 532         (define (print-tests tests message)
 533           (unless (null? tests)
 534                   (apply echo (cons message
 535                                     (map (lambda (t) t::name) tests)))))
 536
 537         (let ((failed' (failed)) (skipped' (skipped)))
 538           (echo (length procs) "tests run,"
 539                 (length (passed)) "succeeded,"
 540                 (length failed') "failed,"
 541                 (length skipped') "skipped.")
 542           (print-tests failed' "Failed tests:")
 543           (print-tests skipped' "Skipped tests:")
 544           (length failed')))))))
 545
 546 (define (verbosity n)
 547   (if (= 0 n) '() (cons '--verbose (verbosity (- n 1)))))
 548
 549 (define (locate-test path)
 550   (if (absolute-path? path) path (in-srcdir path)))
 551
 552 ;; A single test.
 553 (define test
 554   (package
 555    (define (scm name path . args)
 556      ;; Start the process.
 557      (define (spawn-scm args' in out err)
 558        (spawn-process-fd `(,*argv0* ,@(verbosity (*verbose*))
 559                                     ,(locate-test path)
 560                                     ,@args' ,@args) in out err))
 561      (new name #f spawn-scm #f #f CLOSED_FD))
 562
 563    (define (binary name path . args)
 564      ;; Start the process.
 565      (define (spawn-binary args' in out err)
 566        (spawn-process-fd `(,path ,@args' ,@args) in out err))
 567      (new name #f spawn-binary #f #f CLOSED_FD))
 568
 569    (define (new name directory spawn pid retcode logfd)
 570      (package
 571       (define (set-directory x)
 572         (new name x spawn pid retcode logfd))
 573       (define (set-retcode x)
 574         (new name directory spawn pid x logfd))
 575       (define (set-pid x)
 576         (new name directory spawn x retcode logfd))
 577       (define (set-logfd x)
 578         (new name directory spawn pid retcode x))
 579       (define (open-log-file)
 580         (let ((filename (string-append (basename name) ".log")))
 581           (catch '() (unlink filename))
 582           (open filename (logior O_RDWR O_BINARY O_CREAT) #o600)))
 583       (define (run-sync . args)
 584         (letfd ((log (open-log-file)))
 585           (with-working-directory directory
 586             (let* ((p (inbound-pipe))
 587                    (pid (spawn args 0 (:write-end p) (:write-end p))))
 588               (close (:write-end p))
 589               (splice (:read-end p) STDERR_FILENO log)
 590               (close (:read-end p))
 591               (let ((t' (set-retcode (wait-process name pid #t))))
 592                 (t'::report)
 593                 t')))))
 594       (define (run-sync-quiet . args)
 595         (with-working-directory directory
 596           (set-retcode
 597            (wait-process
 598             name (spawn args CLOSED_FD CLOSED_FD CLOSED_FD) #t))))
 599       (define (run-async . args)
 600         (let ((log (open-log-file)))
 601           (with-working-directory directory
 602             (new name directory spawn
 603                  (spawn args CLOSED_FD log log)
 604                  retcode log))))
 605       (define (status)
 606         (let ((t (assoc retcode '((0 "PASS") (77 "SKIP") (99 "ERROR")))))
 607           (if (not t) "FAIL" (cadr t))))
 608       (define (report)
 609         (unless (= logfd CLOSED_FD)
 610                 (seek logfd 0 SEEK_SET)
 611                 (splice logfd STDERR_FILENO)
 612                 (close logfd))
 613         (echo (string-append (status) ":") name))))))
 614
 615 ;; Run the setup target to create an environment, then run all given
 616 ;; tests in parallel.
 617 (define (run-tests-parallel setup tests)
 618   (lettmp (gpghome-tar)
 619     (setup::run-sync '--create-tarball gpghome-tar)
 620     (let loop ((pool (test-pool::new '())) (tests' tests))
 621       (if (null? tests')
 622           (let ((results (pool::wait)))
 623             (for-each (lambda (t)
 624                         (catch (echo "Removing" t::directory "failed:" *error*)
 625                                (unlink-recursively t::directory))
 626                         (t::report)) (reverse results::procs))
 627             (exit (results::report)))
 628           (let* ((wd (mkdtemp))
 629                  (test (car tests'))
 630                  (test' (test::set-directory wd)))
 631             (loop (pool::add (test'::run-async '--unpack-tarball gpghome-tar))
 632                   (cdr tests')))))))
 633
 634 ;; Run the setup target to create an environment, then run all given
 635 ;; tests in sequence.
 636 (define (run-tests-sequential setup tests)
 637   (lettmp (gpghome-tar)
 638     (setup::run-sync '--create-tarball gpghome-tar)
 639     (let loop ((pool (test-pool::new '())) (tests' tests))
 640       (if (null? tests')
 641           (let ((results (pool::wait)))
 642             (for-each (lambda (t)
 643                         (catch (echo "Removing" t::directory "failed:" *error*)
 644                                (unlink-recursively t::directory)))
 645                       results::procs)
 646             (exit (results::report)))
 647           (let* ((wd (mkdtemp))
 648                  (test (car tests'))
 649                  (test' (test::set-directory wd)))
 650             (loop (pool::add (test'::run-sync '--unpack-tarball gpghome-tar))
 651                   (cdr tests')))))))
 652
 653 ;; Command line flag handling.  Returns the elements following KEY in
 654 ;; ARGUMENTS up to the next argument, or #f if KEY is not in
 655 ;; ARGUMENTS.
 656 (define (flag key arguments)
 657   (cond
 658    ((null? arguments)
 659     #f)
 660    ((string=? key (car arguments))
 661     (let loop ((acc '())
 662                (args (cdr arguments)))
 663       (if (or (null? args) (string-prefix? (car args) "--"))
 664           (reverse acc)
 665           (loop (cons (car args) acc) (cdr args)))))
 666    ((string=? "--" (car arguments))
 667     #f)
 668    (else
 669     (flag key (cdr arguments)))))
 670 (assert (equal? (flag "--xxx" '("--yyy")) #f))
 671 (assert (equal? (flag "--xxx" '("--xxx")) '()))
 672 (assert (equal? (flag "--xxx" '("--xxx" "yyy")) '("yyy")))
 673 (assert (equal? (flag "--xxx" '("--xxx" "yyy" "zzz")) '("yyy" "zzz")))
 674 (assert (equal? (flag "--xxx" '("--xxx" "yyy" "zzz" "--")) '("yyy" "zzz")))
 675 (assert (equal? (flag "--xxx" '("--xxx" "yyy" "--" "zzz")) '("yyy")))
 676 (assert (equal? (flag "--" '("--" "xxx" "yyy" "--" "zzz")) '("xxx" "yyy")))