diff options
| -rw-r--r-- | tests/gpgscm/tests.scm | 151 | ||||
| -rw-r--r-- | 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 d360272fd..dd4c69fbf 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) ,@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 ,@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 cea50db24..a7c282e5e 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) ,@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 ,@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)) |