tests: Rework environment setup.
authorJustus Winter <justus@g10code.com>
Thu, 9 Mar 2017 12:26:06 +0000 (13:26 +0100)
committerJustus Winter <justus@g10code.com>
Thu, 9 Mar 2017 12:26:06 +0000 (13:26 +0100)
* 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>
tests/gpgme/run-tests.scm
tests/gpgscm/tests.scm
tests/gpgsm/run-tests.scm
tests/migrations/run-tests.scm
tests/openpgp/run-tests.scm

index cb17977..4d3a7e6 100644 (file)
 (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)
                                                            "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))))))
index b3da919..0c02c34 100644 (file)
 ;; 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)
 
 ;; 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
index dfd5b02..e444245 100644 (file)
 (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)))
index 069af5b..b4ad260 100644 (file)
@@ -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)))
index 546d7d4..139f618 100644 (file)
@@ -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))))