summaryrefslogtreecommitdiff
path: root/Master/tlpkg/tlperl/lib/Test/Tester
diff options
context:
space:
mode:
Diffstat (limited to 'Master/tlpkg/tlperl/lib/Test/Tester')
-rw-r--r--Master/tlpkg/tlperl/lib/Test/Tester/Capture.pm231
-rw-r--r--Master/tlpkg/tlperl/lib/Test/Tester/CaptureRunner.pm76
-rw-r--r--Master/tlpkg/tlperl/lib/Test/Tester/Delegate.pm32
3 files changed, 339 insertions, 0 deletions
diff --git a/Master/tlpkg/tlperl/lib/Test/Tester/Capture.pm b/Master/tlpkg/tlperl/lib/Test/Tester/Capture.pm
new file mode 100644
index 00000000000..00e12e6458e
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/Test/Tester/Capture.pm
@@ -0,0 +1,231 @@
+use strict;
+
+package Test::Tester::Capture;
+
+use Test::Builder;
+
+use vars qw( @ISA );
+@ISA = qw( Test::Builder );
+
+# Make Test::Tester::Capture thread-safe for ithreads.
+BEGIN {
+ use Config;
+ if( $] >= 5.008 && $Config{useithreads} ) {
+ require threads::shared;
+ threads::shared->import;
+ }
+ else {
+ *share = sub { 0 };
+ *lock = sub { 0 };
+ }
+}
+
+my $Curr_Test = 0; share($Curr_Test);
+my @Test_Results = (); share(@Test_Results);
+my $Prem_Diag = {diag => ""}; share($Curr_Test);
+
+sub new
+{
+ # Test::Tester::Capgture::new used to just return __PACKAGE__
+ # because Test::Builder::new enforced it's singleton nature by
+ # return __PACKAGE__. That has since changed, Test::Builder::new now
+ # returns a blessed has and around version 0.78, Test::Builder::todo
+ # started wanting to modify $self. To cope with this, we now return
+ # a blessed hash. This is a short-term hack, the correct thing to do
+ # is to detect which style of Test::Builder we're dealing with and
+ # act appropriately.
+
+ my $class = shift;
+ return bless {}, $class;
+}
+
+sub ok {
+ my($self, $test, $name) = @_;
+
+ # $test might contain an object which we don't want to accidentally
+ # store, so we turn it into a boolean.
+ $test = $test ? 1 : 0;
+
+ lock $Curr_Test;
+ $Curr_Test++;
+
+ my($pack, $file, $line) = $self->caller;
+
+ my $todo = $self->todo($pack);
+
+ my $result = {};
+ share($result);
+
+ unless( $test ) {
+ @$result{ 'ok', 'actual_ok' } = ( ( $todo ? 1 : 0 ), 0 );
+ }
+ else {
+ @$result{ 'ok', 'actual_ok' } = ( 1, $test );
+ }
+
+ if( defined $name ) {
+ $name =~ s|#|\\#|g; # # in a name can confuse Test::Harness.
+ $result->{name} = $name;
+ }
+ else {
+ $result->{name} = '';
+ }
+
+ if( $todo ) {
+ my $what_todo = $todo;
+ $result->{reason} = $what_todo;
+ $result->{type} = 'todo';
+ }
+ else {
+ $result->{reason} = '';
+ $result->{type} = '';
+ }
+
+ $Test_Results[$Curr_Test-1] = $result;
+
+ unless( $test ) {
+ my $msg = $todo ? "Failed (TODO)" : "Failed";
+ $result->{fail_diag} = (" $msg test ($file at line $line)\n");
+ }
+
+ $result->{diag} = "";
+ $result->{_level} = $Test::Builder::Level;
+ $result->{_depth} = Test::Tester::find_run_tests();
+
+ return $test ? 1 : 0;
+}
+
+sub skip {
+ my($self, $why) = @_;
+ $why ||= '';
+
+ lock($Curr_Test);
+ $Curr_Test++;
+
+ my %result;
+ share(%result);
+ %result = (
+ 'ok' => 1,
+ actual_ok => 1,
+ name => '',
+ type => 'skip',
+ reason => $why,
+ diag => "",
+ _level => $Test::Builder::Level,
+ _depth => Test::Tester::find_run_tests(),
+ );
+ $Test_Results[$Curr_Test-1] = \%result;
+
+ return 1;
+}
+
+sub todo_skip {
+ my($self, $why) = @_;
+ $why ||= '';
+
+ lock($Curr_Test);
+ $Curr_Test++;
+
+ my %result;
+ share(%result);
+ %result = (
+ 'ok' => 1,
+ actual_ok => 0,
+ name => '',
+ type => 'todo_skip',
+ reason => $why,
+ diag => "",
+ _level => $Test::Builder::Level,
+ _depth => Test::Tester::find_run_tests(),
+ );
+
+ $Test_Results[$Curr_Test-1] = \%result;
+
+ return 1;
+}
+
+sub diag {
+ my($self, @msgs) = @_;
+ return unless @msgs;
+
+ # Prevent printing headers when compiling (i.e. -c)
+ return if $^C;
+
+ # Escape each line with a #.
+ foreach (@msgs) {
+ $_ = 'undef' unless defined;
+ }
+
+ push @msgs, "\n" unless $msgs[-1] =~ /\n\Z/;
+
+ my $result = $Curr_Test ? $Test_Results[$Curr_Test - 1] : $Prem_Diag;
+
+ $result->{diag} .= join("", @msgs);
+
+ return 0;
+}
+
+sub details {
+ return @Test_Results;
+}
+
+
+# Stub. Feel free to send me a patch to implement this.
+sub note {
+}
+
+sub explain {
+ return Test::Builder::explain(@_);
+}
+
+sub premature
+{
+ return $Prem_Diag->{diag};
+}
+
+sub current_test
+{
+ if (@_ > 1)
+ {
+ die "Don't try to change the test number!";
+ }
+ else
+ {
+ return $Curr_Test;
+ }
+}
+
+sub reset
+{
+ $Curr_Test = 0;
+ @Test_Results = ();
+ $Prem_Diag = {diag => ""};
+}
+
+1;
+
+__END__
+
+=head1 NAME
+
+Test::Tester::Capture - Help testing test modules built with Test::Builder
+
+=head1 DESCRIPTION
+
+This is a subclass of Test::Builder that overrides many of the methods so
+that they don't output anything. It also keeps track of it's own set of test
+results so that you can use Test::Builder based modules to perform tests on
+other Test::Builder based modules.
+
+=head1 AUTHOR
+
+Most of the code here was lifted straight from Test::Builder and then had
+chunks removed by Fergal Daly <fergal@esatclear.ie>.
+
+=head1 LICENSE
+
+Under the same license as Perl itself
+
+See http://www.perl.com/perl/misc/Artistic.html
+
+=cut
diff --git a/Master/tlpkg/tlperl/lib/Test/Tester/CaptureRunner.pm b/Master/tlpkg/tlperl/lib/Test/Tester/CaptureRunner.pm
new file mode 100644
index 00000000000..f14a4c145aa
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/Test/Tester/CaptureRunner.pm
@@ -0,0 +1,76 @@
+# $Header: /home/fergal/my/cvs/Test-Tester/lib/Test/Tester/CaptureRunner.pm,v 1.3 2003/03/05 01:07:55 fergal Exp $
+use strict;
+
+package Test::Tester::CaptureRunner;
+
+use Test::Tester::Capture;
+require Exporter;
+
+sub new
+{
+ my $pkg = shift;
+ my $self = bless {}, $pkg;
+ return $self;
+}
+
+sub run_tests
+{
+ my $self = shift;
+
+ my $test = shift;
+
+ capture()->reset;
+
+ $self->{StartLevel} = $Test::Builder::Level;
+ &$test();
+}
+
+sub get_results
+{
+ my $self = shift;
+ my @results = capture()->details;
+
+ my $start = $self->{StartLevel};
+ foreach my $res (@results)
+ {
+ next if defined $res->{depth};
+ my $depth = $res->{_depth} - $res->{_level} - $start - 3;
+# print "my $depth = $res->{_depth} - $res->{_level} - $start - 1\n";
+ $res->{depth} = $depth;
+ }
+
+ return @results;
+}
+
+sub get_premature
+{
+ return capture()->premature;
+}
+
+sub capture
+{
+ return Test::Tester::Capture->new;
+}
+
+__END__
+
+=head1 NAME
+
+Test::Tester::CaptureRunner - Help testing test modules built with Test::Builder
+
+=head1 DESCRIPTION
+
+This stuff if needed to allow me to play with other ways of monitoring the
+test results.
+
+=head1 AUTHOR
+
+Copyright 2003 by Fergal Daly <fergal@esatclear.ie>.
+
+=head1 LICENSE
+
+Under the same license as Perl itself
+
+See http://www.perl.com/perl/misc/Artistic.html
+
+=cut
diff --git a/Master/tlpkg/tlperl/lib/Test/Tester/Delegate.pm b/Master/tlpkg/tlperl/lib/Test/Tester/Delegate.pm
new file mode 100644
index 00000000000..7ddb921cdfc
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/Test/Tester/Delegate.pm
@@ -0,0 +1,32 @@
+use strict;
+use warnings;
+
+package Test::Tester::Delegate;
+
+use vars '$AUTOLOAD';
+
+sub new
+{
+ my $pkg = shift;
+
+ my $obj = shift;
+ my $self = bless {}, $pkg;
+
+ return $self;
+}
+
+sub AUTOLOAD
+{
+ my ($sub) = $AUTOLOAD =~ /.*::(.*?)$/;
+
+ return if $sub eq "DESTROY";
+
+ my $obj = $_[0]->{Object};
+
+ my $ref = $obj->can($sub);
+ shift(@_);
+ unshift(@_, $obj);
+ goto &$ref;
+}
+
+1;