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 <[email protected]>

5 files changed, 58 insertions, 48 deletions

diff --git a/tests/gpgme/run-tests.scm b/tests/gpgme/run-tests.scm
index cb17977cb..4d3a7e683 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 b3da919d4..0c02c349a 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) '())
 				    ,@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
diff --git a/tests/gpgsm/run-tests.scm b/tests/gpgsm/run-tests.scm
index dfd5b0266..e44424513 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 069af5b47..b4ad260bb 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 546d7d497..139f61837 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))))