mirror of git://git.gnupg.org/gnupg.git
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 <justus@g10code.com>
This commit is contained in:
parent
fde885bbc4
commit
178b6314ab
|
@ -278,6 +278,15 @@
|
||||||
"-XXXXXX"))
|
"-XXXXXX"))
|
||||||
(apply path-join components)))))
|
(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)
|
(define-macro (with-temporary-working-directory . expressions)
|
||||||
(let ((tmp-sym (gensym)))
|
(let ((tmp-sym (gensym)))
|
||||||
`(let* ((,tmp-sym (mkdtemp)))
|
`(let* ((,tmp-sym (mkdtemp)))
|
||||||
|
@ -621,12 +630,9 @@
|
||||||
(let loop ((pool (test-pool::new '())) (tests' tests))
|
(let loop ((pool (test-pool::new '())) (tests' tests))
|
||||||
(if (null? tests')
|
(if (null? tests')
|
||||||
(let ((results (pool::wait)))
|
(let ((results (pool::wait)))
|
||||||
(for-each (lambda (t)
|
(for-each (lambda (t) (t::report)) (reverse results::procs))
|
||||||
(catch (echo "Removing" t::directory "failed:" *error*)
|
|
||||||
(unlink-recursively t::directory))
|
|
||||||
(t::report)) (reverse results::procs))
|
|
||||||
(exit (results::report)))
|
(exit (results::report)))
|
||||||
(let* ((wd (mkdtemp))
|
(let* ((wd (mkdtemp-autoremove))
|
||||||
(test (car tests'))
|
(test (car tests'))
|
||||||
(test' (test::set-directory wd)))
|
(test' (test::set-directory wd)))
|
||||||
(loop (pool::add (test'::run-async))
|
(loop (pool::add (test'::run-async))
|
||||||
|
@ -638,12 +644,8 @@
|
||||||
(let loop ((pool (test-pool::new '())) (tests' tests))
|
(let loop ((pool (test-pool::new '())) (tests' tests))
|
||||||
(if (null? tests')
|
(if (null? tests')
|
||||||
(let ((results (pool::wait)))
|
(let ((results (pool::wait)))
|
||||||
(for-each (lambda (t)
|
|
||||||
(catch (echo "Removing" t::directory "failed:" *error*)
|
|
||||||
(unlink-recursively t::directory)))
|
|
||||||
results::procs)
|
|
||||||
(exit (results::report)))
|
(exit (results::report)))
|
||||||
(let* ((wd (mkdtemp))
|
(let* ((wd (mkdtemp-autoremove))
|
||||||
(test (car tests'))
|
(test (car tests'))
|
||||||
(test' (test::set-directory wd)))
|
(test' (test::set-directory wd)))
|
||||||
(loop (pool::add (test'::run-sync))
|
(loop (pool::add (test'::run-sync))
|
||||||
|
@ -654,10 +656,11 @@
|
||||||
;; Returns a promise containing the arguments that must be passed to a
|
;; Returns a promise containing the arguments that must be passed to a
|
||||||
;; test implementing the consumer side of the cache protocol.
|
;; test implementing the consumer side of the cache protocol.
|
||||||
(define (make-environment-cache setup)
|
(define (make-environment-cache setup)
|
||||||
(delay (let* ((tarball (make-temporary-file "environment-cache")))
|
(delay (with-temporary-working-directory
|
||||||
(atexit (lambda () (remove-temporary-file tarball)))
|
(let ((tarball (make-temporary-file "environment-cache")))
|
||||||
(setup::run-sync '--create-tarball tarball)
|
(atexit (lambda () (remove-temporary-file tarball)))
|
||||||
`(--unpack-tarball ,tarball))))
|
(setup::run-sync '--create-tarball tarball)
|
||||||
|
`(--unpack-tarball ,tarball)))))
|
||||||
|
|
||||||
;; Command line flag handling. Returns the elements following KEY in
|
;; Command line flag handling. Returns the elements following KEY in
|
||||||
;; ARGUMENTS up to the next argument, or #f if KEY is not in
|
;; ARGUMENTS up to the next argument, or #f if KEY is not in
|
||||||
|
|
Loading…
Reference in New Issue