[git] GnuPG - branch, master, updated. gnupg-2.1.20-108-gd6b4646
by Justus Winter
cvs at cvs.gnupg.org
Thu May 4 15:24:00 CEST 2017
This is an automated email from the git hooks/post-receive script. It was
generated because a ref change was pushed to the repository containing
the project "The GNU Privacy Guard".
The branch, master has been updated
via d6b46462f8c5c705ffb7cf8af03465a926aa11d3 (commit)
from eab0138e3179f247180a639a91570e5ee2c6ad0e (commit)
Those revisions listed above that are new to this repository have
not appeared on any other notification email; so we list those
revisions in full, below.
- Log -----------------------------------------------------------------
commit d6b46462f8c5c705ffb7cf8af03465a926aa11d3
Author: Justus Winter <justus at g10code.com>
Date: Thu May 4 15:12:49 2017 +0200
tests: Support tests that are expected to fail.
* tests/gpgscm/tests.scm (test-pool): Rework reporting. Filter using
the computed test status instead of the return value. Also print the
new categories 'failed expectedly' and 'passed unexpectedly'.
(test): If a test ends with a bang (!), it is expected to fail. Adapt
status, status-string, and xml accordingly.
--
Allow tests to be marked as being expected to fail by appending a bang
(!) to the tests name. If such a test fails, it will not be counted
as failure, but will still be prominently displayed in the report. If
it succeeds unexpectedly, this is counted as a failure.
Fixes T3134.
GnuPG-bug-id: 3134
Signed-off-by: Justus Winter <justus at g10code.com>
diff --git a/tests/gpgscm/tests.scm b/tests/gpgscm/tests.scm
index c6c887f..e5ec5c7 100644
--- a/tests/gpgscm/tests.scm
+++ b/tests/gpgscm/tests.scm
@@ -521,31 +521,29 @@
(map pid->test pids)
(wait-processes (map stringify names) pids #t)))))
(current-environment))
- (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 (filter-tests status)
+ (filter (lambda (p) (eq? status (p::status))) procs))
(define (report)
(define (print-tests tests message)
(unless (null? tests)
(apply echo (cons message
(map (lambda (t) t::name) tests)))))
- (let ((failed' (failed)) (skipped' (skipped)))
+ (let ((failed (filter-tests 'FAIL))
+ (xfailed (filter-tests 'XFAIL))
+ (xpassed (filter-tests 'XPASS))
+ (skipped (filter-tests 'SKIP)))
(echo (length procs) "tests run,"
- (length (passed)) "succeeded,"
- (length failed') "failed,"
- (length skipped') "skipped.")
- (print-tests failed' "Failed tests:")
- (print-tests skipped' "Skipped tests:")
- (length failed')))
+ (length (filter-tests 'PASS)) "succeeded,"
+ (length failed) "failed,"
+ (length xfailed) "failed expectedly,"
+ (length xpassed) "succeeded unexpectedly,"
+ (length skipped) "skipped.")
+ (print-tests failed "Failed tests:")
+ (print-tests xfailed "Expectedly failed tests:")
+ (print-tests xpassed "Unexpectedly passed tests:")
+ (print-tests skipped "Skipped tests:")
+ (+ (length failed) (length xpassed))))
(define (xml)
(xx::document
@@ -580,24 +578,34 @@
":"
(substring t 13 15)))
+ ;; If a tests name ends with a bang (!), it is expected to fail.
+ (define (expect-failure? name)
+ (string-suffix? name "!"))
+ ;; Strips the bang (if any).
+ (define (test-name name)
+ (if (expect-failure? name)
+ (substring name 0 (- (string-length name) 1))
+ name))
+
(package
(define (scm setup name path . args)
;; Start the process.
(define (spawn-scm args' in out err)
(spawn-process-fd `(,*argv0* ,@(verbosity (*verbose*))
- ,(locate-test path)
+ ,(locate-test (test-name path))
,@(if setup (force setup) '())
, at args' , at args) in out err))
- (new name #f spawn-scm #f #f CLOSED_FD))
+ (new name #f spawn-scm #f #f CLOSED_FD (expect-failure? name)))
(define (binary setup name path . args)
;; Start the process.
(define (spawn-binary args' in out err)
- (spawn-process-fd `(,path ,@(if setup (force setup) '()) , at args' , at args)
+ (spawn-process-fd `(,(test-name path)
+ ,@(if setup (force setup) '()) , at args' , at args)
in out err))
- (new name #f spawn-binary #f #f CLOSED_FD))
+ (new name #f spawn-binary #f #f CLOSED_FD (expect-failure? name)))
- (define (new name directory spawn pid retcode logfd)
+ (define (new name directory spawn pid retcode logfd expect-failure)
(package
;; XXX: OO glue.
@@ -653,13 +661,18 @@
(set! logfd log))
(current-environment))
(define (status)
- (let ((t (assoc retcode '((0 PASS) (77 SKIP) (99 ERROR)))))
- (if (not t) 'FAIL (cadr t))))
+ (let* ((t' (assoc retcode '((0 PASS) (77 SKIP) (99 ERROR))))
+ (t (if (not t') 'FAIL (cadr t'))))
+ (if expect-failure
+ (case t ((PASS) 'XPASS) ((FAIL) 'XFAIL) (else t))
+ t)))
(define (status-string)
(cadr (assoc (status) '((PASS "PASS")
(SKIP "SKIP")
(ERROR "ERROR")
- (FAIL "FAIL")))))
+ (FAIL "FAIL")
+ (XPASS "XPASS")
+ (XFAIL "XFAIL")))))
(define (report)
(unless (= logfd CLOSED_FD)
(seek logfd 0 SEEK_SET)
@@ -686,7 +699,7 @@
(classname ,(string-translate (dirname name) "/" "."))
(time ,(- end-time start-time)))
`(,@(case (status)
- ((PASS) '())
+ ((PASS XFAIL) '())
((SKIP) (list (xx::tag 'skipped)))
((ERROR) (list
(xx::tag 'error '((message "Unknown error.")))))
-----------------------------------------------------------------------
Summary of changes:
tests/gpgscm/tests.scm | 67 ++++++++++++++++++++++++++++++--------------------
1 file changed, 40 insertions(+), 27 deletions(-)
hooks/post-receive
--
The GNU Privacy Guard
http://git.gnupg.org
More information about the Gnupg-commits
mailing list