security-and-privacy/gnupg
security-and-privacy
/
gnupg
mirror of git://git.gnupg.org/gnupg.git
1
0
Fork 0
Code Releases Activity

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:
Justus Winter 2017-03-23 10:55:34 +01:00
parent fde885bbc4
commit 178b6314ab
No known key found for this signature in database
GPG Key ID: DD1A52F9DA8C9020
1 changed files with 17 additions and 14 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

31
tests/gpgscm/tests.scm
View File

@ -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