Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Browse files

Use a <test-runner> to run tests instead of <perform-options> and thr…

…ead variables.
  • Loading branch information...
commit e5e05480393eb6e886444a844248486eed467f59 1 parent 48c5b54
@cgay cgay authored
View
10 assertions.dylan
@@ -59,7 +59,7 @@ define function do-check-equal
block (return)
let handler <serious-condition>
= method (condition, next-handler)
- if (*debug?*)
+ if (debug?())
next-handler() // decline to handle it
else
return(record-check(name | format-to-string("*** Invalid check name ***"),
@@ -138,7 +138,7 @@ define function do-check-instance?
block (return)
let handler <serious-condition>
= method (condition, next-handler)
- if (*debug?*)
+ if (debug?())
next-handler() // decline to handle it
else
record-check(name | format-to-string("*** Invalid check name ***"),
@@ -196,7 +196,7 @@ define function do-check-true
block (return)
let handler <serious-condition>
= method (condition, next-handler)
- if (*debug?*)
+ if (debug?())
next-handler() // decline to handle it
else
record-check(name | format-to-string("*** Invalid check name ***"),
@@ -256,7 +256,7 @@ define function do-check-false
block (return)
let handler <serious-condition>
= method (condition, next-handler)
- if (*debug?*)
+ if (debug?())
next-handler() // decline to handle it
else
record-check(name | format-to-string("*** Invalid check name ***"),
@@ -316,7 +316,7 @@ define function do-check-condition
block (return)
let handler <serious-condition>
= method (condition, next-handler)
- if (*debug?*)
+ if (debug?())
next-handler() // decline to handle it
else
record-check(name | format-to-string("*** Invalid check name ***"),
View
159 command-line.dylan
@@ -23,12 +23,6 @@ define function parse-args
default: #f,
help: "Show progress as tests are run."));
add-option(parser,
- make(<flag-option>,
- names: #("verbose"),
- negative-names: #("quiet"),
- default: #t,
- help: "Adjust output verbosity."));
- add-option(parser,
make(<parameter-option>,
names: #("report"),
default: "failures",
@@ -120,61 +114,34 @@ define method find-components
values(components)
end method find-components;
-define method display-run-options
- (start-suite :: <component>,
- report-function :: <function>,
- options :: <perform-options>)
- => ()
- format(*test-output*,
- "\nRunning %s %s, with options:\n"
- " progress-function: %s\n"
- " report-function: %s\n"
- " debug?: %s\n"
- " ignore: %s\n\n",
- component-type-name(start-suite),
- component-name(start-suite),
- select (options.perform-progress-function)
- full-progress-function => "full";
- null-progress-function => "none";
- end,
- find-key($report-functions, curry(\=, report-function)),
- select (options.perform-debug?)
- #"crashes" => "crashes";
- #t => "failures";
- otherwise => "no";
- end,
- join(options.perform-ignore, ", ", key: component-name));
-end method display-run-options;
-
-define method compute-application-options
+// Create a <test-runner> from command-line options.
+define function make-runner-from-command-line
(parent :: <component>, parser :: <command-line-parser>)
- => (start-suite :: <component>,
- options :: <perform-options>,
- report-function :: <function>)
+ => (start-suite :: <component>, runner :: <test-runner>, report-function :: <function>)
+ // TODO(cgay): Use init-keywords rather than setters so we can make <test-runner>
+ // immutable.
let debug = get-option-value(parser, "debug");
- let options
- = make(<perform-options>,
- list-suites?: get-option-value(parser, "list-suites"),
- list-tests?: get-option-value(parser, "list-tests"),
- debug?: select (debug by \=)
- #f, "no" => #f;
- "crashes" => #"crashes";
- #t, "failures" => #t;
- otherwise =>
- usage-error("Invalid --debug option: %s", debug);
- end select,
- ignore: find-components(get-option-value(parser, "ignore-suite"),
- get-option-value(parser, "ignore-test")));
- if (get-option-value(parser, "progress"))
- options.perform-progress-function := full-progress-function;
- options.perform-announce-function := announce-component;
- else
- options.perform-progress-function := null-progress-function;
- options.perform-announce-function := method (component) end;
- end;
let report = get-option-value(parser, "report") | "failures";
let report-function = element($report-functions, report, default: #f)
| usage-error("Invalid --report option: %s", report);
+ let runner = make(<test-runner>,
+ debug?: select (debug by \=)
+ #f, "no" => #f;
+ "crashes" => #"crashes";
+ #t, "failures" => #t;
+ otherwise =>
+ usage-error("Invalid --debug option: %s", debug);
+ end select,
+ ignore: find-components(get-option-value(parser, "ignore-suite"),
+ get-option-value(parser, "ignore-test")),
+ report: report);
+ if (get-option-value(parser, "progress"))
+ runner.runner-progress-function := full-progress-function;
+ runner.runner-announce-function := announce-component;
+ else
+ runner.runner-progress-function := null-progress-function;
+ runner.runner-announce-function := method (component) end;
+ end;
let components = find-components(get-option-value(parser, "suite"),
get-option-value(parser, "test"));
let start-suite = select (components.size)
@@ -186,67 +153,53 @@ define method compute-application-options
description: "arguments to -suite and -test",
components: components);
end select;
- values(start-suite, options, report-function)
-end method compute-application-options;
+ values(start-suite, runner, report-function)
+end function make-runner-from-command-line;
+// Run a test or suite. Uses a test runner created based on
+// command-line arguments. Use run-tests instead if you want to
+// create the test-runner yourself. Returns a <result> if any suites
+// or tests were executed; otherwise #f.
define method run-test-application
- (parent :: <component>,
- #key command-name = application-name(),
- arguments = application-arguments(),
- output-stream = *test-output*)
- => (result :: false-or(<result>))
- let parser = parse-args(arguments);
- let (start-suite, options, report-function)
+ (parent :: <component>) => (result :: false-or(<result>))
+ let parser = parse-args(application-arguments());
+ let (start-suite, runner, report-function)
= block ()
- compute-application-options(parent, parser)
+ make-runner-from-command-line(parent, parser)
exception (ex :: <usage-error>)
format(*standard-error*, "%s\n", condition-to-string(ex));
+ // TODO(cgay): The caller should decide whether to exit the
+ // application.
exit-application(2);
end;
- if (options.list-suites? | options.list-tests?)
- let results = list-component(start-suite, options);
- let final-results
- = choose(method (c :: <component>)
- (options.list-suites? & instance?(c, <suite>))
- | (options.list-tests? & instance?(c, <test>))
- end,
- results);
+ let list-suites? = get-option-value(parser, "list-suites");
+ let list-tests? = get-option-value(parser, "list-tests");
+ if (list-suites? | list-tests?)
+ let results = list-component(start-suite, runner);
+ let final-results = choose(method (c :: <component>)
+ (list-suites? & instance?(c, <suite>))
+ | (list-tests? & instance?(c, <test>))
+ end,
+ results);
for (component :: <component> in final-results)
- format(output-stream, "%s %s\n",
+ format(*standard-output*, "%s %s\n",
component.component-type-name, component.component-name)
end;
#f
else
// Run the appropriate test or suite
let pathname = get-option-value(parser, "report-file");
- block ()
- dynamic-bind (*test-output* = output-stream)
- if (get-option-value(parser, "verbose")
- & (report-function ~= xml-report-function)
- & (report-function ~= surefire-report-function))
- display-run-options(start-suite, report-function, options)
- end;
- let result = perform-component(start-suite, options, report-function: #f);
- if (pathname)
- *test-output* := make(<file-stream>,
- locator: pathname,
- direction: #"output",
- if-exists: #"overwrite");
- end;
- report-function & report-function(result);
- result
- end dynamic-bind
- afterwards
- end-test();
- cleanup
- pathname & close(output-stream);
- end block
+ let result = run-tests(runner, start-suite, report-function: #f);
+ if (pathname)
+ with-open-file(stream = pathname,
+ direction: #"output",
+ if-exists: #"overwrite")
+ report-function(runner, result, stream);
+ end;
+ else
+ report-function(result, *standard-output*);
+ end;
+ result
end if
end method run-test-application;
-
-define not-inline function end-test ()
- // This function isn't intended to do anything; it just provides a place
- // to set a breakpoint before the program terminates.
- values()
-end function end-test;
View
4 components.dylan
@@ -194,7 +194,7 @@ end macro test-definer;
// with-test-unit macro
-define thread variable *test-unit-options* = make(<perform-options>);
+define thread variable *test-unit-runner* = make(<test-runner>);
define macro with-test-unit
{ with-test-unit (?name:expression, ?keyword-args:*) ?test-body:body end }
@@ -204,7 +204,7 @@ define macro with-test-unit
name: concatenate("Test unit ", ?name),
function: method () ?test-body end,
?keyword-args);
- let result = perform-component(test, *test-unit-options*,
+ let result = perform-component(test, *test-unit-runner*,
report-function: #f);
*check-recording-function*(result);
end; }
View
40 gui/progress-window.dylan
@@ -201,50 +201,38 @@ end method handle-event;
/// Simple wrapper function
-// Note: These should be functions, but the emu messes up #all-keys then.
+// TODO(cgay): In the testworks library I replaced perform-{suite,test,component}
+// with run-tests. It should be done here too but I'm making minimal changes in
+// testworks-gui right now since it's difficult to test it.
-define method gui-perform-suite
+define function gui-perform-suite
(suite :: <suite>,
- #rest args,
- #key announce-function = gui-announce-function,
- announce-checks? = #t,
- #all-keys)
+ #rest args, #key announce-function = gui-announce-function, #all-keys)
=> (result :: <component-result>)
block ()
start-progress-window();
- dynamic-bind
- (*announce-check-function* = gui-progress-pause-with-check-name)
- apply
- (perform-suite,
- suite,
- announce-function: announce-function,
- announce-checks?: announce-checks?,
- args)
- end
+ apply(perform-suite, suite,
+ announce-function: announce-function,
+ args)
cleanup
exit-progress-window();
- end;
+ end
end method gui-perform-suite;
define method gui-perform-test
(test :: <test>,
#rest args,
#key announce-function = gui-announce-function,
- announce-checks? = #t,
#all-keys)
=> (result :: <component-result>)
block ()
start-progress-window();
- dynamic-bind
- (*announce-check-function* = gui-progress-pause-with-check-name)
- apply
- (perform-test,
- test,
- announce-function: announce-function,
- announce-checks?: announce-checks?,
- args)
+ apply(perform-test,
+ test,
+ announce-function: announce-function,
+ args)
end
cleanup
exit-progress-window();
- end;
+ end
end method gui-perform-test;
View
32 library.dylan
@@ -10,6 +10,7 @@ define library testworks
use command-line-parser;
use common-dylan, import: { common-dylan, threads };
use io, import: { format, standard-io, streams };
+ use strings, import: { string-equal-ic };
use system, import: { file-system };
export
@@ -23,7 +24,13 @@ define module testworks
// Top level
create
- run-test-application;
+ run-test-application,
+ run-tests,
+ <test-runner>,
+ runner-tags,
+ runner-announce-function,
+ runner-progress-function,
+ debug-runner?;
// Checks
create
@@ -47,12 +54,10 @@ define module testworks
// Suites
create
- perform-suite,
suite-definer;
// Tests
create
- perform-test,
test-definer,
with-test-unit;
@@ -73,39 +78,22 @@ define module %testworks
// Debugging options
export
- *debug?*,
debug-failures?,
debug?;
// Formatting
export
test-output,
- *test-output*,
plural;
- // Announcing suite/test/check names
- export
- *announce-checks?*,
- *announce-check-function*;
-
// Components
export
<component>,
execute-component?,
- perform-component,
component-name,
component-tags,
status-name;
- // Perform options
- export
- <perform-options>,
- perform-tags, perform-tags-setter,
- perform-announce-function, perform-announce-function-setter,
- perform-announce-checks?, perform-announce-checks?-setter,
- perform-progress-function, perform-progress-function-setter,
- perform-debug?, perform-debug?-setter;
-
// Tests
export
<test>,
@@ -169,7 +157,7 @@ define module %testworks
// Command line handling
export
- compute-application-options,
+ make-runner-from-command-line,
parse-args;
export
@@ -181,5 +169,5 @@ define module %testworks
// Internals -- mostly due to macro hygiene failures
export
$test-objects-table,
- *test-unit-options*;
+ *test-unit-runner*;
end module %testworks;
View
243 reports.dylan
@@ -62,7 +62,8 @@ end method count-results;
/// Summary generation
define method print-result-summary
- (result :: <result>, name :: <string>, #key test = always(#t))
+ (result :: <result>, name :: <string>, stream :: <stream>,
+ #key test = always(#t))
=> ()
let (passes, failures, not-executed, not-implemented, crashes)
= count-results(result, test: test);
@@ -72,56 +73,57 @@ define method print-result-summary
else
as(<float>, passes) / total
end;
- test-output(" Ran %d %s%s: %d passed (%s%%), %d failed, %d skipped, "
- "%d not implemented, %d crashed\n",
- total,
- name,
- if (total == 1) "" else "s" end,
- passes,
- percent,
- failures, not-executed, not-implemented, crashes);
+ format(stream,
+ " Ran %d %s%s: %d passed (%s%%), %d failed, %d skipped, "
+ "%d not implemented, %d crashed\n",
+ total,
+ name,
+ if (total == 1) "" else "s" end,
+ passes,
+ percent,
+ failures, not-executed, not-implemented, crashes);
end method print-result-summary;
define method print-result-info
- (result :: <result>, #key indent = "", test)
+ (result :: <result>, stream :: <stream>, #key indent = "", test)
=> ()
let result-status = result.result-status;
let show-result? = if (test) test(result) else #t end;
if (show-result?)
- test-output("\n%s%s %s",
- indent, result.result-name, status-name(result-status));
+ format(stream, "\n%s%s %s",
+ indent, result.result-name, status-name(result-status));
if (result-status == $passed
& instance?(result, <component-result>))
- test-output(" in %s seconds with %s bytes allocated.",
- result-time(result), result-bytes(result) | "?");
+ format(stream, " in %s seconds with %s bytes allocated.",
+ result-time(result), result-bytes(result) | "?");
end if
end;
end method print-result-info;
define method print-result-info
- (result :: <component-result>, #key indent = "", test)
+ (result :: <component-result>, stream :: <stream>, #key indent = "", test)
=> ()
next-method();
let show-result? = if (test) test(result) else #t end;
let reason = result.result-reason;
if (show-result? & reason)
- test-output(" [%s]", reason);
+ format(stream, " [%s]", reason);
end;
let subindent = concatenate(indent, " ");
for (subresult in result-subresults(result))
- print-result-info(subresult, indent: subindent, test: test)
+ print-result-info(subresult, stream, indent: subindent, test: test)
end
end method print-result-info;
// This 'after' method prints the reason for the result's failure
define method print-result-info
- (result :: <unit-result>, #key indent = "", test) => ()
+ (result :: <unit-result>, stream :: <stream>, #key indent = "", test) => ()
ignore(indent);
next-method();
let show-result? = if (test) test(result) else #t end;
let reason = result.result-reason;
if (show-result? & reason)
- test-output(" [%s]", reason);
+ format(stream, " [%s]", reason);
end;
end method print-result-info;
@@ -129,15 +131,15 @@ end method print-result-info;
/// Report functions
-define method null-report-function (result :: <result>) => ()
- #f
-end method null-report-function;
+define method null-report-function
+ (result :: <result>, stream :: <stream>) => ()
+end;
define method summary-report-function
- (result :: <result>) => ()
- test-output("\n\n%s summary:\n", result-name(result));
+ (result :: <result>, stream :: <stream>) => ()
+ format(stream, "\n\n%s summary:\n", result-name(result));
local method print-class-summary (result, name, class) => ()
- print-result-summary(result, name,
+ print-result-summary(result, name, stream,
test: method (subresult)
instance?(subresult, class)
end)
@@ -147,27 +149,29 @@ define method summary-report-function
print-class-summary(result, "check", <check-result>);
end method summary-report-function;
-define method failures-report-function (result :: <result>) => ()
- test-output("\n");
+define method failures-report-function
+ (result :: <result>, stream :: <stream>) => ()
+ format(stream, "\n");
select (result.result-status)
$passed =>
- test-output("%s passed\n", result.result-name);
+ format(stream, "%s passed\n", result.result-name);
otherwise =>
print-result-info
- (result,
+ (result, stream,
test: method (result)
let status = result.result-status;
status ~== $passed & status ~== $skipped
end);
- test-output("\n");
+ format(stream, "\n");
end;
- summary-report-function(result);
+ summary-report-function(result, stream);
end method failures-report-function;
-define method full-report-function (result :: <result>) => ()
- test-output("\n");
- print-result-info(result, test: always(#t));
- summary-report-function(result);
+define method full-report-function
+ (result :: <result>, stream :: <stream>) => ()
+ format(stream, "\n");
+ print-result-info(result, stream, test: always(#t));
+ summary-report-function(result, stream);
end method full-report-function;
define variable *default-report-function* = failures-report-function;
@@ -191,16 +195,17 @@ define method remove-newlines
string
end method remove-newlines;
-define method log-report-function (result :: <result>) => ()
+define method log-report-function
+ (result :: <result>, stream :: <stream>) => ()
local method generate-report (result :: <result>) => ()
let test-type = result-type-name(result);
- test-output("\nObject: %s\n", test-type);
- test-output("Name: %s\n", remove-newlines(result-name(result)));
- test-output("Status: %s\n", status-name(result-status(result)));
+ format(stream, "\nObject: %s\n", test-type);
+ format(stream, "Name: %s\n", remove-newlines(result-name(result)));
+ format(stream, "Status: %s\n", status-name(result-status(result)));
let status = result.result-status;
if (instance?(result, <component-result>))
if (result.result-reason)
- test-output("Reason: %s\n", result.result-reason);
+ format(stream, "Reason: %s\n", result.result-reason);
end;
for (subresult in result-subresults(result))
generate-report(subresult)
@@ -208,19 +213,19 @@ define method log-report-function (result :: <result>) => ()
else
let reason = result.result-reason;
if (reason)
- test-output("Reason: %s\n", remove-newlines(reason));
+ format(stream, "Reason: %s\n", remove-newlines(reason));
end;
if (~reason & instance?(result, <component-result>))
- test-output("Seconds: %s\nAllocation: %d bytes\n",
- result-time(result), result-bytes(result) | 0);
+ format(stream, "Seconds: %s\nAllocation: %d bytes\n",
+ result-time(result), result-bytes(result) | 0);
end if;
end;
- test-output("end\n");
+ format(stream, "end\n");
end method generate-report;
- test-output("\n%s", $test-log-header);
+ format(stream, "\n%s", $test-log-header);
generate-report(result);
- test-output("\n%s\n", $test-log-footer);
- failures-report-function(result)
+ format(stream, "\n%s\n", $test-log-footer);
+ failures-report-function(result, stream)
end method log-report-function;
@@ -229,144 +234,161 @@ end method log-report-function;
define constant $xml-version-header
= "<?xml version=\"1.0\" encoding=\"ISO-8859-1\"?>";
-define function xml-output-pcdata (text :: <string>) => ()
+define function xml-output-pcdata
+ (text :: <string>, stream :: <stream>) => ()
let text-size = text.size;
iterate loop (start = 0, i = 0)
if (i < text-size)
select (text[i])
'&' =>
- test-output("%s&amp;", copy-sequence(text, start: start, end: i));
+ format(stream, "%s&amp;", copy-sequence(text, start: start, end: i));
loop(i + 1, i + 1);
'<' =>
- test-output("%s&lt;", copy-sequence(text, start: start, end: i));
+ format(stream, "%s&lt;", copy-sequence(text, start: start, end: i));
loop(i + 1, i + 1);
'>' =>
- test-output("%s&gt;", copy-sequence(text, start: start, end: i));
+ format(stream, "%s&gt;", copy-sequence(text, start: start, end: i));
loop(i + 1, i + 1);
otherwise =>
loop(start, i + 1);
end select;
else
- test-output("%s",
- if (start = 0)
- text
- else
- copy-sequence(text, start: start)
- end);
+ format(stream, "%s", if (start = 0)
+ text
+ else
+ copy-sequence(text, start: start)
+ end);
end if;
end iterate;
end function;
-define function do-xml-element (element-name :: <string>, body :: <function>) => ()
- test-output("<%s>", element-name);
+define function do-xml-element
+ (element-name :: <string>, body :: <function>, stream :: <stream>) => ()
+ format(stream, "<%s>", element-name);
body();
- test-output("</%s>\n", element-name);
+ format(stream, "</%s>\n", element-name);
end function;
-define method do-xml-result-body (result :: <result>) => ();
- test-output("\n");
- do-xml-element("name", curry(xml-output-pcdata, result.result-name));
+define method do-xml-result-body
+ (result :: <result>, stream :: <stream>) => ()
+ format(stream, "\n");
+ do-xml-element("name", curry(xml-output-pcdata, result.result-name, stream), stream);
let status = result.result-status;
- do-xml-element("status", curry(xml-output-pcdata, status.status-name));
-end method;
+ do-xml-element("status", curry(xml-output-pcdata, status.status-name, stream), stream);
+end method do-xml-result-body;
-define method do-xml-result-body (result :: <check-result>) => ();
+define method do-xml-result-body
+ (result :: <check-result>, stream :: <stream>) => ()
next-method();
let reason = result.result-reason;
if (reason)
- do-xml-element("reason", curry(xml-output-pcdata, reason));
+ do-xml-element("reason", curry(xml-output-pcdata, reason, stream), stream);
end if;
-end method;
+end method do-xml-result-body;
-define method do-xml-result-body (result :: <component-result>) => ();
+define method do-xml-result-body
+ (result :: <component-result>, stream :: <stream>) => ()
next-method();
do-xml-element("seconds",
method ()
- test-output("%d", result.result-seconds)
- end);
+ format(stream, "%d", result.result-seconds)
+ end,
+ stream);
do-xml-element("microseconds",
method ()
- test-output("%d", result.result-microseconds)
- end);
+ format(stream, "%d", result.result-microseconds)
+ end,
+ stream);
do-xml-element("allocation",
method ()
- test-output("%d", result.result-bytes)
- end);
+ format(stream, "%d", result.result-bytes)
+ end,
+ stream);
if (result.result-reason)
do-xml-element("reason",
method ()
- xml-output-pcdata(result.result-reason);
- end);
+ xml-output-pcdata(result.result-reason, stream);
+ end,
+ stream);
end if;
- do(do-xml-result, result-subresults(result));
+ do(rcurry(do-xml-result, stream), result-subresults(result));
end method;
-define method do-xml-result (result :: <result>) => ();
- do-xml-element(result-type-name(result), curry(do-xml-result-body, result));
-end method;
+define method do-xml-result
+ (result :: <result>, stream :: <stream>) => ()
+ do-xml-element(result-type-name(result),
+ curry(do-xml-result-body, result, stream),
+ stream);
+end method do-xml-result;
-define method xml-report-function (result :: <result>) => ()
- test-output("%s\n", $xml-version-header);
+define method xml-report-function
+ (result :: <result>, stream :: <stream>) => ()
+ format(stream, "%s\n", $xml-version-header);
do-xml-element("test-report",
method ()
- test-output("\n");
- do-xml-result(result);
- end);
-end method;
+ format(stream, "\n");
+ do-xml-result(result, stream);
+ end,
+ stream);
+end method xml-report-function;
/// Surefire report
define function emit-surefire-suite
- (suite :: <suite-result>) => ()
+ (suite :: <suite-result>, stream :: <stream>) => ()
let is-test-result? = rcurry(instance?, <test-result>);
let test-results = choose(is-test-result?, result-subresults(suite));
if (~empty?(test-results))
let (passes, failures, not-executed, not-implemented, crashes)
= count-results(suite, test: is-test-result?);
- test-output(" <testsuite name=\"%s\" failures=\"%d\" errors=\"%d\" tests=\"%d\">\n",
- suite.result-name, failures + not-implemented, crashes,
- test-results.size);
- do(curry(emit-surefire-test, suite), test-results);
- test-output(" </testsuite>\n");
+ format(stream,
+ " <testsuite name=\"%s\" failures=\"%d\" errors=\"%d\" tests=\"%d\">\n",
+ suite.result-name, failures + not-implemented, crashes,
+ test-results.size);
+ do(method (test)
+ emit-surefire-test(suite, test, stream);
+ end,
+ test-results);
+ format(stream, " </testsuite>\n");
end if;
end function emit-surefire-suite;
define function emit-surefire-test
- (suite :: <suite-result>, test :: <test-result>) => ()
- test-output(" <testcase name=\"%s\" classname=\"%s\">",
- test.result-name, suite.result-name);
+ (suite :: <suite-result>, test :: <test-result>, stream :: <stream>) => ()
+ format(stream, " <testcase name=\"%s\" classname=\"%s\">",
+ test.result-name, suite.result-name);
let status = test.result-status;
select (status)
$passed => #f;
$skipped =>
- test-output("\n <skipped />\n");
+ format(stream, "\n <skipped />\n");
$not-implemented =>
- test-output("\n <failure message=\"Not implemented\" />\n");
+ format(stream, "\n <failure message=\"Not implemented\" />\n");
otherwise =>
// If this test failed then we know at least one of the checks
// failed. Note that (due to testworks-specs) a <test-result>
// may contain <test-unit-result>s and we flatten those into
// this result because they don't (apparently?) match Surefire's
// format.
- test-output("\n <failure>\n");
- do-results(emit-surefire-check, test,
+ format(stream, "\n <failure>\n");
+ do-results(rcurry(emit-surefire-check, stream), test,
test: rcurry(instance?, <check-result>));
- test-output("\n </failure>\n");
+ format(stream, "\n </failure>\n");
end select;
- test-output(" </testcase>\n");
+ format(stream, " </testcase>\n");
end function emit-surefire-test;
define function emit-surefire-check
- (result :: <check-result>) => ()
+ (result :: <check-result>, stream :: <stream>) => ()
let status = result.result-status;
let reason = result.result-reason;
if (reason & status ~= $passed & status ~= $skipped)
- xml-output-pcdata(reason);
- test-output("\n");
+ xml-output-pcdata(reason, stream);
+ format(stream, "\n");
end;
end function emit-surefire-check;
@@ -383,9 +405,10 @@ define function collect-suite-results
end function collect-suite-results;
define function surefire-report-function
- (result :: <result>) => ()
- test-output("%s\n", $xml-version-header);
- test-output("<testsuites>\n");
- do(emit-surefire-suite, collect-suite-results(result));
- test-output("</testsuites>\n");
+ (result :: <result>, stream :: <stream>) => ()
+ format(stream, "%s\n", $xml-version-header);
+ format(stream, "<testsuites>\n");
+ do(rcurry(emit-surefire-suite, stream),
+ collect-suite-results(result));
+ format(stream, "</testsuites>\n");
end function surefire-report-function;
View
151 run.dylan
@@ -13,51 +13,47 @@ define method announce-component
component.component-type-name, component.component-name);
end;
-*announce-function* := announce-component;
-
-define method debug-failures?
+define inline function debug-failures?
() => (debug-failures? :: <boolean>)
- *debug?* == #t
+ debug-runner?(*runner*) == #t
end;
-define method debug?
+define inline function debug?
() => (debug? :: <boolean>)
- *debug?* ~= #f
+ debug-runner?(*runner*) ~= #f
end;
define method test-output
(format-string :: <string>, #rest format-args) => ()
- apply(format, *test-output*, format-string, format-args);
+ apply(format, runner-output-stream(*runner*), format-string, format-args);
end;
-/// Perform options
-
-// this class defines all the options that might be used
-// to control test suite performing.
-
-// TODO(cgay): Rename to <test-run> and dispatch on it so that we
-// don't need all these thread variables and there are better
-// opportunities to modify testworks' behavior. Or just rename to
-// <options> for brevity.
-define open class <perform-options> (<object>)
- slot perform-tags :: <sequence> = $all-tags,
+// A <test-runner> holds options for the test run and collects results.
+// TODO(cgay): Remove the *-function slots and provide methods for
+// subclassers to override instead.
+define open class <test-runner> (<object>)
+ // TODO(cgay): <report> = one-of(#"failures", #"crashes", #"none", ...)
+ //constant slot runner-report :: <string> = "failures",
+ // init-keyword: report:;
+ constant slot runner-tags :: <sequence> = $all-tags,
init-keyword: tags:;
- slot perform-announce-function :: false-or(<function>) = *announce-function*,
+ slot runner-announce-function :: false-or(<function>) = announce-component,
init-keyword: announce-function:;
- slot perform-announce-checks? :: <boolean> = *announce-checks?*,
- init-keyword: announce-checks?:;
- slot perform-progress-function = *default-progress-function*,
+ slot runner-progress-function = null-progress-function,
init-keyword: progress-function:;
- slot perform-debug? = *debug?*,
+ constant slot debug-runner? = #f,
init-keyword: debug?:;
- constant slot perform-ignore :: <sequence> = #[], // of components
+ constant slot runner-ignore :: <sequence> = #[], // of components
init-keyword: ignore:;
- constant slot list-suites? :: <boolean> = #f,
- init-keyword: list-suites?:;
- constant slot list-tests? :: <boolean> = #f,
- init-keyword: list-tests?:;
-end class <perform-options>;
+
+ // The stream on which output is done. Note that this may be bound
+ // to different streams during the test run and when the report is
+ // generated. e.g., to output the report to a file.
+ constant slot runner-output-stream :: <stream> = *standard-output*,
+ init-keyword: output-stream:;
+
+end class <test-runner>;
///*** Generic Classes, Helper Functions, and Helper Macros ***///
@@ -66,7 +62,7 @@ end class <perform-options>;
define macro maybe-trap-errors
{ maybe-trap-errors (?body:body) }
=> { local method maybe-trap-errors-body () ?body end;
- if (*debug?*)
+ if (debug?())
maybe-trap-errors-body();
else
block ()
@@ -77,85 +73,43 @@ define macro maybe-trap-errors
end; }
end macro maybe-trap-errors;
-define method perform-component
- (component :: <component>, options :: <perform-options>,
+// TODO(cgay): Move report-function into <test-runner>.
+define function run-tests
+ (runner :: <test-runner>, component :: <component>,
#key report-function = *default-report-function*)
=> (component-result :: <component-result>)
- let announce-checks? = options.perform-announce-checks?;
- let result
- = dynamic-bind (*announce-checks?* = announce-checks?)
- maybe-execute-component(component, options)
- end;
+ let result = dynamic-bind (*runner* = runner)
+ maybe-execute-component(component, runner)
+ end;
report-function & report-function(result);
result
-end method perform-component;
-
-define method perform-suite
- (suite :: <suite>,
- #key tags = $all-tags,
- announce-function = #f,
- announce-checks? = *announce-checks?*,
- report-function = *default-report-function*,
- progress-function = *default-progress-function*,
- debug? = *debug?*)
- => (result :: <component-result>)
- perform-component
- (suite,
- make(<perform-options>,
- tags: tags,
- announce-function: announce-function,
- announce-checks?: announce-checks?,
- progress-function: progress-function | null-progress-function,
- debug?: debug?),
- report-function: report-function | null-report-function)
-end method perform-suite;
-
-// perform-test takes a <test> object and returns a component-result object.
-
-define method perform-test
- (test :: <test>,
- #key tags = $all-tags,
- announce-function = *announce-function*,
- announce-checks? = *announce-checks?*,
- progress-function = *default-progress-function*,
- report-function = *default-report-function*,
- debug? = *debug?*)
- => (result :: <component-result>)
- let options = make(<perform-options>,
- tags: tags,
- announce-function: announce-function,
- announce-checks?: announce-checks?,
- progress-function: progress-function | null-progress-function,
- debug?: debug?);
- perform-component (test, options,
- report-function: report-function | null-report-function);
-end method perform-test;
+end function run-tests;
/// Execute component
define open generic execute-component?
- (component :: <component>, options :: <perform-options>)
+ (component :: <component>, runner :: <test-runner>)
=> (execute? :: <boolean>);
define method execute-component?
- (component :: <component>, options :: <perform-options>)
+ (component :: <component>, runner :: <test-runner>)
=> (execute? :: <boolean>)
- tags-match?(options.perform-tags, component.component-tags)
- & ~member?(component, options.perform-ignore)
+ tags-match?(runner.runner-tags, component.component-tags)
+ & ~member?(component, runner.runner-ignore)
end method execute-component?;
define method maybe-execute-component
- (component :: <component>, options :: <perform-options>)
+ (component :: <component>, runner :: <test-runner>)
=> (result :: <component-result>)
let announce-function
- = options.perform-announce-function;
+ = runner.runner-announce-function;
if (announce-function)
announce-function(component)
end;
let (subresults, status, reason, seconds, microseconds, bytes)
- = if (execute-component?(component, options))
- execute-component(component, options)
+ = if (execute-component?(component, runner))
+ execute-component(component, runner)
else
values(#(), $skipped, 0, 0, 0)
end;
@@ -170,7 +124,7 @@ define method maybe-execute-component
end method maybe-execute-component;
define method execute-component
- (suite :: <suite>, options :: <perform-options>)
+ (suite :: <suite>, runner :: <test-runner>)
=> (subresults :: <sequence>, status :: <result-status>, reason :: false-or(<string>),
seconds :: <integer>, microseconds :: <integer>, bytes :: <integer>)
let subresults :: <stretchy-vector> = make(<stretchy-vector>);
@@ -181,7 +135,7 @@ define method execute-component
= block ()
suite.suite-setup-function();
for (component in suite.suite-components)
- let subresult = maybe-execute-component(component, options);
+ let subresult = maybe-execute-component(component, runner);
add!(subresults, subresult);
if (instance?(subresult, <component-result>)
& subresult.result-seconds
@@ -216,20 +170,19 @@ define method execute-component
end method execute-component;
define method execute-component
- (test :: <test>, options :: <perform-options>)
+ (test :: <test>, runner :: <test-runner>)
=> (subresults :: <sequence>, status :: <result-status>, reason :: false-or(<string>),
seconds :: <integer>, microseconds :: <integer>, bytes :: <integer>)
let subresults = make(<stretchy-vector>);
let (seconds, microseconds, bytes) = values(0, 0, 0);
let (status, reason)
- = dynamic-bind (*debug?* = options.perform-debug?,
- *check-recording-function* =
+ = dynamic-bind (*check-recording-function* =
method (result :: <result>)
add!(subresults, result);
- options.perform-progress-function(result);
+ runner.runner-progress-function(result);
result
end,
- *test-unit-options* = options)
+ *test-unit-runner* = runner)
let cond = #f;
profiling (cpu-time-seconds, cpu-time-microseconds, allocation)
cond := maybe-trap-errors(test.test-function());
@@ -256,9 +209,9 @@ define method execute-component
end method execute-component;
define method list-component
- (test :: <test>, options :: <perform-options>)
+ (test :: <test>, runner :: <test-runner>)
=> (list :: <sequence>)
- if (execute-component?(test, options))
+ if (execute-component?(test, runner))
vector(test);
else
#[];
@@ -266,13 +219,13 @@ define method list-component
end method list-component;
define method list-component
- (suite :: <suite>, options :: <perform-options>)
+ (suite :: <suite>, runner :: <test-runner>)
=> (list :: <sequence>)
let sublist :: <stretchy-vector> = make(<stretchy-vector>);
- if (execute-component?(suite, options))
+ if (execute-component?(suite, runner))
add!(sublist, suite);
for (component in suite.suite-components)
- sublist := concatenate!(sublist, list-component(component, options));
+ sublist := concatenate!(sublist, list-component(component, runner));
end for;
end if;
sublist
View
22 tests/test-command-line.dylan
@@ -2,13 +2,12 @@ Module: testworks-test-suite
Synopsis: Tests for command-line.dylan
-define test test-perform-options
- (description: "Verify that command-line options set "
- "'perform options' correctly.")
- let args = list(list("--debug", perform-debug?, #t),
- list("--debug=no", perform-debug?, #f),
- list("--debug=crashes", perform-debug?, #"crashes"),
- list("--debug=failures", perform-debug?, #t));
+// Verify that command-line options create a <test-runner> correctly.
+define test test-make-runner-from-command-line ()
+ let args = list(list("--debug", debug-runner?, #t),
+ list("--debug=no", debug-runner?, #f),
+ list("--debug=crashes", debug-runner?, #"crashes"),
+ list("--debug=failures", debug-runner?, #t));
let dummy-component = make(<suite>,
name: "Dummy",
description: "not used",
@@ -16,13 +15,12 @@ define test test-perform-options
for (item in args)
let (arg, getter, expected) = apply(values, item);
let parser = parse-args(list(arg));
- let (_, options, _)
- = compute-application-options(dummy-component, parser);
- let actual = getter(options);
+ let (_, runner, _) = make-runner-from-command-line(dummy-component, parser);
+ let actual = getter(runner);
check-equal(arg, expected, actual);
end;
-end test test-perform-options;
+end test test-make-runner-from-command-line;
define suite command-line-test-suite ()
- test test-perform-options;
+ test test-make-runner-from-command-line;
end;
View
3  tests/testworks-test-suite-library.dylan
@@ -22,6 +22,5 @@ define module testworks-test-suite
use testworks;
use %testworks;
- export testworks-test-suite,
- \with-debugging;
+ export testworks-test-suite;
end module testworks-test-suite;
View
25 tests/testworks-test-suite.dylan
@@ -8,17 +8,6 @@ Warranty: Distributed WITHOUT WARRANTY OF ANY KIND
/// Some utilities for testing TestWorks
-define macro with-debugging
- { with-debugging () ?body:body end }
- => { let old-debug? = *debug?*;
- block ()
- *debug?* := #t;
- ?body
- cleanup
- *debug?* := old-debug?;
- end }
-end macro with-debugging;
-
define macro without-recording
{ without-recording () ?body:body end }
=> { let old-check-recording-function = *check-recording-function*;
@@ -282,10 +271,10 @@ end suite testworks-check-macros-suite;
define test testworks-perform-test-results-test ()
let test-to-check = find-test-object(testworks-check-test);
- let test-results = perform-test(test-to-check,
- progress-function: #f,
- report-function: #f,
- announce-function: #f);
+ let runner = make(<test-runner>,
+ progress-function: always(#f),
+ announce-function: always(#f));
+ let test-results = run-tests(runner, test-to-check, report-function: #f);
check-true("perform-test returns <test-result>",
instance?(test-results, <test-result>));
check-equal("perform-test returns $passed when passing",
@@ -296,8 +285,10 @@ end test testworks-perform-test-results-test;
define test testworks-perform-suite-results-test ()
let suite-to-check = testworks-check-macros-suite;
- let suite-results
- = perform-suite(suite-to-check, progress-function: #f, report-function: #f);
+ let runner = make(<test-runner>,
+ progress-function: always(#f),
+ announce-function: always(#f));
+ let suite-results = run-tests(runner, suite-to-check, report-function: #f);
check-true("perform-suite returns <suite-result>",
instance?(suite-results, <suite-result>));
check-equal("perform-suite returns $passed when passing",
View
14 utils.dylan
@@ -6,18 +6,8 @@ License: See License.txt in this distribution for details.
Warranty: Distributed WITHOUT WARRANTY OF ANY KIND
-define thread variable *debug?* = #f;
-
-// The stream on which output is done. Note that this may be bound to
-// different streams during the test run and when the report is
-// generated. e.g., to output the report to a file.
-define thread variable *test-output* :: <stream> = *standard-output*;
-
-define thread variable *announce-checks?* :: <boolean> = #f;
-
-define thread variable *announce-check-function* :: false-or(<function>) = #f;
-
-define thread variable *announce-function* :: false-or(<function>) = method (c) end;
+// The active test run object.
+define thread variable *runner* :: false-or(<test-runner>) = #f;
define function add-times
Please sign in to comment.
Something went wrong with that request. Please try again.