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: Rework environment setup.

Browse source 
* 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 2017-03-09 13:26:06 +01:00
parent ed5575ec55
commit cca91a3f8f
No known key found for this signature in database
GPG key ID: DD1A52F9DA8C9020
5 changed files with 58 additions and 48 deletions
Download patch file Download diff file Expand all files Collapse all files

78
tests/gpgscm/tests.scm
View file

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