security-and-privacy/gnupg
security-and-privacy/gnupg
1
0
Fork 0
mirror of git://git.gnupg.org/gnupg.git synced 2025-07-02 22:46:30 +02:00
Code Activity

tests: Speed up the test suite.

Browse source 
* tests/openpgp/run-tests.scm (test::run-sync): Pass additional
arguments to the test.
(test::run-sync-quiet): Likewise.
(test::run-async): Likewise.
(run-tests-{parallel,sequential}-isolated): Create a tarball of the
gnupghome, then extract it for each test.
* tests/openpgp/setup.scm: Refactor into functions, add an interface
to tar-up the created environment, and untar it multiple times.

Signed-off-by: Justus Winter <justus@g10code.com>
This commit is contained in:
Justus Winter 2016-09-05 17:17:24 +02:00
parent c97bde2dfe
commit 46c4333c37
2 changed files with 150 additions and 126 deletions
Download patch file Download diff file Expand all files Collapse all files

80
tests/openpgp/run-tests.scm
View file

@ -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"