diff options
Diffstat (limited to 'Master/tlpkg/tlperl/lib/Test/Builder.pm')
-rw-r--r-- | Master/tlpkg/tlperl/lib/Test/Builder.pm | 130 |
1 files changed, 103 insertions, 27 deletions
diff --git a/Master/tlpkg/tlperl/lib/Test/Builder.pm b/Master/tlpkg/tlperl/lib/Test/Builder.pm index 26ffea41ff4..cb4335f5ceb 100644 --- a/Master/tlpkg/tlperl/lib/Test/Builder.pm +++ b/Master/tlpkg/tlperl/lib/Test/Builder.pm @@ -4,7 +4,7 @@ use 5.006; use strict; use warnings; -our $VERSION = '0.94'; +our $VERSION = '0.98'; $VERSION = eval $VERSION; ## no critic (BuiltinFunctions::ProhibitStringyEval) BEGIN { @@ -23,7 +23,7 @@ BEGIN { require threads::shared; # Hack around YET ANOTHER threads::shared bug. It would - # occassionally forget the contents of the variable when sharing it. + # occasionally forget the contents of the variable when sharing it. # So we first copy the data, then share, then put our copy back. *share = sub (\[$@%]) { my $type = ref $_[0]; @@ -90,7 +90,7 @@ Test::Builder - Backend for building test libraries =head1 DESCRIPTION Test::Simple and Test::More have proven to be popular testing modules, -but they're not always flexible enough. Test::Builder provides the a +but they're not always flexible enough. Test::Builder provides a building block upon which to write your own test libraries I<which can work together>. @@ -156,7 +156,7 @@ sub create { $child->finalize; Returns a new instance of C<Test::Builder>. Any output from this child will -indented four spaces more than the parent's indentation. When done, the +be indented four spaces more than the parent's indentation. When done, the C<finalize> method I<must> be called explicitly. Trying to create a new child with a previous child still active (i.e., @@ -174,18 +174,28 @@ sub child { $self->croak("You already have a child named ($self->{Child_Name}) running"); } + my $parent_in_todo = $self->in_todo; + + # Clear $TODO for the child. + my $orig_TODO = $self->find_TODO(undef, 1, undef); + my $child = bless {}, ref $self; $child->reset; # Add to our indentation $child->_indent( $self->_indent . ' ' ); + $child->{$_} = $self->{$_} foreach qw{Out_FH Todo_FH Fail_FH}; + if ($parent_in_todo) { + $child->{Fail_FH} = $self->{Todo_FH}; + } # This will be reset in finalize. We do this here lest one child failure # cause all children to fail. $child->{Child_Error} = $?; $? = 0; $child->{Parent} = $self; + $child->{Parent_TODO} = $orig_TODO; $child->{Name} = $name || "Child of " . $self->name; $self->{Child_Name} = $child->name; return $child; @@ -210,25 +220,71 @@ sub subtest { # Turn the child into the parent so anyone who has stored a copy of # the Test::Builder singleton will get the child. - my $child = $self->child($name); - my %parent = %$self; - %$self = %$child; + my($error, $child, %parent); + { + # child() calls reset() which sets $Level to 1, so we localize + # $Level first to limit the scope of the reset to the subtest. + local $Test::Builder::Level = $Test::Builder::Level + 1; - my $error; - if( !eval { $subtests->(); 1 } ) { - $error = $@; + $child = $self->child($name); + %parent = %$self; + %$self = %$child; + + my $run_the_subtests = sub { + $subtests->(); + $self->done_testing unless $self->_plan_handled; + 1; + }; + + if( !eval { $run_the_subtests->() } ) { + $error = $@; + } } # Restore the parent and the copied child. %$child = %$self; %$self = %parent; + # Restore the parent's $TODO + $self->find_TODO(undef, 1, $child->{Parent_TODO}); + # Die *after* we restore the parent. die $error if $error and !eval { $error->isa('Test::Builder::Exception') }; + local $Test::Builder::Level = $Test::Builder::Level + 1; return $child->finalize; } +=begin _private + +=item B<_plan_handled> + + if ( $Test->_plan_handled ) { ... } + +Returns true if the developer has explicitly handled the plan via: + +=over 4 + +=item * Explicitly setting the number of tests + +=item * Setting 'no_plan' + +=item * Set 'skip_all'. + +=back + +This is currently used in subtests when we implicitly call C<< $Test->done_testing >> +if the developer has not set a plan. + +=end _private + +=cut + +sub _plan_handled { + my $self = shift; + return $self->{Have_Plan} || $self->{No_Plan} || $self->{Skip_All}; +} + =item B<finalize> @@ -256,11 +312,14 @@ sub finalize { if( $self->{Child_Name} ) { $self->croak("Can't call finalize() with child ($self->{Child_Name}) active"); } + + local $? = 0; # don't fail if $subtests happened to set $? nonzero $self->_ending; # XXX This will only be necessary for TAP envelopes (we think) #$self->_print( $self->is_passing ? "PASS\n" : "FAIL\n" ); + local $Test::Builder::Level = $Test::Builder::Level + 1; my $ok = 1; $self->parent->{Child_Name} = undef; if ( $self->{Skip_All} ) { @@ -315,7 +374,7 @@ sub name { shift->{Name} } sub DESTROY { my $self = shift; - if ( $self->parent ) { + if ( $self->parent and $$ == $self->{Original_Pid} ) { my $name = $self->name; $self->diag(<<"FAIL"); Child ($name) exited without calling finalize() @@ -350,6 +409,7 @@ sub reset { ## no critic (Subroutines::ProhibitBuiltinHomonyms) $self->{Have_Plan} = 0; $self->{No_Plan} = 0; $self->{Have_Output_Plan} = 0; + $self->{Done_Testing} = 0; $self->{Original_Pid} = $$; $self->{Child_Name} = undef; @@ -458,7 +518,6 @@ sub _plan_tests { return; } - =item B<expected_tests> my $max = $Test->expected_tests; @@ -504,7 +563,6 @@ sub no_plan { return 1; } - =begin private =item B<_output_plan> @@ -543,6 +601,7 @@ sub _output_plan { return; } + =item B<done_testing> $Test->done_testing(); @@ -866,6 +925,8 @@ sub _is_dualvar { Like Test::More's C<is()>. Checks if C<$got eq $expected>. This is the string version. +C<undef> only ever matches another C<undef>. + =item B<is_num> $Test->is_num($got, $expected, $name); @@ -873,14 +934,14 @@ string version. Like Test::More's C<is()>. Checks if C<$got == $expected>. This is the numeric version. +C<undef> only ever matches another C<undef>. + =cut sub is_eq { my( $self, $got, $expect, $name ) = @_; local $Level = $Level + 1; - $self->_unoverload_str( \$got, \$expect ); - if( !defined $got || !defined $expect ) { # undef only matches undef and nothing else my $test = !defined $got && !defined $expect; @@ -897,8 +958,6 @@ sub is_num { my( $self, $got, $expect, $name ) = @_; local $Level = $Level + 1; - $self->_unoverload_num( \$got, \$expect ); - if( !defined $got || !defined $expect ) { # undef only matches undef and nothing else my $test = !defined $got && !defined $expect; @@ -1059,8 +1118,9 @@ sub cmp_ok { my($pack, $file, $line) = $self->caller(); + # This is so that warnings come out at the caller's level $test = eval qq[ -#line 1 "cmp_ok [from $file line $line]" +#line $line "(eval in cmp_ok) $file" \$got $type \$expect; ]; $error = $@; @@ -1685,17 +1745,18 @@ sub _print_to_fh { return if $^C; my $msg = join '', @msgs; + my $indent = $self->_indent; local( $\, $", $, ) = ( undef, ' ', '' ); # Escape each line after the first with a # so we don't # confuse Test::Harness. - $msg =~ s{\n(?!\z)}{\n# }sg; + $msg =~ s{\n(?!\z)}{\n$indent# }sg; # Stick a newline on the end if it needs it. $msg .= "\n" unless $msg =~ /\n\z/; - return print $fh $self->_indent, $msg; + return print $fh $indent, $msg; } =item B<output> @@ -1825,8 +1886,8 @@ sub _open_testhandles { open( $Testout, ">&STDOUT" ) or die "Can't dup STDOUT: $!"; open( $Testerr, ">&STDERR" ) or die "Can't dup STDERR: $!"; - # $self->_copy_io_layers( \*STDOUT, $Testout ); - # $self->_copy_io_layers( \*STDERR, $Testerr ); + $self->_copy_io_layers( \*STDOUT, $Testout ); + $self->_copy_io_layers( \*STDERR, $Testerr ); $self->{Opened_Testhandles} = 1; @@ -1841,13 +1902,21 @@ sub _copy_io_layers { require PerlIO; my @src_layers = PerlIO::get_layers($src); - binmode $dst, join " ", map ":$_", @src_layers if @src_layers; + _apply_layers($dst, @src_layers) if @src_layers; } ); return; } +sub _apply_layers { + my ($fh, @layers) = @_; + my %seen; + my @unique = grep { $_ ne 'unix' and !$seen{$_}++ } @layers; + binmode($fh, join(":", "", "raw", @unique)); +} + + =item reset_outputs $tb->reset_outputs; @@ -2091,21 +2160,28 @@ sub todo { =item B<find_TODO> my $todo_reason = $Test->find_TODO(); - my $todo_reason = $Test->find_TODO($pack): + my $todo_reason = $Test->find_TODO($pack); Like C<todo()> but only returns the value of C<$TODO> ignoring C<todo_start()>. +Can also be used to set C<$TODO> to a new value while returning the +old value: + + my $old_reason = $Test->find_TODO($pack, 1, $new_reason); + =cut sub find_TODO { - my( $self, $pack ) = @_; + my( $self, $pack, $set, $new_value ) = @_; $pack = $pack || $self->caller(1) || $self->exported_to; return unless $pack; no strict 'refs'; ## no critic - return ${ $pack . '::TODO' }; + my $old_value = ${ $pack . '::TODO' }; + $set and ${ $pack . '::TODO' } = $new_value; + return $old_value; } =item B<in_todo> @@ -2458,7 +2534,7 @@ Test::Builder. =head1 MEMORY -An informative hash, accessable via C<<details()>>, is stored for each +An informative hash, accessible via C<<details()>>, is stored for each test you perform. So memory usage will scale linearly with each test run. Although this is not a problem for most test suites, it can become an issue if you do large (hundred thousands to million) |