[Pkg-gnupg-commit] [gnupg2] 46/124: tests: Rework environment setup.
Daniel Kahn Gillmor
dkg at fifthhorseman.net
Wed Apr 5 15:55:31 UTC 2017
This is an automated email from the git hooks/post-receive script.
dkg pushed a commit to branch experimental
in repository gnupg2.
commit cca91a3f8f7e3e36b7149fc93f7b6df11d21eb1d
Author: Justus Winter <justus at g10code.com>
Date: Thu Mar 9 13:26:06 2017 +0100
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 at g10code.com>
---
tests/gpgme/run-tests.scm | 15 ++++----
tests/gpgscm/tests.scm | 78 +++++++++++++++++++++++-------------------
tests/gpgsm/run-tests.scm | 6 ++--
tests/migrations/run-tests.scm | 3 +-
tests/openpgp/run-tests.scm | 4 +--
5 files changed, 58 insertions(+), 48 deletions(-)
diff --git a/tests/gpgme/run-tests.scm b/tests/gpgme/run-tests.scm
index cb17977..4d3a7e6 100644
--- a/tests/gpgme/run-tests.scm
+++ b/tests/gpgme/run-tests.scm
@@ -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))))))
diff --git a/tests/gpgscm/tests.scm b/tests/gpgscm/tests.scm
index b3da919..0c02c34 100644
--- a/tests/gpgscm/tests.scm
+++ b/tests/gpgscm/tests.scm
@@ -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) '())
, at args' , at 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 , at args' , at args) in out err))
+ (spawn-process-fd `(,path ,@(if setup (force setup) '()) , at args' , at 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
diff --git a/tests/gpgsm/run-tests.scm b/tests/gpgsm/run-tests.scm
index dfd5b02..e444245 100644
--- a/tests/gpgsm/run-tests.scm
+++ b/tests/gpgsm/run-tests.scm
@@ -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)))
diff --git a/tests/migrations/run-tests.scm b/tests/migrations/run-tests.scm
index 069af5b..b4ad260 100644
--- a/tests/migrations/run-tests.scm
+++ b/tests/migrations/run-tests.scm
@@ -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)))
diff --git a/tests/openpgp/run-tests.scm b/tests/openpgp/run-tests.scm
index 546d7d4..139f618 100644
--- a/tests/openpgp/run-tests.scm
+++ b/tests/openpgp/run-tests.scm
@@ -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))))
--
Alioth's /usr/local/bin/git-commit-notice on /srv/git.debian.org/git/pkg-gnupg/gnupg2.git
More information about the Pkg-gnupg-commit
mailing list