diff options
Diffstat (limited to 'tests/openpgp/run-tests.scm')
| -rw-r--r-- | tests/openpgp/run-tests.scm | 80 |
1 files changed, 44 insertions, 36 deletions
diff --git a/tests/openpgp/run-tests.scm b/tests/openpgp/run-tests.scm index e3b6b6a47..3334f61e6 100644 --- a/tests/openpgp/run-tests.scm +++ b/tests/openpgp/run-tests.scm @@ -82,10 +82,10 @@ (new name directory command pid x)) (define (set-pid x) (new name directory command x retcode)) - (define (run-sync) + (define (run-sync . args) (with-working-directory directory (let* ((p (inbound-pipe)) - (pid (spawn-process-fd command CLOSED_FD + (pid (spawn-process-fd (append command args) CLOSED_FD (:write-end p) (:write-end p)))) (close (:write-end p)) (splice (:read-end p) STDERR_FILENO) @@ -93,14 +93,16 @@ (let ((t' (set-retcode (wait-process name pid #t)))) (t'::report) t')))) - (define (run-sync-quiet) + (define (run-sync-quiet . args) (with-working-directory directory (set-retcode (wait-process - name (spawn-process-fd command CLOSED_FD CLOSED_FD CLOSED_FD) #t)))) - (define (run-async) + name (spawn-process-fd (append command args) + CLOSED_FD CLOSED_FD CLOSED_FD) #t)))) + (define (run-async . args) (with-working-directory directory - (set-pid (spawn-process-fd command CLOSED_FD CLOSED_FD CLOSED_FD)))) + (set-pid (spawn-process-fd (append command args) + CLOSED_FD CLOSED_FD CLOSED_FD)))) (define (status) (let ((t (assoc retcode '((0 "PASS") (77 "SKIP") (99 "ERROR"))))) (if (not t) "FAIL" (cadr t)))) @@ -119,21 +121,24 @@ (loop (pool::add (test::run-async)) (cdr tests')))))) (define (run-tests-parallel-isolated setup teardown . tests) - (let loop ((pool (test-pool::new '())) (tests' tests)) - (if (null? tests') - (let ((results (pool::wait))) - (for-each (lambda (t) - (let ((teardown' (teardown::set-directory t::directory))) - (teardown'::run-sync-quiet)) - (unlink-recursively t::directory) - (t::report)) results::procs) - (exit (results::report))) - (let* ((wd (mkdtemp)) - (test (car tests')) - (test' (test::set-directory wd)) - (setup' (setup::set-directory wd))) - (setup'::run-sync-quiet) - (loop (pool::add (test'::run-async)) (cdr tests')))))) + (lettmp (gpghome-tar) + (setup::run-sync '--create-tarball gpghome-tar) + (let loop ((pool (test-pool::new '())) (tests' tests)) + (if (null? tests') + (let ((results (pool::wait))) + (for-each (lambda (t) + (let ((teardown' (teardown::set-directory + t::directory))) + (teardown'::run-sync-quiet)) + (unlink-recursively t::directory) + (t::report)) results::procs) + (exit (results::report))) + (let* ((wd (mkdtemp)) + (test (car tests')) + (test' (test::set-directory wd)) + (setup' (setup::set-directory wd))) + (setup'::run-sync-quiet '--unpack-tarball gpghome-tar) + (loop (pool::add (test'::run-async)) (cdr tests'))))))) (define (run-tests-sequential-shared setup teardown . tests) (let loop ((pool (test-pool::new '())) @@ -145,21 +150,24 @@ (loop (pool::add (test::run-sync)) (cdr tests')))))) (define (run-tests-sequential-isolated setup teardown . tests) - (let loop ((pool (test-pool::new '())) (tests' tests)) - (if (null? tests') - (let ((results (pool::wait))) - (for-each (lambda (t) - (let ((teardown' (teardown::set-directory t::directory))) - (teardown'::run-sync-quiet)) - (unlink-recursively t::directory)) - results::procs) - (exit (results::report))) - (let* ((wd (mkdtemp)) - (test (car tests')) - (test' (test::set-directory wd)) - (setup' (setup::set-directory wd))) - (setup'::run-sync-quiet) - (loop (pool::add (test'::run-sync)) (cdr tests')))))) + (lettmp (gpghome-tar) + (setup::run-sync '--create-tarball gpghome-tar) + (let loop ((pool (test-pool::new '())) (tests' tests)) + (if (null? tests') + (let ((results (pool::wait))) + (for-each (lambda (t) + (let ((teardown' (teardown::set-directory + t::directory))) + (teardown'::run-sync-quiet)) + (unlink-recursively t::directory)) + results::procs) + (exit (results::report))) + (let* ((wd (mkdtemp)) + (test (car tests')) + (test' (test::set-directory wd)) + (setup' (setup::set-directory wd))) + (setup'::run-sync-quiet '--unpack-tarball gpghome-tar) + (loop (pool::add (test'::run-sync)) (cdr tests'))))))) (define all-tests '("version.scm" |