[Pkg-gnupg-commit] [gnupg2] 93/180: gpgscm: Move the test runner to the Scheme library.
Daniel Kahn Gillmor
dkg at fifthhorseman.net
Sat Dec 24 22:29:13 UTC 2016
This is an automated email from the git hooks/post-receive script.
dkg pushed a commit to branch master
in repository gnupg2.
commit 1a176b92a8aad42056ed2c4e1f49a5feb40770cf
Author: Justus Winter <justus at g10code.com>
Date: Wed Nov 16 12:32:17 2016 +0100
gpgscm: Move the test runner to the Scheme library.
* tests/openpgp/run-tests.scm: Move most of the code...
* tests/gpgscm/tests.scm: ... here.
Signed-off-by: Justus Winter <justus at g10code.com>
---
tests/gpgscm/tests.scm | 151 ++++++++++++++++++++++++++++++++++++++++++++
tests/openpgp/run-tests.scm | 141 -----------------------------------------
2 files changed, 151 insertions(+), 141 deletions(-)
diff --git a/tests/gpgscm/tests.scm b/tests/gpgscm/tests.scm
index d360272..dd4c69f 100644
--- a/tests/gpgscm/tests.scm
+++ b/tests/gpgscm/tests.scm
@@ -498,3 +498,154 @@
;; Spawn an os shell.
(define (interactive-shell)
(call-with-fds `(,(getenv "SHELL") -i) 0 1 2))
+
+;;
+;; The main test framework.
+;;
+
+;; A pool of tests.
+(define test-pool
+ (package
+ (define (new procs)
+ (package
+ (define (add test)
+ (new (cons test procs)))
+ (define (wait)
+ (let ((unfinished (filter (lambda (t) (not t::retcode)) procs)))
+ (if (null? unfinished)
+ (package)
+ (let* ((names (map (lambda (t) t::name) unfinished))
+ (pids (map (lambda (t) t::pid) unfinished))
+ (results
+ (map (lambda (pid retcode) (list pid retcode))
+ pids
+ (wait-processes (map stringify names) pids #t))))
+ (new
+ (map (lambda (t)
+ (if t::retcode
+ t
+ (t::set-retcode (cadr (assoc t::pid results)))))
+ procs))))))
+ (define (passed)
+ (filter (lambda (p) (= 0 p::retcode)) procs))
+ (define (skipped)
+ (filter (lambda (p) (= 77 p::retcode)) procs))
+ (define (hard-errored)
+ (filter (lambda (p) (= 99 p::retcode)) procs))
+ (define (failed)
+ (filter (lambda (p)
+ (not (or (= 0 p::retcode) (= 77 p::retcode)
+ (= 99 p::retcode))))
+ procs))
+ (define (report)
+ (echo (length procs) "tests run,"
+ (length (passed)) "succeeded,"
+ (length (failed)) "failed,"
+ (length (skipped)) "skipped.")
+ (length (failed)))))))
+
+(define (verbosity n)
+ (if (= 0 n) '() (cons '--verbose (verbosity (- n 1)))))
+
+(define (locate-test path)
+ (if (absolute-path? path) path (in-srcdir path)))
+
+;; A single test.
+(define test
+ (package
+ (define (scm path . args)
+ ;; Start the process.
+ (define (spawn-scm args in out err)
+ (spawn-process-fd `(,*argv0* ,@(verbosity (*verbose*))
+ ,(locate-test path) , at args) in out err))
+ (new (basename path) #f spawn-scm #f #f CLOSED_FD))
+
+ (define (binary path . args)
+ ;; Start the process.
+ (define (spawn-binary args in out err)
+ (spawn-process-fd `(path , at args) in out err))
+ (new (basename path) #f spawn-binary #f #f CLOSED_FD))
+
+ (define (new name directory spawn pid retcode logfd)
+ (package
+ (define (set-directory x)
+ (new name x spawn pid retcode logfd))
+ (define (set-retcode x)
+ (new name directory spawn pid x logfd))
+ (define (set-pid x)
+ (new name directory spawn x retcode logfd))
+ (define (set-logfd x)
+ (new name directory spawn pid retcode x))
+ (define (open-log-file)
+ (let ((filename (string-append (basename name) ".log")))
+ (catch '() (unlink filename))
+ (open filename (logior O_RDWR O_BINARY O_CREAT) #o600)))
+ (define (run-sync . args)
+ (letfd ((log (open-log-file)))
+ (with-working-directory directory
+ (let* ((p (inbound-pipe))
+ (pid (spawn args 0 (:write-end p) (:write-end p))))
+ (close (:write-end p))
+ (splice (:read-end p) STDERR_FILENO log)
+ (close (:read-end p))
+ (let ((t' (set-retcode (wait-process name pid #t))))
+ (t'::report)
+ t')))))
+ (define (run-sync-quiet . args)
+ (with-working-directory directory
+ (set-retcode
+ (wait-process
+ name (spawn args CLOSED_FD CLOSED_FD CLOSED_FD) #t))))
+ (define (run-async . args)
+ (let ((log (open-log-file)))
+ (with-working-directory directory
+ (new name directory spawn
+ (spawn args CLOSED_FD log log)
+ retcode log))))
+ (define (status)
+ (let ((t (assoc retcode '((0 "PASS") (77 "SKIP") (99 "ERROR")))))
+ (if (not t) "FAIL" (cadr t))))
+ (define (report)
+ (unless (= logfd CLOSED_FD)
+ (seek logfd 0 SEEK_SET)
+ (splice logfd STDERR_FILENO)
+ (close logfd))
+ (echo (string-append (status retcode) ":") name))))))
+
+;; 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')))))))
+
+;; 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')))))))
diff --git a/tests/openpgp/run-tests.scm b/tests/openpgp/run-tests.scm
index cea50db..a7c282e 100644
--- a/tests/openpgp/run-tests.scm
+++ b/tests/openpgp/run-tests.scm
@@ -26,147 +26,6 @@
;; Set objdir so that the tests can locate built programs.
(setenv "objdir" (getcwd) #f)
-(define test-pool
- (package
- (define (new procs)
- (package
- (define (add test)
- (new (cons test procs)))
- (define (wait)
- (let ((unfinished (filter (lambda (t) (not t::retcode)) procs)))
- (if (null? unfinished)
- (package)
- (let* ((names (map (lambda (t) t::name) unfinished))
- (pids (map (lambda (t) t::pid) unfinished))
- (results
- (map (lambda (pid retcode) (list pid retcode))
- pids
- (wait-processes (map stringify names) pids #t))))
- (new
- (map (lambda (t)
- (if t::retcode
- t
- (t::set-retcode (cadr (assoc t::pid results)))))
- procs))))))
- (define (passed)
- (filter (lambda (p) (= 0 p::retcode)) procs))
- (define (skipped)
- (filter (lambda (p) (= 77 p::retcode)) procs))
- (define (hard-errored)
- (filter (lambda (p) (= 99 p::retcode)) procs))
- (define (failed)
- (filter (lambda (p)
- (not (or (= 0 p::retcode) (= 77 p::retcode)
- (= 99 p::retcode))))
- procs))
- (define (report)
- (echo (length procs) "tests run,"
- (length (passed)) "succeeded,"
- (length (failed)) "failed,"
- (length (skipped)) "skipped.")
- (length (failed)))))))
-
-(define (verbosity n)
- (if (= 0 n) '() (cons '--verbose (verbosity (- n 1)))))
-
-(define (locate-test path)
- (if (absolute-path? path) path (in-srcdir path)))
-
-(define test
- (package
- (define (scm path . args)
- ;; Start the process.
- (define (spawn-scm args in out err)
- (spawn-process-fd `(,*argv0* ,@(verbosity (*verbose*))
- ,(locate-test path) , at args) in out err))
- (new (basename path) #f spawn-scm #f #f CLOSED_FD))
-
- (define (binary path . args)
- ;; Start the process.
- (define (spawn-binary args in out err)
- (spawn-process-fd `(path , at args) in out err))
- (new (basename path) #f spawn-binary #f #f CLOSED_FD))
-
- (define (new name directory spawn pid retcode logfd)
- (package
- (define (set-directory x)
- (new name x spawn pid retcode logfd))
- (define (set-retcode x)
- (new name directory spawn pid x logfd))
- (define (set-pid x)
- (new name directory spawn x retcode logfd))
- (define (set-logfd x)
- (new name directory spawn pid retcode x))
- (define (open-log-file)
- (let ((filename (string-append (basename name) ".log")))
- (catch '() (unlink filename))
- (open filename (logior O_RDWR O_BINARY O_CREAT) #o600)))
- (define (run-sync . args)
- (letfd ((log (open-log-file)))
- (with-working-directory directory
- (let* ((p (inbound-pipe))
- (pid (spawn args 0 (:write-end p) (:write-end p))))
- (close (:write-end p))
- (splice (:read-end p) STDERR_FILENO log)
- (close (:read-end p))
- (let ((t' (set-retcode (wait-process name pid #t))))
- (t'::report)
- t')))))
- (define (run-sync-quiet . args)
- (with-working-directory directory
- (set-retcode
- (wait-process
- name (spawn args CLOSED_FD CLOSED_FD CLOSED_FD) #t))))
- (define (run-async . args)
- (let ((log (open-log-file)))
- (with-working-directory directory
- (new name directory spawn
- (spawn args CLOSED_FD log log)
- retcode log))))
- (define (status)
- (let ((t (assoc retcode '((0 "PASS") (77 "SKIP") (99 "ERROR")))))
- (if (not t) "FAIL" (cadr t))))
- (define (report)
- (unless (= logfd CLOSED_FD)
- (seek logfd 0 SEEK_SET)
- (splice logfd STDERR_FILENO)
- (close logfd))
- (echo (string-append (status retcode) ":") name))))))
-
-(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-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')))))))
-
(let* ((runner (if (member "--parallel" *args*)
run-tests-parallel
run-tests-sequential))
--
Alioth's /usr/local/bin/git-commit-notice on /srv/git.debian.org/git/pkg-gnupg/gnupg2.git
More information about the Pkg-gnupg-commit
mailing list