Added XML format for test results and updated testworks-report to rea…

…d the new format.

Also added check-no-condition for symmetry with check-condition.

checks.dylan

@@ -65,6 +65,12 @@ define macro check-condition
                             end) }
 end macro check-condition;
 
+// Same as check-no-errors, for symmetry with check-condition...
+define macro check-no-condition
+  { check-no-condition(?check-name:expression, ?check-body:expression) }
+    => { check-true(?check-name, begin ?check-body; #t end) }
+end macro check-no-condition;
+
 define macro check-no-errors
   { check-no-errors(?check-name:expression, ?check-body:expression) }
     => { check-true(?check-name, begin ?check-body; #t end) }

command-line.dylan

@@ -17,6 +17,15 @@ define constant $INVALID-REPORT-FUNCTION  = 5;
 define constant $INVALID-COMMAND-LINE-ARG = 6;
 define constant $INVALID-DEBUG-OPTION     = 7;
 
+define table $report-functions :: <string-table> = {
+    "none"     => null-report-function,
+    "full"     => full-report-function,
+    "summary"  => summary-report-function,
+    "failures" => failures-report-function,
+    "log"      => log-report-function,
+    "xml"      => xml-report-function
+    };
+
 // Encapsulates the components to be ignored
 
 define class <perform-criteria> (<perform-options>)
@@ -90,13 +99,7 @@ define method display-run-options
         full-progress-function => "full";
         null-progress-function => "none";
       end,
-      select (report-function)
-        full-report-function     => "full";
-        failures-report-function => "failures";
-        summary-report-function  => "summary";
-        null-report-function     => "none";
-        log-report-function      => "log";
-      end,
+      find-key($report-functions, curry(\=, report-function)),
       select (options.perform-debug?)
         #"crashes" => "crashes";
         #t         => "failures";
@@ -154,7 +157,7 @@ define method help-function (appname :: <string>) => ()
              "             [-debug [never | failures | crashes]]\n"
              "             [-quiet]\n"
              "             [-progress | -noprogress]\n"
-             "             [-report [none | full | failures | summary | log]]\n"
+             "             [-report [none | full | failures | summary | log | xml]]\n"
              "             [-suite <name1> <name2> ... ...]\n"
              "             [-test <name1> <name2> ... ...]\n"
              "             [-top]\n"
@@ -222,22 +225,12 @@ define method compute-application-options
         "noprogress" => 
           options.perform-progress-function := null-progress-function;
         "report" =>
-          report-function
-            := begin
-                 let function-name = pop(arguments);
-                 select (function-name by \=)
-                   "none"     => null-report-function;
-                   "full"     => full-report-function;
-                   "summary"  => summary-report-function;
-                   "failures" => failures-report-function;
-                   "log"      => log-report-function;
-                   otherwise =>
-                     application-error($INVALID-REPORT-FUNCTION,
-                                       "Report function '%s' not supported.\n"
-                                       "Use -help for available options\n",
-                                       function-name);
-                 end select
-               end;
+          let function-name = pop(arguments);
+          report-function := element($report-functions, function-name, default: #f)
+            | application-error($INVALID-REPORT-FUNCTION,
+                                "Report function '%s' not supported.\n"
+                                "Use -help for available options\n",
+                                function-name);
         "suite" =>
           run-suites
             := concatenate(run-suites, argument-value(option, arguments));
@@ -257,8 +250,6 @@ define method compute-application-options
             := concatenate(ignore-tests,  argument-value(option, arguments));
         "quiet" =>
           quiet? := #t;
-        "verbose" =>
-          quiet? := #f;
         otherwise =>
           application-warning($INVALID-COMMAND-LINE-ARG,
                               "Unknown command line keyword '%s': leaving for application.\n"
@@ -315,7 +306,7 @@ define method run-test-application
 
   // Run the appropriate test or suite
   block ()
-    unless (quiet?)
+    unless (quiet? | report-function = xml-report-function)
       display-run-options(start-suite, report-function, options)
     end;
     let result = #f;

reports.dylan

@@ -385,3 +385,87 @@ define method log-report-function (result :: <result>) => ()
   failures-report-function(result)
 end method log-report-function;
 
+define method generate-xml-report
+    (result :: <result>)
+ => ()
+  let test-type = result-type-name(result);
+  let status = result.result-status;
+  let kids = make(<stretchy-vector>);
+  add!(kids, with-xml() name { text(result-name(result)) } end);
+  add!(kids, with-xml() status { text(status.status-name) } end);
+  if (instance?(result, <benchmark-result>))
+    add!(kids, with-xml()
+                 seconds { text(integer-to-string(result-seconds(result))) }
+               end);
+    add!(kids, with-xml()
+                 microseconds { text(integer-to-string(result-microseconds(result))) }
+               end);
+    add!(kids, with-xml()
+                 allocation { text(integer-to-string(result-bytes(result))) }
+               end);
+  end;
+  local method add-reason();
+          let operation = result-operation(result);
+          let value = result-value(result);
+          let reason = block ()
+                         failure-reason(status, operation, value)
+                       exception (ex :: <error>)
+                         "***error getting failure reason***"
+                       end;
+          if (reason)
+            add!(kids, with-xml() reason { text(reason) } end);
+          end;
+        end method;
+  if (object-class(result) = <test-unit-result>)
+    add-reason();
+    for (subresult in result-subresults(result))
+      add!(kids, generate-xml-report(subresult));
+    end;
+  elseif (instance?(result, <component-result>))
+    if (instance?(status, <error>))
+      add!(kids, with-xml() reason { text(safe-error-to-string(status)) } end);
+    end;
+    for (subresult in result-subresults(result))
+      add!(kids, generate-xml-report(subresult));
+    end
+  else
+    add-reason();
+  end;
+  make(<element>,
+       name: test-type,
+       children: kids,
+       attributes: #[])
+end method generate-xml-report;
+
+define constant $xml-version-header
+  = "<?xml version=\"1.0\" encoding=\"ISO-8859-1\"?>";
+
+define method xml-report-function
+    (result :: <result>) => ()
+  let pi = make(<processing-instruction>,
+                name: "xml",
+                attributes: vector(make(<attribute>,
+                                        name: "version",
+                                        value: "1.0"),
+                                   make(<attribute>,
+                                        name: "encoding",
+                                        value: "ISO-8859-1")));
+  let report = with-xml()
+                 test-report {
+                   do(collect(generate-xml-report(result)))
+                   /* failures-report-function needs to be able to output
+                      (preferably XML) to a string before this will work...
+                   summary {
+                     do (collect(with-xml()
+                                   text(failures-report-function(result))
+                                 end))
+                   }
+                   */
+                 }
+               end with-xml;
+  let doc = make(<document>,
+                 children: list(pi, report));
+  test-output("%s", doc);
+end method xml-report-function;
+
+

tests.dylan

@@ -46,7 +46,7 @@ end;
 
 define method result-type-name
     (result :: <test-unit-result>) => (name :: <string>)
-  "Test unit"
+  "Test-unit"
 end;
 
 define class <benchmark-result> (<unit-result>)
@@ -235,4 +235,4 @@ define method print-result-info
                          result.result-value)
   end
 end method print-result-info;
-    
+

testworks-lib.dylan

@@ -10,6 +10,8 @@ Warranty:     Distributed WITHOUT WARRANTY OF ANY KIND
 define library testworks
   use common-dylan;
   use io;
+  use xml-parser,
+    import: { simple-xml, xml-parser };
 
   export testworks;
 end library testworks;
@@ -19,6 +21,8 @@ define module testworks
   use format-out;
   use threads,
     import: { dynamic-bind };
+  use simple-xml;
+  use xml-parser;
 
   // Debugging options
   export *debug?*,
@@ -55,6 +59,7 @@ define module testworks
   // Checks
   export check,
          check-condition,
+         check-no-condition,
          check-equal,
          check-false,
          check-no-errors,
@@ -124,14 +129,16 @@ define module testworks
          summary-report-function,
          failures-report-function,
          full-report-function,
-         log-report-function;
+         log-report-function,
+         xml-report-function;
 
   // Command line handling
   export run-test-application;
 
   // Internals for use by testworks-test-suite
   export $test-log-header,
          $test-log-footer,
+         $xml-version-header,
          *check-recording-function*,
          failure-reason,
          safe-error-to-string;