mirror of
git://git.gnupg.org/gnupg.git
synced 2025-01-17 14:07:03 +01:00
tests: Rework environment setup.
* tests/gpgscm/tests.scm (test::scm): Add a setup argument. (test::binary): Likewise. (run-tests-parallel): Remove setup parameter. (run-tests-sequential): Likewise. (make-environment-cache): New function that handles the cache protocol. * tests/gpgme/run-tests.scm: Adapt accordingly. * tests/gpgsm/run-tests.scm: Likewise. * tests/migrations/run-tests.scm: Likewise. * tests/openpgp/run-tests.scm: Likewise. -- This change allows us to have different environments for tests. This is needed to run more GPGME tests, and to increase concurrency while running all tests. Signed-off-by: Justus Winter <justus@g10code.com>
This commit is contained in:
Justus Winter
parent
ed5575ec55
commit
cca91a3f8f
@ -39,9 +39,10 @@
|
||||
(let* ((runner (if (member "--parallel" *args*)
|
||||
run-tests-parallel
|
||||
run-tests-sequential))
|
||||
(setup-c (make-environment-cache
|
||||
(test::scm #f "setup.scm" (in-srcdir "setup.scm") "--" "tests" "gpg")))
|
||||
(tests (filter (lambda (arg) (not (string-prefix? arg "--"))) *args*)))
|
||||
(runner
|
||||
(test::scm "setup.scm" (in-srcdir "setup.scm") "--" "tests" "gpg")
|
||||
(apply
|
||||
append
|
||||
(map (lambda (cmpnts)
|
||||
@ -50,6 +51,7 @@
|
||||
(string-suffix? name ".test"))))
|
||||
(define :path car)
|
||||
(define :key cadr)
|
||||
(define :setup caddr)
|
||||
(define (find-test name)
|
||||
(apply path-join
|
||||
`(,(if (compiled? name)
|
||||
@ -59,11 +61,12 @@
|
||||
"Makefile.am"))))
|
||||
(map (lambda (name)
|
||||
(apply test::scm
|
||||
`(,name ,(in-srcdir "wrap.scm") --executable
|
||||
,(find-test name)
|
||||
-- ,@(:path cmpnts))))
|
||||
`(,(:setup cmpnts)
|
||||
,name ,(in-srcdir "wrap.scm") --executable
|
||||
,(find-test name)
|
||||
-- ,@(:path cmpnts))))
|
||||
(if (null? tests) (all-tests makefile (:key cmpnts)) tests))))
|
||||
'((("tests" "gpg") "c_tests")
|
||||
`((("tests" "gpg") "c_tests" ,setup-c)
|
||||
;; XXX: Not yet.
|
||||
;; (("lang" "python" "tests") "py_tests")
|
||||
(("lang" "qt" "tests") "TESTS"))))))
|
||||
(("lang" "qt" "tests") "TESTS" ,setup-c))))))
|
||||
|
||||
@ -551,18 +551,20 @@
|
||||
;; A single test.
|
||||
(define test
|
||||
(package
|
||||
(define (scm name path . args)
|
||||
(define (scm setup name path . args)
|
||||
;; Start the process.
|
||||
(define (spawn-scm args' in out err)
|
||||
(spawn-process-fd `(,*argv0* ,@(verbosity (*verbose*))
|
||||
,(locate-test path)
|
||||
,@(if setup (force setup) '())
|
||||
,@args' ,@args) in out err))
|
||||
(new name #f spawn-scm #f #f CLOSED_FD))
|
||||
|
||||
(define (binary name path . args)
|
||||
(define (binary setup name path . args)
|
||||
;; Start the process.
|
||||
(define (spawn-binary args' in out err)
|
||||
(spawn-process-fd `(,path ,@args' ,@args) in out err))
|
||||
(spawn-process-fd `(,path ,@(if setup (force setup) '()) ,@args' ,@args)
|
||||
in out err))
|
||||
(new name #f spawn-binary #f #f CLOSED_FD))
|
||||
|
||||
(define (new name directory spawn pid retcode logfd)
|
||||
@ -613,41 +615,47 @@
|
||||
|
||||
;; Run the setup target to create an environment, then run all given
|
||||
;; tests in parallel.
|
||||
(define (run-tests-parallel setup 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)
|
||||
(catch (echo "Removing" t::directory "failed:" *error*)
|
||||
(unlink-recursively t::directory))
|
||||
(t::report)) (reverse results::procs))
|
||||
(exit (results::report)))
|
||||
(let* ((wd (mkdtemp))
|
||||
(test (car tests'))
|
||||
(test' (test::set-directory wd)))
|
||||
(loop (pool::add (test'::run-async '--unpack-tarball gpghome-tar))
|
||||
(cdr tests')))))))
|
||||
(define (run-tests-parallel tests)
|
||||
(let loop ((pool (test-pool::new '())) (tests' tests))
|
||||
(if (null? tests')
|
||||
(let ((results (pool::wait)))
|
||||
(for-each (lambda (t)
|
||||
(catch (echo "Removing" t::directory "failed:" *error*)
|
||||
(unlink-recursively t::directory))
|
||||
(t::report)) (reverse results::procs))
|
||||
(exit (results::report)))
|
||||
(let* ((wd (mkdtemp))
|
||||
(test (car tests'))
|
||||
(test' (test::set-directory wd)))
|
||||
(loop (pool::add (test'::run-async))
|
||||
(cdr tests'))))))
|
||||
|
||||
;; Run the setup target to create an environment, then run all given
|
||||
;; tests in sequence.
|
||||
(define (run-tests-sequential setup 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)
|
||||
(catch (echo "Removing" t::directory "failed:" *error*)
|
||||
(unlink-recursively t::directory)))
|
||||
results::procs)
|
||||
(exit (results::report)))
|
||||
(let* ((wd (mkdtemp))
|
||||
(test (car tests'))
|
||||
(test' (test::set-directory wd)))
|
||||
(loop (pool::add (test'::run-sync '--unpack-tarball gpghome-tar))
|
||||
(cdr tests')))))))
|
||||
(define (run-tests-sequential tests)
|
||||
(let loop ((pool (test-pool::new '())) (tests' tests))
|
||||
(if (null? tests')
|
||||
(let ((results (pool::wait)))
|
||||
(for-each (lambda (t)
|
||||
(catch (echo "Removing" t::directory "failed:" *error*)
|
||||
(unlink-recursively t::directory)))
|
||||
results::procs)
|
||||
(exit (results::report)))
|
||||
(let* ((wd (mkdtemp))
|
||||
(test (car tests'))
|
||||
(test' (test::set-directory wd)))
|
||||
(loop (pool::add (test'::run-sync))
|
||||
(cdr tests'))))))
|
||||
|
||||
;; Helper to create environment caches from test functions. SETUP
|
||||
;; must be a test implementing the producer side cache protocol.
|
||||
;; Returns a promise containing the arguments that must be passed to a
|
||||
;; test implementing the consumer side of the cache protocol.
|
||||
(define (make-environment-cache setup)
|
||||
(delay (let* ((tarball (make-temporary-file "environment-cache")))
|
||||
(atexit (lambda () (remove-temporary-file tarball)))
|
||||
(setup::run-sync '--create-tarball tarball)
|
||||
`(--unpack-tarball ,tarball))))
|
||||
|
||||
;; Command line flag handling. Returns the elements following KEY in
|
||||
;; ARGUMENTS up to the next argument, or #f if KEY is not in
|
||||
|
||||
@ -20,13 +20,13 @@
|
||||
(if (string=? "" (getenv "srcdir"))
|
||||
(begin
|
||||
(echo "Environment variable 'srcdir' not set. Please point it to"
|
||||
"tests/openpgp.")
|
||||
"tests/gpgsm.")
|
||||
(exit 2)))
|
||||
|
||||
(let* ((tests (filter (lambda (arg) (not (string-prefix? arg "--"))) *args*))
|
||||
(setup (make-environment-cache (test::scm #f "setup.scm" "setup.scm")))
|
||||
(runner (if (and (member "--parallel" *args*)
|
||||
(> (length tests) 1))
|
||||
run-tests-parallel
|
||||
run-tests-sequential)))
|
||||
(runner (test::scm "setup.scm" "setup.scm")
|
||||
(map (lambda (t) (test::scm t t)) tests)))
|
||||
(runner (map (lambda (t) (test::scm setup t t)) tests)))
|
||||
|
||||
@ -22,5 +22,4 @@
|
||||
(> (length tests) 1))
|
||||
run-tests-parallel
|
||||
run-tests-sequential)))
|
||||
(runner (test::scm "setup.scm" "setup.scm")
|
||||
(map (lambda (t) (test::scm t t)) tests)))
|
||||
(runner (map (lambda (t) (test::scm #f t t)) tests)))
|
||||
|
||||
@ -27,9 +27,9 @@
|
||||
(setenv "objdir" (getcwd) #f)
|
||||
|
||||
(let* ((tests (filter (lambda (arg) (not (string-prefix? arg "--"))) *args*))
|
||||
(setup (make-environment-cache (test::scm #f "setup.scm" "setup.scm")))
|
||||
(runner (if (and (member "--parallel" *args*)
|
||||
(> (length tests) 1))
|
||||
run-tests-parallel
|
||||
run-tests-sequential)))
|
||||
(runner (test::scm "setup.scm" "setup.scm")
|
||||
(map (lambda (t) (test::scm t t)) tests)))
|
||||
(runner (map (lambda (t) (test::scm setup t t)) tests))))
|
||||
|
||||
Loading…
x
Reference in New Issue
Block a user