This patch adds a new runner (state) class. At the moment, the only
state you can store is a list of filtering tokens, and whether to
quell the backtrace. The latter could well change once we implement a
better debugging system, or if we ditch the backtrace altogether.
The only significant changes required were:
- The runner now gets passed into $suite->run(), and propogated
downwards and into the result object.
- The three runners (TestRunner, Tk, HarnessUnit) are now derived
from T::U::Runner, which ISA T::U::TestListener, rather than each
runner being a TestListener. I think this is a bit nicer than
multiple inheritance.
What do people think?
Index: MANIFEST
===================================================================
RCS file: /cvsroot/perlunit/src/Test-Unit-0.1/MANIFEST,v
retrieving revision 1.4
diff -u -r1.4 MANIFEST
--- MANIFEST 2000/05/07 12:48:17 1.4
+++ MANIFEST 2001/03/05 16:20:24
@@ -16,6 +16,7 @@
lib/Test/Unit/tests/OverrideTestCase.pm
lib/Test/Unit/tests/TestInnerClass.pm
lib/Test/Unit/Exception.pm
+lib/Test/Unit/Runner.pm
lib/Test/Unit/TestRunner.pm
lib/Test/Unit/TestSuite.pm
lib/Test/Unit/TestResult.pm
Index: lib/Test/Unit/Runner.pm
===================================================================
RCS file: Runner.pm
diff -N Runner.pm
--- /dev/null Mon Dec 11 17:26:27 2000
+++ lib/Test/Unit/Runner.pm Mon Mar 5 08:39:59 2001
@@ -0,0 +1,60 @@
+package Test::Unit::Runner;
+use strict;
+
+use base qw(Test::Unit::TestListener);
+
+sub filter {
+ my $self = shift;
+ my (@filter) = @_;
+
+ $self->{_filter} = [ @filter ] if @filter;
+
+ return @{ $self->{_filter} || [] };
+}
+
+sub quell_backtrace {
+ my $self = shift;
+ my ($new_setting) = @_;
+
+ $self->{_quell_backtrace} = $new_setting
+ if defined $new_setting;
+
+ return $self->{_quell_backtrace};
+}
+
+
+1;
+__END__
+
+
+=head1 NAME
+
+ Test::Unit::Runner - abstract base class for test runners
+
+=head1 SYNOPSIS
+
+ # this class is not intended to be used directly
+
+=head1 DESCRIPTION
+
+ This class is a parent class of all test runners, and represents
+ state (e.g. run-time options) available to all runner classes.
+
+=head1 AUTHOR
+
+ Copyright (c) 2000 Brian Ewins, Christian Lemburg, <[EMAIL PROTECTED]>.
+
+ All rights reserved. This program is free software; you can
+ redistribute it and/or modify it under the same terms as
+ Perl itself.
+
+ Thanks go to the other PerlUnit framework people:
+ Cayte Lindner, J.E. Fritz, Zhon Johansen.
+
+=head1 SEE ALSO
+
+ - Test::Unit::HarnessUnit
+ - Test::Unit::TestRunner
+ - Test::Unit::TkTestRunner
+
+=cut
Index: lib/Test/Unit/TkTestRunner.pm
===================================================================
RCS file: /cvsroot/perlunit/src/Test-Unit-0.1/lib/Test/Unit/TkTestRunner.pm,v
retrieving revision 1.11
diff -u -r1.11 TkTestRunner.pm
--- lib/Test/Unit/TkTestRunner.pm 2001/02/20 21:31:05 1.11
+++ lib/Test/Unit/TkTestRunner.pm 2001/03/05 16:20:25
@@ -1,6 +1,6 @@
#!/usr/bin/perl
package Test::Unit::TkTestRunner;
-use base qw(Test::Unit::TestListener);
+use base qw(Test::Unit::Runner);
use constant COPYRIGHT_NOTICE => <<'END_COPYRIGHT_NOTICE';
This the PerlUnit Tk Test Runner.
Copyright (C) 2000 Christian Lemburg, Brian Ewins,
Index: lib/Test/Unit/UnitHarness.pm
===================================================================
RCS file: /cvsroot/perlunit/src/Test-Unit-0.1/lib/Test/Unit/UnitHarness.pm,v
retrieving revision 1.7
diff -u -r1.7 UnitHarness.pm
--- lib/Test/Unit/UnitHarness.pm 2001/02/20 21:31:05 1.7
+++ lib/Test/Unit/UnitHarness.pm 2001/03/05 16:20:25
@@ -3,7 +3,7 @@
package Test::Unit::UnitHarness;
BEGIN {require 5.002;}
-use base qw(Test::Unit::TestListener Test::Unit::Test);
+use base qw(Test::Unit::Runner Test::Unit::Test);
use Exporter;
use Config;
use Carp;
Index: lib/Test/Unit/TestRunner.pm
===================================================================
RCS file: /cvsroot/perlunit/src/Test-Unit-0.1/lib/Test/Unit/TestRunner.pm,v
retrieving revision 1.8
diff -u -r1.8 TestRunner.pm
--- lib/Test/Unit/TestRunner.pm 2001/02/20 21:31:05 1.8
+++ lib/Test/Unit/TestRunner.pm 2001/03/05 16:20:24
@@ -2,7 +2,7 @@
use strict;
use constant DEBUG => 0;
-use base qw(Test::Unit::TestListener);
+use base qw(Test::Unit::Runner);
use Test::Unit::TestSuite;
use Test::Unit::TestResult;
@@ -55,7 +55,7 @@
my $result = $self->create_test_result();
$result->add_listener($self);
my $start_time = new Benchmark();
- $suite->run($result);
+ $suite->run($result, $self);
my $end_time = new Benchmark();
my $run_time = timediff($end_time, $start_time);
$self->_print("\n", "Time: ", timestr($run_time), "\n");
Index: lib/Test/Unit/Test.pm
===================================================================
RCS file: /cvsroot/perlunit/src/Test-Unit-0.1/lib/Test/Unit/Test.pm,v
retrieving revision 1.6
diff -u -r1.6 Test.pm
--- lib/Test/Unit/Test.pm 2001/02/20 21:31:05 1.6
+++ lib/Test/Unit/Test.pm 2001/03/05 16:20:24
@@ -29,6 +29,22 @@
return $self->name();
}
+sub filter_method {
+ my $self = shift;
+ my ($token, $method) = @_;
+
+ if (! exists $self->{_filter}{$token}) {
+ my @methods = @{ $self->filter->{$token} || [] };
+ $self->{_filter}{$token} = { map { $_ => 1 } @methods };
+ }
+
+ $method =~ s/^test_//;
+
+ return $self->{_filter}{$token}{$method};
+}
+
+sub filter { {} }
+
1;
__END__
Index: lib/Test/Unit/TestSuite.pm
===================================================================
RCS file: /cvsroot/perlunit/src/Test-Unit-0.1/lib/Test/Unit/TestSuite.pm,v
retrieving revision 1.11
diff -u -r1.11 TestSuite.pm
--- lib/Test/Unit/TestSuite.pm 2001/02/27 10:51:36 1.11
+++ lib/Test/Unit/TestSuite.pm 2001/03/05 16:20:25
@@ -112,14 +142,31 @@
sub run {
my $self = shift;
- my ($result) = @_;
+ my ($result, $runner) = @_;
for my $e (@{$self->tests()}) {
- last if $result->should_stop();
- $e->run($result);
+ if ($runner && $self->filter_test($runner, $e)) {
+ printf "skipping %s\n", $e->name() if DEBUG;
+ next;
+ }
+
+ last if $result->should_stop();
+ $e->run($result, $runner);
}
- return $result;
+ return $result;
}
+sub filter_test {
+ my $self = shift;
+ my ($runner, $test) = @_;
+ my @filter_tokens = $runner->filter();
+
+ foreach my $token (@filter_tokens) {
+ return 1 if $test->filter_method($token, $test->name());
+ }
+
+ return 0;
+}
+
sub test_at {
my $self = shift;
my ($index) = @_;
Index: lib/Test/Unit/HarnessUnit.pm
===================================================================
RCS file: /cvsroot/perlunit/src/Test-Unit-0.1/lib/Test/Unit/HarnessUnit.pm,v
retrieving revision 1.8
diff -u -r1.8 HarnessUnit.pm
--- lib/Test/Unit/HarnessUnit.pm 2001/02/22 18:45:59 1.8
+++ lib/Test/Unit/HarnessUnit.pm 2001/03/05 16:20:24
@@ -4,7 +4,7 @@
use strict;
use constant DEBUG => 0;
-use base qw(Test::Unit::TestListener);
+use base qw(Test::Unit::Runner);
use Test::Unit::TestSuite;
use Test::Unit::TestResult;
@@ -82,7 +82,7 @@
my $result = $self->create_test_result();
my $count=$suite->count_test_cases();
$result->add_listener($self);
- $suite->run($result);
+ $suite->run($result, $self);
}
sub this_package {
Index: lib/Test/Unit/TestCase.pm
===================================================================
RCS file: /cvsroot/perlunit/src/Test-Unit-0.1/lib/Test/Unit/TestCase.pm,v
retrieving revision 1.18
diff -u -r1.18 TestCase.pm
--- lib/Test/Unit/TestCase.pm 2001/02/28 19:38:35 1.18
+++ lib/Test/Unit/TestCase.pm 2001/03/05 16:20:24
@@ -33,9 +33,14 @@
sub run {
my $self = shift;
print ref($self) . "::run() called\n" if DEBUG;
- my ($result) = @_;
+ my ($result, $runner) = @_;
+
+ if ($runner) {
+ $self->quell_backtrace() if $runner->quell_backtrace();
+ }
+
$result = create_result() unless defined($result);
- $result->run($self);
+ $result->run($self, $runner);
return $result;
}
_______________________________________________
Perlunit-devel mailing list
[EMAIL PROTECTED]
http://lists.sourceforge.net/lists/listinfo/perlunit-devel
