[Gd-chatter] r11723 - trunk/libraries/programming-tools/testworks
housel at gwydiondylan.org
housel at gwydiondylan.org
Sat Mar 1 18:39:12 CET 2008
Author: housel
Date: Sat Mar 1 18:39:11 2008
New Revision: 11723
Modified:
trunk/libraries/programming-tools/testworks/components.dylan
trunk/libraries/programming-tools/testworks/reports.dylan
trunk/libraries/programming-tools/testworks/suites.dylan
trunk/libraries/programming-tools/testworks/tests.dylan
trunk/libraries/programming-tools/testworks/testworks-lib.dylan
trunk/libraries/programming-tools/testworks/testworks.dylan
Log:
Bug: 7373
Mark tests that execute no checks as "not implemented".
* testworks/testworks-lib.dylan (define module testworks): Update
export list to match the new API.
* testworks/testworks.dylan
(<result-status>): Add #"not-implemented" as a new status.
(status-name): Add a new case for #"not-implemented".
* testworks/components.dylan
(maybe-execute-component): Use the make-result factory method to
construct the result object of a <component>.
* testworks/suites.dylan
(execute-component): Mark suites as not-implemented if they have no
subresults.
(make-result): Factory method for constructing <component-result> objects.
* testworks/tests.dylan
(test-allow-empty?): New slot in class <test> for noting when a test
might dynamically elide checks, to prevent it from being marked
not-implemented.
(<test-unit>): Subclass of <test> for tests created by \with-test-unit.
(<test-unit-result>): Result class for <test-unit> tests.
(result-type-name): New method on <test-unit-result>.
(record-test-unit-crash): Deleted.
(with-test-unit): Instead of running the body of with-test-unit and
recording it as a failed check if an error occurs, dynamically
create a <test-unit> object and execute it using perform-test.
(execute-component): Mark tests as not-implemented if they do not
execute any checks (unless they are marked with allow-empty: #t).
(make-result): Factory methods for constructing <component-result> objects.
* testworks/reports.dylan
(count-results): Count not-implemented tests.
(print-result-summary): Print the count of not-implemented tests.
(failures-report-function): Print not-implemented tests in the
failure report.
Modified: trunk/libraries/programming-tools/testworks/components.dylan
==============================================================================
--- trunk/libraries/programming-tools/testworks/components.dylan (original)
+++ trunk/libraries/programming-tools/testworks/components.dylan Sat Mar 1 18:39:11 2008
@@ -98,13 +98,6 @@
else
values(#(), #"not-executed")
end;
- let result-class = select (component by instance?)
- <test> => <test-result>;
- <suite> => <suite-result>;
- end;
- make(result-class,
- name: component.component-name,
- status: perform-status,
- subresults: subresults)
+ make-result(component, subresults, perform-status)
end method maybe-execute-component;
Modified: trunk/libraries/programming-tools/testworks/reports.dylan
==============================================================================
--- trunk/libraries/programming-tools/testworks/reports.dylan (original)
+++ trunk/libraries/programming-tools/testworks/reports.dylan Sat Mar 1 18:39:11 2008
@@ -46,23 +46,26 @@
define method count-results
(result :: <result>, #key test = always(#t))
=> (passes :: <integer>, failures :: <integer>,
- not-executed :: <integer>, crashes :: <integer>)
- let passes = 0;
- let failures = 0;
- let not-executed = 0;
- let crashes = 0;
+ not-executed :: <integer>, not-implemented :: <integer>,
+ crashes :: <integer>)
+ let passes = 0;
+ let failures = 0;
+ let not-executed = 0;
+ let not-implemented = 0;
+ let crashes = 0;
do-results
(method (result)
select (result.result-status)
- #"passed" => passes := passes + 1;
- #"failed" => failures := failures + 1;
- #"not-executed" => not-executed := not-executed + 1;
- otherwise => crashes := crashes + 1;
+ #"passed" => passes := passes + 1;
+ #"failed" => failures := failures + 1;
+ #"not-executed" => not-executed := not-executed + 1;
+ #"not-implemented" => not-implemented := not-implemented + 1;
+ otherwise => crashes := crashes + 1;
end
end,
result,
test: test);
- values(passes, failures, not-executed, crashes)
+ values(passes, failures, not-executed, not-implemented, crashes)
end method count-results;
/*
@@ -232,17 +235,17 @@
(result :: <result>, name :: <string>,
#key test = always(#t))
=> ()
- let (passes, failures, not-executed, crashes)
+ let (passes, failures, not-executed, not-implemented, crashes)
= count-results(result, test: test);
- let total-results = passes + failures + crashes;
+ let total-results = passes + failures + not-implemented + crashes;
test-output(" Ran %d %s%s %d passed (",
total-results,
name,
if (total-results == 1) ": " else "s: " end,
passes);
print-percentage(passes, total-results);
- test-output("), %d failed, %d not executed, %d crashed\n",
- failures, not-executed, crashes);
+ test-output("), %d failed, %d not executed, %d not implemented, %d crashed\n",
+ failures, not-executed, not-implemented, crashes);
end method print-result-summary;
define method print-result-class-summary
@@ -311,7 +314,7 @@
(result,
test: method (result)
let status = result.result-status;
- status == #"failed" | instance?(status, <error>)
+ status ~== #"passed" & status ~== #"not-executed"
end);
test-output("\n");
end;
Modified: trunk/libraries/programming-tools/testworks/suites.dylan
==============================================================================
--- trunk/libraries/programming-tools/testworks/suites.dylan (original)
+++ trunk/libraries/programming-tools/testworks/suites.dylan Sat Mar 1 18:39:11 2008
@@ -172,6 +172,8 @@
add!(subresults, subresult)
end;
case
+ empty?(subresults) =>
+ #"not-implemented";
every?(method (subresult)
let status = subresult.result-status;
status = #"passed" | status = #"not-executed"
@@ -186,3 +188,12 @@
end;
values(subresults, status)
end method execute-component;
+
+define method make-result
+ (suite :: <suite>, subresults :: <sequence>, status :: <result-status>)
+ => (result :: <component-result>)
+ make(<suite-result>,
+ name: suite.component-name,
+ status: status,
+ subresults: subresults)
+end method make-result;
Modified: trunk/libraries/programming-tools/testworks/tests.dylan
==============================================================================
--- trunk/libraries/programming-tools/testworks/tests.dylan (original)
+++ trunk/libraries/programming-tools/testworks/tests.dylan Sat Mar 1 18:39:11 2008
@@ -12,8 +12,13 @@
define class <test> (<component>)
constant slot test-function :: <function>,
required-init-keyword: function:;
+ constant slot test-allow-empty? :: <boolean>,
+ init-value: #f, init-keyword: allow-empty:;
end class <test>;
+define class <test-unit> (<test>)
+end class <test-unit>;
+
define constant $test-objects-table = make(<table>);
define method find-test-object
@@ -36,6 +41,14 @@
"Check"
end;
+define class <test-unit-result> (<test-result>, <unit-result>)
+end;
+
+define method result-type-name
+ (result :: <test-unit-result>) => (name :: <string>)
+ "Test unit"
+end;
+
define class <benchmark-result> (<unit-result>)
constant slot result-seconds :: false-or(<integer>),
required-init-keyword: seconds:;
@@ -75,19 +88,16 @@
// with-test-unit macro
-//---*** Can we do something better than pretend this was a check?
-define method record-test-unit-crash
- (name :: <string>, error :: <error>) => ()
- let unit-name :: <byte-string>
- = concatenate-as(<byte-string>, "Test unit ", name);
- record-check(unit-name, error, error, #f)
-end method record-test-unit-crash;
-
define macro with-test-unit
{ with-test-unit (?name:expression, ?keyword-args:*) ?test-body:body end }
=> { begin
- let error = maybe-trap-errors(begin ?test-body; #f end);
- error & record-test-unit-crash(?name, error)
+ let test
+ = make(<test-unit>,
+ name: concatenate("Test unit ", ?name),
+ function: method () ?test-body end,
+ ?keyword-args);
+ let result = perform-test(test, report-function: #f);
+ *check-recording-function*(result);
end; }
end macro with-test-unit;
@@ -162,6 +172,8 @@
case
instance?(error, <error>) =>
error;
+ empty?(subresults) & ~test.test-allow-empty? =>
+ #"not-implemented";
every?(method (result :: <unit-result>) => (passed? :: <boolean>)
result.result-status == #"passed"
end,
@@ -174,6 +186,26 @@
values(subresults, status)
end method execute-component;
+define method make-result
+ (test :: <test>, subresults :: <sequence>, status :: <result-status>)
+ => (result :: <component-result>)
+ make(<test-result>,
+ name: test.component-name,
+ status: status,
+ subresults: subresults)
+end method make-result;
+
+define method make-result
+ (test :: <test-unit>, subresults :: <sequence>, status :: <result-status>)
+ => (result :: <component-result>)
+ make(<test-unit-result>,
+ name: test.component-name,
+ status: status,
+ subresults: subresults,
+ operation: test.test-function,
+ value: #f)
+end method make-result;
+
/// Some progress functions
define method null-progress-function
Modified: trunk/libraries/programming-tools/testworks/testworks-lib.dylan
==============================================================================
--- trunk/libraries/programming-tools/testworks/testworks-lib.dylan (original)
+++ trunk/libraries/programming-tools/testworks/testworks-lib.dylan Sat Mar 1 18:39:11 2008
@@ -67,6 +67,7 @@
// Tests
export <test>,
test-definer,
+ <test-unit>,
\with-test-unit,
test-function,
perform-test,
@@ -104,6 +105,7 @@
do-results,
<check-result>,
+ <test-unit-result>,
<benchmark-result>,
$benchmark-result-divider,
print-one-benchmark-result,
@@ -139,6 +141,5 @@
do-check,
do-check-condition,
do-benchmark,
- record-test-unit-crash,
print-failure-reason;
end module testworks;
Modified: trunk/libraries/programming-tools/testworks/testworks.dylan
==============================================================================
--- trunk/libraries/programming-tools/testworks/testworks.dylan (original)
+++ trunk/libraries/programming-tools/testworks/testworks.dylan Sat Mar 1 18:39:11 2008
@@ -21,7 +21,11 @@
/// Result handling
define constant <result-status>
- = type-union(one-of(#"passed", #"failed", #"not-executed"), <error>);
+ = type-union(one-of(#"passed",
+ #"failed",
+ #"not-executed",
+ #"not-implemented"),
+ <error>);
define method status-name
(status :: <result-status>) => (name :: <string>)
@@ -29,6 +33,7 @@
#"passed" => "passed";
#"failed" => "failed";
#"not-executed" => "not executed";
+ #"not-implemented" => "not implemented";
otherwise => "crashed";
end
end method status-name;
More information about the chatter
mailing list