tests: Support tests that are expected to fail.
authorJustus Winter <justus@g10code.com>
Thu, 4 May 2017 13:12:49 +0000 (15:12 +0200)
committerJustus Winter <justus@g10code.com>
Thu, 4 May 2017 13:22:52 +0000 (15:22 +0200)
* 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>
tests/gpgscm/tests.scm

index c6c887f..e5ec5c7 100644 (file)
                 (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
                   ":"
                   (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) '())
                                    ,@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)
      ;; Start the process.
      (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))
-     (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.
          (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)
                     (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.")))))