diff options
Diffstat (limited to 'Master/tlpkg/tlperl/lib/Test/Tester')
-rw-r--r-- | Master/tlpkg/tlperl/lib/Test/Tester/Capture.pm | 231 | ||||
-rw-r--r-- | Master/tlpkg/tlperl/lib/Test/Tester/CaptureRunner.pm | 76 | ||||
-rw-r--r-- | Master/tlpkg/tlperl/lib/Test/Tester/Delegate.pm | 32 |
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; |