security-and-privacy/gnupg
security-and-privacy/gnupg
1
0
Fork 0
mirror of git://git.gnupg.org/gnupg.git synced 2025-04-17 15:44:34 +02:00
Code Activity

tests: Support tests that are expected to fail.

Browse Source 
* 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@g10code.com>
This commit is contained in:
Justus Winter 2017-05-04 15:12:49 +02:00
parent eab0138e31
commit d6b46462f8
No known key found for this signature in database
GPG Key ID: DD1A52F9DA8C9020
1 changed files with 40 additions and 27 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

67
tests/gpgscm/tests.scm
View File

@ -521,31 +521,29 @@
(map pid->test pids) (map pid->test pids)
(wait-processes (map stringify names) pids #t))))) (wait-processes (map stringify names) pids #t)))))
(current-environment)) (current-environment))
(define (passed) (define (filter-tests status)
(filter (lambda (p) (= 0 p::retcode)) procs)) (filter (lambda (p) (eq? status (p::status))) 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) (define (report)
(define (print-tests tests message) (define (print-tests tests message)
(unless (null? tests) (unless (null? tests)
(apply echo (cons message (apply echo (cons message
(map (lambda (t) t::name) tests))))) (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," (echo (length procs) "tests run,"
(length (passed)) "succeeded," (length (filter-tests 'PASS)) "succeeded,"
(length failed') "failed," (length failed) "failed,"
(length skipped') "skipped.") (length xfailed) "failed expectedly,"
(print-tests failed' "Failed tests:") (length xpassed) "succeeded unexpectedly,"
(print-tests skipped' "Skipped tests:") (length skipped) "skipped.")
(length failed'))) (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) (define (xml)
(xx::document (xx::document
@ -580,24 +578,34 @@
":" ":"
(substring t 13 15))) (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 (package
(define (scm setup name path . args) (define (scm setup name path . args)
;; Start the process. ;; Start the process.
(define (spawn-scm args' in out err) (define (spawn-scm args' in out err)
(spawn-process-fd `(,*argv0* ,@(verbosity (*verbose*)) (spawn-process-fd `(,*argv0* ,@(verbosity (*verbose*))
,(locate-test path) ,(locate-test (test-name path))
,@(if setup (force setup) '()) ,@(if setup (force setup) '())
,@args' ,@args) in out err)) ,@args' ,@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) (define (binary setup name path . args)
;; Start the process. ;; Start the process.
(define (spawn-binary args' in out err) (define (spawn-binary args' in out err)
(spawn-process-fd `(,path ,@(if setup (force setup) '()) ,@args' ,@args) (spawn-process-fd `(,(test-name path)
,@(if setup (force setup) '()) ,@args' ,@args)
in out err)) 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 (package
;; XXX: OO glue. ;; XXX: OO glue.
@ -653,13 +661,18 @@
(set! logfd log)) (set! logfd log))
(current-environment)) (current-environment))
(define (status) (define (status)
(let ((t (assoc retcode '((0 PASS) (77 SKIP) (99 ERROR))))) (let* ((t' (assoc retcode '((0 PASS) (77 SKIP) (99 ERROR))))
(if (not t) 'FAIL (cadr t)))) (t (if (not t') 'FAIL (cadr t'))))
(if expect-failure
(case t ((PASS) 'XPASS) ((FAIL) 'XFAIL) (else t))
t)))
(define (status-string) (define (status-string)
(cadr (assoc (status) '((PASS "PASS") (cadr (assoc (status) '((PASS "PASS")
(SKIP "SKIP") (SKIP "SKIP")
(ERROR "ERROR") (ERROR "ERROR")
(FAIL "FAIL"))))) (FAIL "FAIL")
(XPASS "XPASS")
(XFAIL "XFAIL")))))
(define (report) (define (report)
(unless (= logfd CLOSED_FD) (unless (= logfd CLOSED_FD)
(seek logfd 0 SEEK_SET) (seek logfd 0 SEEK_SET)
@ -686,7 +699,7 @@
(classname ,(string-translate (dirname name) "/" ".")) (classname ,(string-translate (dirname name) "/" "."))
(time ,(- end-time start-time))) (time ,(- end-time start-time)))
`(,@(case (status) `(,@(case (status)
((PASS) '()) ((PASS XFAIL) '())
((SKIP) (list (xx::tag 'skipped))) ((SKIP) (list (xx::tag 'skipped)))
((ERROR) (list ((ERROR) (list
(xx::tag 'error '((message "Unknown error."))))) (xx::tag 'error '((message "Unknown error.")))))