gpgscm: Make test cleanup more robust.

* tests/gpgscm/tests.scm (mkdtemp-autoremove): New function that
cleans up at interpreter shutdown.
(run-tests-parallel): Use the new function.
(run-tests-sequential): Likewise.
(make-environment-cache): Execute setup with an temporary working
directory.
--

Make sure to remove all resources created in the filesystem even if
the test runner is interrupted.  Make sure to remove anything that the
setup script creates.

Signed-off-by: Justus Winter <[email protected]>

1 files changed, 17 insertions, 14 deletions

diff --git a/tests.scm b/tests.scm
index a4339ca..592b36f 100644
--- a/tests.scm
+++ b/tests.scm
@@ -278,6 +278,15 @@
 						"-XXXXXX"))
 				(apply path-join components)))))
 
+;; Make a temporary directory and remove it at interpreter shutdown.
+;; Note that there are macros that limit the lifetime of temporary
+;; directories and files to a lexical scope.  Use those if possible.
+;; Otherwise this works like mkdtemp.
+(define (mkdtemp-autoremove . components)
+  (let ((dir (apply mkdtemp components)))
+    (atexit (lambda () (unlink-recursively dir)))
+    dir))
+
 (define-macro (with-temporary-working-directory . expressions)
   (let ((tmp-sym (gensym)))
     `(let* ((,tmp-sym (mkdtemp)))
@@ -621,12 +630,9 @@
   (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))
+	  (for-each (lambda (t) (t::report)) (reverse results::procs))
 	  (exit (results::report)))
-	(let* ((wd (mkdtemp))
+	(let* ((wd (mkdtemp-autoremove))
 	       (test (car tests'))
 	       (test' (test::set-directory wd)))
 	  (loop (pool::add (test'::run-async))
@@ -638,12 +644,8 @@
   (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))
+	(let* ((wd (mkdtemp-autoremove))
 	       (test (car tests'))
 	       (test' (test::set-directory wd)))
 	  (loop (pool::add (test'::run-sync))
@@ -654,10 +656,11 @@
 ;; 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))))
+  (delay (with-temporary-working-directory
+	  (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