Support extended test status in reports. Add the tests to git. Better…

… formatting of test status in the library log.

reports-generated/style.css

@@ -1,15 +1,18 @@
 /* Results */
 
-a.ok {
-    color: green;
-}	
+.test-status {
+}
 
-a.fail {
+.fail-status {
     color: red;
 }
 
-a.no-resource {
-    color :#7A7A7A;
+.no-resource-status {
+    color: #7A7A7A;
+}
+
+.ok-status {
+    color: green;
 }
 
 .timestamp {

test-grid-tests.asd

@@ -0,0 +1,22 @@
+;;; -*- Mode: LISP; Syntax: COMMON-LISP; indent-tabs-mode: nil; coding: utf-8;  -*-
+;;;
+;;; Copyright (C) 2011 Anton Vodonosov (avodonosov@yandex.ru)
+;;;
+;;; See LICENSE for details.
+
+(asdf:defsystem #:test-grid-tests
+  :version "0.1.0"
+  :serial t
+  :depends-on (#:test-grid)
+  :components ((:file "test-grid-tests")))
+
+(defpackage #:test-grid-tests-config (:export #:*src-base-dir*))
+(defparameter test-grid-tests-config:*src-base-dir*
+  (make-pathname :name nil :type nil :defaults *load-truename*))
+
+;; make sample test suites available to ASDF
+(pushnew (merge-pathnames "sample-test-suites/"
+                          test-grid-tests-config:*src-base-dir*)
+         asdf:*central-registry*
+         :test #'equal)
+

test-grid-tests.lisp

@@ -0,0 +1,34 @@
+(defpackage #:test-grid-tests
+  (:use :cl))
+
+(in-package #:test-grid-tests)
+
+(defun test-rt-api ()
+  (test-grid::require-impl '#:rt-api)
+  (rt-api:clean)
+
+  (asdf:clear-system :rt-sample-test-suite)
+  (asdf:operate 'asdf:load-op :rt-sample-test-suite)
+
+  (let ((status (test-grid::run-rt-test-suite)))
+    (and (test-grid::set= (getf status :failed-tests)
+                          '("test-1" "test-4")
+                          :test #'string=)
+         (test-grid::set= (getf status :known-to-fail)
+                          '("test-3")
+                          :test #'string=))))
+
+(defun test-aggregated-status ()
+  (and (eq :ok (test-grid::aggregated-status :ok))
+       (eq :fail (test-grid::aggregated-status :fail))
+       (eq :no-resource (test-grid::aggregated-status :no-resource))
+       (eq :fail (test-grid::aggregated-status '(:failed-tests ("a") :known-to-fail ("b"))))
+       (eq :fail (test-grid::aggregated-status '(:failed-tests () :known-to-fail ("b"))))
+       (eq :fail (test-grid::aggregated-status '(:failed-tests ("a") :known-to-fail ())))
+       (eq :known-fail (test-grid::aggregated-status '(:failed-tests ("a") :known-to-fail ("a"))))
+       (eq :ok (test-grid::aggregated-status '(:failed-tests () :known-to-fail ())))))
+
+; to run the tests: 
+(and (test-aggregated-status)
+     (test-rt-api))
+; expected to return T

test-grid.lisp

@@ -465,6 +465,10 @@ if all the tests succeeded and NIL othersize."
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;; Utils
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(defun set= (set-a set-b &key (test #'eql) key)
+  (null (set-exclusive-or set-a set-b :test test :key key)))
+
 (defun do-plist-impl (plist handler)
   (do* ((cur-pos plist (cddr cur-pos))
         (prop (first cur-pos) (first cur-pos))
@@ -733,7 +737,7 @@ data (libraries test suites output and the run results) will be saved."
     (fresh-line stream)
     (terpri stream)
     (format stream "============================================================~%")
-    (format stream "  cl-test-grid status for ~A: ~A~%" libname status)
+    (format stream "  cl-test-grid status for ~A: ~S~%" libname status)
     (format stream "============================================================~%")))
 
 (defun run-libtest (lib run-descr log-directory)
@@ -1031,25 +1035,40 @@ to the cl-test-grid issue tracker:
         (blob-uri blob-key)
         "javascript:alert('The blobstore key is not specified, seems like the library log was not submitted to the online storage')")))
 
-(defun single-letter-status (normalized-status) 
-  (case normalized-status
+(defun aggregated-status (normalized-status)
+  "Returns the test resutl as one symbol, even
+if it was an \"extended status\". Possible return
+values: :OK, :FAIL, :NO-RESOURSE, :KNOWN-FAIL."
+  (etypecase normalized-status
+    (symbol normalized-status)
+    (list (destructuring-bind (&key failed-tests known-to-fail) normalized-status
+            (cond ((and (null failed-tests)
+                        (null known-to-fail))
+                   :ok)
+                  ((set= failed-tests known-to-fail :test #'string=)
+                   :known-fail)
+                  (t :fail))))))
+
+(defun single-letter-status (aggregated-status) 
+  (case aggregated-status
     (:ok "O")
     (:fail "F")
+    (:known-fail "K")
     (:no-resource "R")
-    (otherwise normalized-status)))
+    (otherwise aggregated-status)))
 
-(defun status-css-class (normalized-status) 
-  (case normalized-status
+(defun status-css-class (aggregated-status) 
+  (case aggregated-status
     (:ok "ok-status")
-    (:fail "fail-status")
+    ((:known-fail :fail) "fail-status")
     (:no-resource "no-resource-status")
     (otherwise "")))
 
 (defun render-single-letter-status (test-run lib-test-result)
   (declare (ignore test-run))
   (if (null lib-test-result)
       " "
-      (let ((status (normalize-status (getf lib-test-result :status))))
+      (let ((status (aggregated-status (getf lib-test-result :status))))
         (format nil "<a class=\"test-status ~A\" href=\"~A\">~A</a>" 
                 (status-css-class status)
                 (lib-log-uri lib-test-result)
@@ -1098,7 +1117,7 @@ to the cl-test-grid issue tracker:
                 (getf run-descr :lisp)
                 (getf (getf run-descr :contact) :email)
                 (string-downcase (getf lib-result :libname))
-                (getf lib-result :status)
+                (aggregated-status (getf lib-result :status))
                 (float (getf lib-result :test-duration)))))))
 
 ;; ========= Pivot Reports ==================
@@ -1237,11 +1256,12 @@ as a parameter"
 
 (defun format-lib-results (out lib-results)
   (dolist (lib-result lib-results)
-    (format out "<a href=\"~a\" class=\"~a\">~a</a> " 
-            (lib-log-uri lib-result)
-            (string-downcase (getf lib-result :status))
-            (string-downcase (getf lib-result :status)))))
-
+    (let ((status (aggregated-status (getf lib-result :status))))
+      (format out "<a href=\"~a\" class=\"test-status ~a\">~a</a> "
+              (lib-log-uri lib-result)
+              (string-downcase status)
+              (status-css-class status)))))
+
 (defun print-row-header (row-addr row-spans out)
   (dolist (subaddr (subaddrs row-addr))
     (let* ((helper (gethash subaddr row-spans))

test-runs-report-template.html

@@ -24,19 +24,11 @@
             font-weight: bold;
         }
 
-        .fail-status {
-            color: red;
-        }
-
         .no-resource-status {
             color: black;
         }
 
-        .ok-status {
-            color: green;
-        }
-
-</style>
+    </style>
 
 </head>
 <body>
@@ -47,6 +39,8 @@ <h4>Legend</h4>
         <p>Library test statuses:
             <ul>
                 <li><span class="test-status fail-status">F</span> stands for FAIL</li>
+                <li><span class="test-status fail-status">K</span> stands for Known FAIL - test failures
+                        exist, but all the failures are already known for the library developers.</li>
                 <li><span class="test-status ok-status">O</span> stands for OK</li>
                 <li><span class="test-status no-resource-status">R</span> stands for No Resourse - the test suite 
                         can not be run because some required