gpgscm: Make test cleanup more robust.
authorJustus Winter <justus@g10code.com>
Thu, 23 Mar 2017 09:55:34 +0000 (10:55 +0100)
committerJustus Winter <justus@g10code.com>
Thu, 23 Mar 2017 14:56:34 +0000 (15:56 +0100)
* 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 <justus@g10code.com>
tests/gpgscm/tests.scm

index a4339ca..592b36f 100644 (file)
                                                "-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)))
   (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))
   (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))
 ;; 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