From: Rafael Garcia-Suarez Date: Thu, 5 May 2005 14:41:55 +0000 (+0000) Subject: Upgrade to Test::Simple 0.60 X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=5143c659fadb184e0a7d17e727769f92c91d37b7;hp=b4ec42b69d9617082490f2c4d5d6882716a48762;p=p5sagit%2Fp5-mst-13.2.git Upgrade to Test::Simple 0.60 p4raw-id: //depot/perl@24397 --- diff --git a/MANIFEST b/MANIFEST index 23b68c7..600775e 100644 --- a/MANIFEST +++ b/MANIFEST @@ -1857,6 +1857,7 @@ lib/Test/Simple/t/bad_plan.t Test::Builder plan() test lib/Test/Simple/t/buffer.t Test::Builder buffering test lib/Test/Simple/t/Builder.t Test::Builder tests lib/Test/Simple/t/circular_data.t Test::Simple test +lib/Test/Simple/t/create.t Test::Simple test lib/Test/Simple/t/curr_test.t Test::Builder->curr_test tests lib/Test/Simple/t/details.t Test::Builder tests lib/Test/Simple/t/diag.t Test::More diag() test @@ -1874,7 +1875,7 @@ lib/Test/Simple/t/harness_active.t Test::Simple test lib/Test/Simple/t/has_plan2.t Test::More->plan tests lib/Test/Simple/t/has_plan.t Test::Builder->plan tests lib/Test/Simple/t/import.t Test::More test, importing functions -lib/Test/Simple/t/is_deeply.t Test::More test, is_deeply() +lib/Test/Simple/t/is_deeply_fail.t Test::More test, is_deeply() lib/Test/Simple/t/is_fh.t Test::Builder test, _is_fh() lib/Test/Simple/t/maybe_regex.t Test::Builder->maybe_regex() tests lib/Test/Simple/t/missing.t Test::Simple test, missing tests @@ -2647,6 +2648,7 @@ t/lib/strict/vars Tests of "use strict 'vars'" for strict.t t/lib/Test/Simple/Catch.pm Utility module for testing Test::Simple t/lib/Test/Simple/sample_tests/death_in_eval.plx for exit.t t/lib/Test/Simple/sample_tests/death.plx for exit.t +t/lib/Test/Simple/sample_tests/exit.plx for exit.t t/lib/Test/Simple/sample_tests/extras.plx for exit.t t/lib/Test/Simple/sample_tests/five_fail.plx for exit.t t/lib/Test/Simple/sample_tests/last_minute_death.plx for exit.t diff --git a/lib/Test/Builder.pm b/lib/Test/Builder.pm index 9f6a3a4..859915b 100644 --- a/lib/Test/Builder.pm +++ b/lib/Test/Builder.pm @@ -8,7 +8,7 @@ $^C ||= 0; use strict; use vars qw($VERSION); -$VERSION = '0.22'; +$VERSION = '0.30'; $VERSION = eval $VERSION; # make the alpha version come out as a number # Make Test::Builder thread-safe for ithreads. @@ -115,19 +115,48 @@ work together>. Returns a Test::Builder object representing the current state of the test. -Since you only run one test per program, there is B +Since you only run one test per program C always returns the same Test::Builder object. No matter how many times you call new(), you're -getting the same object. (This is called a singleton). +getting the same object. This is called a singleton. This is done so that +multiple modules share such global information as the test counter and +where test output is going. + +If you want a completely new Test::Builder object different from the +singleton, use C. =cut my $Test = Test::Builder->new; sub new { my($class) = shift; - $Test ||= bless ['Move along, nothing to see here'], $class; + $Test ||= $class->create; return $Test; } + +=item B + + my $Test = Test::Builder->create; + +Ok, so there can be more than one Test::Builder object and this is how +you get it. You might use this instead of C if you're testing +a Test::Builder based module, but otherwise you probably want C. + +B: the implementation is not complete. C, for example, is +still shared amongst B Test::Builder objects, even ones created using +this method. Also, the method name may change in the future. + +=cut + +sub create { + my $class = shift; + + my $self = bless {}, $class; + $self->reset; + + return $self; +} + =item B $Test->reset; @@ -138,44 +167,33 @@ test might be run multiple times in the same process. =cut -my $Test_Died; -my $Have_Plan; -my $No_Plan; -my $Curr_Test; share($Curr_Test); use vars qw($Level); -my $Original_Pid; -my @Test_Results; share(@Test_Results); - -my $Exported_To; -my $Expected_Tests; - -my $Skip_All; - -my $Use_Nums; - -my($No_Header, $No_Ending); - -$Test->reset; sub reset { my ($self) = @_; - $Test_Died = 0; - $Have_Plan = 0; - $No_Plan = 0; - $Curr_Test = 0; - $Level = 1; - $Original_Pid = $$; - @Test_Results = (); + # We leave this a global because it has to be localized and localizing + # hash keys is just asking for pain. Also, it was documented. + $Level = 1; + + $self->{Test_Died} = 0; + $self->{Have_Plan} = 0; + $self->{No_Plan} = 0; + $self->{Original_Pid} = $$; - $Exported_To = undef; - $Expected_Tests = 0; + share($self->{Curr_Test}); + $self->{Curr_Test} = 0; + $self->{Test_Results} = &share([]); - $Skip_All = 0; + $self->{Exported_To} = undef; + $self->{Expected_Tests} = 0; - $Use_Nums = 1; + $self->{Skip_All} = 0; - ($No_Header, $No_Ending) = (0,0); + $self->{Use_Nums} = 1; + + $self->{No_Header} = 0; + $self->{No_Ending} = 0; $self->_dup_stdhandles unless $^C; @@ -205,9 +223,9 @@ sub exported_to { my($self, $pack) = @_; if( defined $pack ) { - $Exported_To = $pack; + $self->{Exported_To} = $pack; } - return $Exported_To; + return $self->{Exported_To}; } =item B @@ -228,7 +246,7 @@ sub plan { return unless $cmd; - if( $Have_Plan ) { + if( $self->{Have_Plan} ) { die sprintf "You tried to plan twice! Second plan at %s line %d\n", ($self->caller)[1,2]; } @@ -278,12 +296,12 @@ sub expected_tests { die "Number of tests must be a postive integer. You gave it '$max'.\n" unless $max =~ /^\+?\d+$/ and $max > 0; - $Expected_Tests = $max; - $Have_Plan = 1; + $self->{Expected_Tests} = $max; + $self->{Have_Plan} = 1; $self->_print("1..$max\n") unless $self->no_header; } - return $Expected_Tests; + return $self->{Expected_Tests}; } @@ -296,22 +314,26 @@ Declares that this test will run an indeterminate # of tests. =cut sub no_plan { - $No_Plan = 1; - $Have_Plan = 1; + my $self = shift; + + $self->{No_Plan} = 1; + $self->{Have_Plan} = 1; } =item B $plan = $Test->has_plan - + Find out whether a plan has been defined. $plan is either C (no plan has been set), C (indeterminate # of tests) or an integer (the number of expected tests). =cut sub has_plan { - return($Expected_Tests) if $Expected_Tests; - return('no_plan') if $No_Plan; - return(undef); + my $self = shift; + + return($self->{Expected_Tests}) if $self->{Expected_Tests}; + return('no_plan') if $self->{No_Plan}; + return(undef); }; @@ -331,7 +353,7 @@ sub skip_all { $out .= " # Skip $reason" if $reason; $out .= "\n"; - $Skip_All = 1; + $self->{Skip_All} = 1; $self->_print($out) unless $self->no_header; exit(0); @@ -364,13 +386,13 @@ sub ok { # store, so we turn it into a boolean. $test = $test ? 1 : 0; - unless( $Have_Plan ) { + unless( $self->{Have_Plan} ) { require Carp; Carp::croak("You tried to run a test without a plan! Gotta have a plan."); } - lock $Curr_Test; - $Curr_Test++; + lock $self->{Curr_Test}; + $self->{Curr_Test}++; # In case $name is a string overloaded object, force it to stringify. $self->_unoverload(\$name); @@ -397,7 +419,7 @@ ERR } $out .= "ok"; - $out .= " $Curr_Test" if $self->use_numbers; + $out .= " $self->{Curr_Test}" if $self->use_numbers; if( defined $name ) { $name =~ s|#|\\#|g; # # in a name can confuse Test::Harness. @@ -418,7 +440,7 @@ ERR $result->{type} = ''; } - $Test_Results[$Curr_Test-1] = $result; + $self->{Test_Results}[$self->{Curr_Test}-1] = $result; $out .= "\n"; $self->_print($out); @@ -771,15 +793,15 @@ sub skip { $why ||= ''; $self->_unoverload(\$why); - unless( $Have_Plan ) { + unless( $self->{Have_Plan} ) { require Carp; Carp::croak("You tried to run tests without a plan! Gotta have a plan."); } - lock($Curr_Test); - $Curr_Test++; + lock($self->{Curr_Test}); + $self->{Curr_Test}++; - $Test_Results[$Curr_Test-1] = &share({ + $self->{Test_Results}[$self->{Curr_Test}-1] = &share({ 'ok' => 1, actual_ok => 1, name => '', @@ -788,12 +810,12 @@ sub skip { }); my $out = "ok"; - $out .= " $Curr_Test" if $self->use_numbers; + $out .= " $self->{Curr_Test}" if $self->use_numbers; $out .= " # skip"; $out .= " $why" if length $why; $out .= "\n"; - $Test->_print($out); + $self->_print($out); return 1; } @@ -815,15 +837,15 @@ sub todo_skip { my($self, $why) = @_; $why ||= ''; - unless( $Have_Plan ) { + unless( $self->{Have_Plan} ) { require Carp; Carp::croak("You tried to run tests without a plan! Gotta have a plan."); } - lock($Curr_Test); - $Curr_Test++; + lock($self->{Curr_Test}); + $self->{Curr_Test}++; - $Test_Results[$Curr_Test-1] = &share({ + $self->{Test_Results}[$self->{Curr_Test}-1] = &share({ 'ok' => 1, actual_ok => 0, name => '', @@ -832,10 +854,10 @@ sub todo_skip { }); my $out = "not ok"; - $out .= " $Curr_Test" if $self->use_numbers; + $out .= " $self->{Curr_Test}" if $self->use_numbers; $out .= " # TODO & SKIP $why\n"; - $Test->_print($out); + $self->_print($out); return 1; } @@ -921,9 +943,9 @@ sub use_numbers { my($self, $use_nums) = @_; if( defined $use_nums ) { - $Use_Nums = $use_nums; + $self->{Use_Nums} = $use_nums; } - return $Use_Nums; + return $self->{Use_Nums}; } =item B @@ -947,18 +969,18 @@ sub no_header { my($self, $no_header) = @_; if( defined $no_header ) { - $No_Header = $no_header; + $self->{No_Header} = $no_header; } - return $No_Header; + return $self->{No_Header}; } sub no_ending { my($self, $no_ending) = @_; if( defined $no_ending ) { - $No_Ending = $no_ending; + $self->{No_Ending} = $no_ending; } - return $No_Ending; + return $self->{No_Ending}; } @@ -1102,32 +1124,31 @@ Defaults to STDOUT. =cut -my($Out_FH, $Fail_FH, $Todo_FH); sub output { my($self, $fh) = @_; if( defined $fh ) { - $Out_FH = _new_fh($fh); + $self->{Out_FH} = _new_fh($fh); } - return $Out_FH; + return $self->{Out_FH}; } sub failure_output { my($self, $fh) = @_; if( defined $fh ) { - $Fail_FH = _new_fh($fh); + $self->{Fail_FH} = _new_fh($fh); } - return $Fail_FH; + return $self->{Fail_FH}; } sub todo_output { my($self, $fh) = @_; if( defined $fh ) { - $Todo_FH = _new_fh($fh); + $self->{Todo_FH} = _new_fh($fh); } - return $Todo_FH; + return $self->{Todo_FH}; } @@ -1142,6 +1163,7 @@ sub _new_fh { $fh = do { local *FH }; open $fh, ">$file_or_fh" or die "Can't open test output log $file_or_fh: $!"; + _autoflush($fh); } return $fh; @@ -1169,11 +1191,10 @@ sub _autoflush { } -my $Opened_Testhandles = 0; sub _dup_stdhandles { my $self = shift; - $self->_open_testhandles unless $Opened_Testhandles; + $self->_open_testhandles; # Set everything to unbuffered else plain prints to STDOUT will # come out in the wrong order from our own prints. @@ -1182,12 +1203,15 @@ sub _dup_stdhandles { _autoflush(\*TESTERR); _autoflush(\*STDERR); - $Test->output(\*TESTOUT); - $Test->failure_output(\*TESTERR); - $Test->todo_output(\*TESTOUT); + $self->output(\*TESTOUT); + $self->failure_output(\*TESTERR); + $self->todo_output(\*TESTOUT); } + +my $Opened_Testhandles = 0; sub _open_testhandles { + return if $Opened_Testhandles; # We dup STDOUT and STDERR so people can change them in their # test suites while still getting normal test output. open(TESTOUT, ">&STDOUT") or die "Can't dup STDOUT: $!"; @@ -1220,20 +1244,21 @@ can erase history if you really want to. sub current_test { my($self, $num) = @_; - lock($Curr_Test); + lock($self->{Curr_Test}); if( defined $num ) { - unless( $Have_Plan ) { + unless( $self->{Have_Plan} ) { require Carp; Carp::croak("Can't change the current test number without a plan!"); } - $Curr_Test = $num; + $self->{Curr_Test} = $num; # If the test counter is being pushed forward fill in the details. - if( $num > @Test_Results ) { - my $start = @Test_Results ? $#Test_Results + 1 : 0; + my $test_results = $self->{Test_Results}; + if( $num > @$test_results ) { + my $start = @$test_results ? @$test_results : 0; for ($start..$num-1) { - $Test_Results[$_] = &share({ + $test_results->[$_] = &share({ 'ok' => 1, actual_ok => undef, reason => 'incrementing test number', @@ -1243,11 +1268,11 @@ sub current_test { } } # If backward, wipe history. Its their funeral. - elsif( $num < @Test_Results ) { - $#Test_Results = $num - 1; + elsif( $num < @$test_results ) { + $#{$test_results} = $num - 1; } } - return $Curr_Test; + return $self->{Curr_Test}; } @@ -1265,7 +1290,7 @@ Of course, test #1 is $tests[0], etc... sub summary { my($self) = shift; - return map { $_->{'ok'} } @Test_Results; + return map { $_->{'ok'} } @{ $self->{Test_Results} }; } =item B
@@ -1318,7 +1343,8 @@ result in this structure: =cut sub details { - return @Test_Results; + my $self = shift; + return @{ $self->{Test_Results} }; } =item B @@ -1331,9 +1357,9 @@ will be considered 'todo' (see Test::More and Test::Harness for details). Returns the reason (ie. the value of $TODO) if running as todo tests, false otherwise. -todo() is pretty part about finding the right package to look for -$TODO in. It uses the exported_to() package to find it. If that's -not set, it's pretty good at guessing the right package to look at. +todo() is about finding the right package to look for $TODO in. It +uses the exported_to() package to find it. If that's not set, it's +pretty good at guessing the right package to look at based on $Level. Sometimes there is some confusion about where todo() should be looking for the $TODO variable. If you want to be sure, tell it explicitly @@ -1344,7 +1370,8 @@ what $pack to use. sub todo { my($self, $pack) = @_; - $pack = $pack || $self->exported_to || $self->caller(1); + $pack = $pack || $self->exported_to || $self->caller($Level); + return 0 unless $pack; no strict 'refs'; return defined ${$pack.'::TODO'} ? ${$pack.'::TODO'} @@ -1379,7 +1406,7 @@ sub caller { =item B<_sanity_check> - _sanity_check(); + $self->_sanity_check(); Runs a bunch of end of test sanity checks to make sure reality came through ok. If anything is wrong it will die with a fairly friendly @@ -1389,10 +1416,12 @@ error message. #'# sub _sanity_check { - _whoa($Curr_Test < 0, 'Says here you ran a negative number of tests!'); - _whoa(!$Have_Plan and $Curr_Test, + my $self = shift; + + _whoa($self->{Curr_Test} < 0, 'Says here you ran a negative number of tests!'); + _whoa(!$self->{Have_Plan} and $self->{Curr_Test}, 'Somehow your tests ran without a plan!'); - _whoa($Curr_Test != @Test_Results, + _whoa($self->{Curr_Test} != @{ $self->{Test_Results} }, 'Somehow you got a different number of results than tests ran!'); } @@ -1449,65 +1478,70 @@ $SIG{__DIE__} = sub { for( my $stack = 1; my $sub = (CORE::caller($stack))[3]; $stack++ ) { $in_eval = 1 if $sub =~ /^\(eval\)/; } - $Test_Died = 1 unless $in_eval; + $Test->{Test_Died} = 1 unless $in_eval; }; sub _ending { my $self = shift; - _sanity_check(); + $self->_sanity_check(); # Don't bother with an ending if this is a forked copy. Only the parent # should do the ending. - do{ _my_exit($?) && return } if $Original_Pid != $$; - - # Bailout if plan() was never called. This is so - # "require Test::Simple" doesn't puke. - do{ _my_exit(0) && return } if !$Have_Plan && !$Test_Died; + # Exit if plan() was never called. This is so "require Test::Simple" + # doesn't puke. + if( ($self->{Original_Pid} != $$) or + (!$self->{Have_Plan} && !$self->{Test_Died}) ) + { + _my_exit($?); + return; + } # Figure out if we passed or failed and print helpful messages. - if( @Test_Results ) { + my $test_results = $self->{Test_Results}; + if( @$test_results ) { # The plan? We have no plan. - if( $No_Plan ) { - $self->_print("1..$Curr_Test\n") unless $self->no_header; - $Expected_Tests = $Curr_Test; + if( $self->{No_Plan} ) { + $self->_print("1..$self->{Curr_Test}\n") unless $self->no_header; + $self->{Expected_Tests} = $self->{Curr_Test}; } # Auto-extended arrays and elements which aren't explicitly # filled in with a shared reference will puke under 5.8.0 # ithreads. So we have to fill them in by hand. :( my $empty_result = &share({}); - for my $idx ( 0..$Expected_Tests-1 ) { - $Test_Results[$idx] = $empty_result - unless defined $Test_Results[$idx]; + for my $idx ( 0..$self->{Expected_Tests}-1 ) { + $test_results->[$idx] = $empty_result + unless defined $test_results->[$idx]; } - my $num_failed = grep !$_->{'ok'}, @Test_Results[0..$Expected_Tests-1]; - $num_failed += abs($Expected_Tests - @Test_Results); + my $num_failed = grep !$_->{'ok'}, + @{$test_results}[0..$self->{Expected_Tests}-1]; + $num_failed += abs($self->{Expected_Tests} - @$test_results); - if( $Curr_Test < $Expected_Tests ) { - my $s = $Expected_Tests == 1 ? '' : 's'; + if( $self->{Curr_Test} < $self->{Expected_Tests} ) { + my $s = $self->{Expected_Tests} == 1 ? '' : 's'; $self->diag(<<"FAIL"); -Looks like you planned $Expected_Tests test$s but only ran $Curr_Test. +Looks like you planned $self->{Expected_Tests} test$s but only ran $self->{Curr_Test}. FAIL } - elsif( $Curr_Test > $Expected_Tests ) { - my $num_extra = $Curr_Test - $Expected_Tests; - my $s = $Expected_Tests == 1 ? '' : 's'; + elsif( $self->{Curr_Test} > $self->{Expected_Tests} ) { + my $num_extra = $self->{Curr_Test} - $self->{Expected_Tests}; + my $s = $self->{Expected_Tests} == 1 ? '' : 's'; $self->diag(<<"FAIL"); -Looks like you planned $Expected_Tests test$s but ran $num_extra extra. +Looks like you planned $self->{Expected_Tests} test$s but ran $num_extra extra. FAIL } elsif ( $num_failed ) { my $s = $num_failed == 1 ? '' : 's'; $self->diag(<<"FAIL"); -Looks like you failed $num_failed test$s of $Expected_Tests. +Looks like you failed $num_failed test$s of $self->{Expected_Tests}. FAIL } - if( $Test_Died ) { + if( $self->{Test_Died} ) { $self->diag(<<"FAIL"); -Looks like your test died just after $Curr_Test. +Looks like your test died just after $self->{Curr_Test}. FAIL _my_exit( 255 ) && return; @@ -1515,10 +1549,10 @@ FAIL _my_exit( $num_failed <= 254 ? $num_failed : 254 ) && return; } - elsif ( $Skip_All ) { + elsif ( $self->{Skip_All} ) { _my_exit( 0 ) && return; } - elsif ( $Test_Died ) { + elsif ( $self->{Test_Died} ) { $self->diag(<<'FAIL'); Looks like your test died before it could output anything. FAIL diff --git a/lib/Test/More.pm b/lib/Test/More.pm index aa02808..a40ae4b 100644 --- a/lib/Test/More.pm +++ b/lib/Test/More.pm @@ -18,7 +18,7 @@ sub _carp { require Exporter; use vars qw($VERSION @ISA @EXPORT %EXPORT_TAGS $TODO); -$VERSION = '0.54'; +$VERSION = '0.60'; $VERSION = eval $VERSION; # make the alpha version come out as a number @ISA = qw(Exporter); @@ -100,11 +100,6 @@ Test::More - yet another framework for writing test scripts pass($test_name); fail($test_name); - # Utility comparison functions. - eq_array(\@this, \@that); - eq_hash(\%this, \%that); - eq_set(\@this, \@that); - # UNIMPLEMENTED!!! my @status = Test::More::status; @@ -805,7 +800,7 @@ sub _is_module_name { # End with an alphanumeric. # The rest is an alphanumeric or :: $module =~ s/\b::\b//g; - $module =~ /^[a-zA-Z]\w+$/; + $module =~ /^[a-zA-Z]\w*$/; } =back @@ -982,11 +977,11 @@ but want to put tests in your testing script (always a good idea). =back -=head2 Comparison functions +=head2 Complex data structures Not everything is a simple eq check or regex. There are times you -need to see if two arrays are equivalent, for instance. For these -instances, Test::More provides a handful of useful functions. +need to see if two data structures are equivalent. For these +instances Test::More provides a handful of useful functions. B I'm not quite sure what will happen with filehandles. @@ -1018,26 +1013,28 @@ WARNING chop $msg; # clip off newline so carp() will put in line/file _carp sprintf $msg, scalar @_; + + return $Test->ok(0); } my($this, $that, $name) = @_; my $ok; - if( !ref $this xor !ref $that ) { # one's a reference, one isn't - $ok = 0; - } - if( !ref $this and !ref $that ) { + if( !ref $this and !ref $that ) { # neither is a reference $ok = $Test->is_eq($this, $that, $name); } - else { + elsif( !ref $this xor !ref $that ) { # one's a reference, one isn't + $ok = $Test->ok(0, $name); + $Test->diag( _format_stack({ vals => [ $this, $that ] }) ); + } + else { # both references local @Data_Stack = (); - local %Refs_Seen = (); if( _deep_check($this, $that) ) { $ok = $Test->ok(1, $name); } else { $ok = $Test->ok(0, $name); - $ok = $Test->diag(_format_stack(@Data_Stack)); + $Test->diag(_format_stack(@Data_Stack)); } } @@ -1073,9 +1070,10 @@ sub _format_stack { my $out = "Structures begin differing at:\n"; foreach my $idx (0..$#vals) { my $val = $vals[$idx]; - $vals[$idx] = !defined $val ? 'undef' : - $val eq $DNE ? "Does not exist" - : "'$val'"; + $vals[$idx] = !defined $val ? 'undef' : + $val eq $DNE ? "Does not exist" : + ref $val ? "$val" : + "'$val'"; } $out .= "$vars[0] = $vals[0]\n"; @@ -1099,9 +1097,28 @@ sub _type { } +=head2 Discouraged comparison functions + +The use of the following functions is discouraged as they are not +actually testing functions and produce no diagnostics to help figure +out what went wrong. They were written before is_deeply() existed +because I couldn't figure out how to display a useful diff of two +arbitrary data structures. + +These functions are usually used inside an ok(). + + ok( eq_array(\@this, \@that) ); + +C can do that better and with diagnostics. + + is_deeply( \@this, \@that ); + +They may be deprecated in future versions. + + =item B - eq_array(\@this, \@that); + my $is_eq = eq_array(\@this, \@that); Checks if two arrays are equivalent. This is a deep check, so multi-level structures are handled correctly. @@ -1111,8 +1128,7 @@ multi-level structures are handled correctly. #'# sub eq_array { local @Data_Stack; - local %Refs_Seen; - _eq_array(@_); + _deep_check(@_); } sub _eq_array { @@ -1125,13 +1141,6 @@ sub _eq_array { return 1 if $a1 eq $a2; - if($Refs_Seen{$a1}) { - return $Refs_Seen{$a1} eq $a2; - } - else { - $Refs_Seen{$a1} = "$a2"; - } - my $ok = 1; my $max = $#$a1 > $#$a2 ? $#$a1 : $#$a2; for (0..$max) { @@ -1152,6 +1161,11 @@ sub _deep_check { my($e1, $e2) = @_; my $ok = 0; + # Effectively turn %Refs_Seen into a stack. This avoids picking up + # the same referenced used twice (such as [\$a, \$a]) to be considered + # circular. + local %Refs_Seen = %Refs_Seen; + { # Quiet uninitialized value warnings when comparing undefs. local $^W = 0; @@ -1160,6 +1174,7 @@ sub _deep_check { # Either they're both references or both not. my $same_ref = !(!ref $e1 xor !ref $e2); + my $not_ref = (!ref $e1 and !ref $e2); if( defined $e1 xor defined $e2 ) { $ok = 0; @@ -1170,12 +1185,23 @@ sub _deep_check { elsif ( $same_ref and ($e1 eq $e2) ) { $ok = 1; } + elsif ( $not_ref ) { + push @Data_Stack, { type => '', vals => [$e1, $e2] }; + $ok = 0; + } else { + if( $Refs_Seen{$e1} ) { + return $Refs_Seen{$e1} eq $e2; + } + else { + $Refs_Seen{$e1} = "$e2"; + } + my $type = _type($e1); - $type = '' unless _type($e2) eq $type; + $type = 'DIFFERENT' unless _type($e2) eq $type; - if( !$type ) { - push @Data_Stack, { vals => [$e1, $e2] }; + if( $type eq 'DIFFERENT' ) { + push @Data_Stack, { type => $type, vals => [$e1, $e2] }; $ok = 0; } elsif( $type eq 'ARRAY' ) { @@ -1185,7 +1211,7 @@ sub _deep_check { $ok = _eq_hash($e1, $e2); } elsif( $type eq 'REF' ) { - push @Data_Stack, { type => 'REF', vals => [$e1, $e2] }; + push @Data_Stack, { type => $type, vals => [$e1, $e2] }; $ok = _deep_check($$e1, $$e2); pop @Data_Stack if $ok; } @@ -1194,6 +1220,9 @@ sub _deep_check { $ok = _deep_check($$e1, $$e2); pop @Data_Stack if $ok; } + else { + _whoa(1, "No type in _deep_check"); + } } } @@ -1201,9 +1230,20 @@ sub _deep_check { } +sub _whoa { + my($check, $desc) = @_; + if( $check ) { + die < - eq_hash(\%this, \%that); + my $is_eq = eq_hash(\%this, \%that); Determines if the two hashes contain the same keys and values. This is a deep check. @@ -1212,8 +1252,7 @@ is a deep check. sub eq_hash { local @Data_Stack; - local %Refs_Seen; - return _eq_hash(@_); + return _deep_check(@_); } sub _eq_hash { @@ -1226,13 +1265,6 @@ sub _eq_hash { return 1 if $a1 eq $a2; - if( $Refs_Seen{$a1} ) { - return $Refs_Seen{$a1} eq $a2; - } - else { - $Refs_Seen{$a1} = "$a2"; - } - my $ok = 1; my $bigger = keys %$a1 > keys %$a2 ? $a1 : $a2; foreach my $k (keys %$bigger) { @@ -1251,15 +1283,23 @@ sub _eq_hash { =item B - eq_set(\@this, \@that); + my $is_eq = eq_set(\@this, \@that); Similar to eq_array(), except the order of the elements is B important. This is a deep check, but the irrelevancy of order only applies to the top level. + ok( eq_set(\@this, \@that) ); + +Is better written: + + is_deeply( [sort @this], [sort @that] ); + B By historical accident, this is not a true set comparision. While the order of elements does not matter, duplicate elements do. +Test::Deep contains much better set comparison functions. + =cut sub eq_set { @@ -1330,6 +1370,8 @@ So the exit codes are... If you fail more than 254 tests, it will be reported as 254. +B This behavior may go away in future versions. + =head1 CAVEATS and NOTES diff --git a/lib/Test/Simple.pm b/lib/Test/Simple.pm index 05b4dd5..f84ac5e 100644 --- a/lib/Test/Simple.pm +++ b/lib/Test/Simple.pm @@ -4,7 +4,7 @@ use 5.004; use strict 'vars'; use vars qw($VERSION); -$VERSION = '0.54'; +$VERSION = '0.60'; $VERSION = eval $VERSION; # make the alpha version come out as a number @@ -130,7 +130,7 @@ Here's an example of a simple .t file for the fictional Film module. Rating => 'R', NumExplodingSheep => 1 }); - ok( defined($btaste) and ref $btaste eq 'Film', 'new() works' ); + ok( defined($btaste) && ref $btaste eq 'Film, 'new() works' ); ok( $btaste->Title eq 'Bad Taste', 'Title() get' ); ok( $btaste->Director eq 'Peter Jackson', 'Director() get' ); diff --git a/lib/Test/Simple/Changes b/lib/Test/Simple/Changes index f9e6483..d046129 100644 --- a/lib/Test/Simple/Changes +++ b/lib/Test/Simple/Changes @@ -1,3 +1,24 @@ +0.60 Tue May 3 14:20:34 PDT 2005 + +0.59_01 Tue Apr 26 21:51:12 PDT 2005 + * Test::Builder now has a create() method which allows you to create + a brand spanking new Test::Builder object. + * require_ok() was not working for single letter module names. + * is_deeply() and eq_* now work with circular scalar references + (Thanks Fergal) + * Use of eq_* now officially discouraged. + - Removed eq_* from the SYNOPSIS. + - is_deeply(undef, $not_undef); now works. [rt.cpan.org 9441] + - is_deeply() was mistakenly interpeting the same reference used twice + in a data structure as being circular causing failures. + [rt.cpan.org 11623] + - Loading Test::Builder but not using it would interfere with the + exit code if the code exited. [rt.cpan.org 12310] + - is_deeply() diagnostics now disambiguate between stringified references + and references. [rt.cpan.org 8865] + - Files opened by the output methods are now autoflushed. + - todo() now honors $Level when looking for $TODO. + 0.54 Wed Dec 15 04:18:43 EST 2004 * $how_many is optional for skip() and todo_skip(). Thanks to Devel::Cover for pointing this out. diff --git a/lib/Test/Simple/t/00signature.t b/lib/Test/Simple/t/00signature.t index 3032dc7..778faa3 100644 --- a/lib/Test/Simple/t/00signature.t +++ b/lib/Test/Simple/t/00signature.t @@ -25,7 +25,9 @@ else { my $ret = Module::Signature::verify(); SKIP: { skip "Module::Signature cannot verify", 1 - if $ret eq Module::Signature::CANNOT_VERIFY(); + if $ret eq Module::Signature::CANNOT_VERIFY() or + $ret eq Module::Signature::CIPHER_UNKNOWN(); cmp_ok $ret, '==', Module::Signature::SIGNATURE_OK(), "Valid signature"; } + diff --git a/lib/Test/Simple/t/circular_data.t b/lib/Test/Simple/t/circular_data.t index d7d17dc..2fd819e 100644 --- a/lib/Test/Simple/t/circular_data.t +++ b/lib/Test/Simple/t/circular_data.t @@ -13,7 +13,7 @@ BEGIN { } use strict; -use Test::More tests => 5; +use Test::More tests => 11; my $a1 = [ 1, 2, 3 ]; push @$a1, $a1; @@ -31,3 +31,41 @@ $h2->{4} = $h2; is_deeply $h1, $h2; ok( eq_hash ($h1, $h2) ); + +my ($r, $s); + +$r = \$r; +$s = \$s; + +ok( eq_array ([$s], [$r]) ); + + +{ + # Classic set of circular scalar refs. + my($a,$b,$c); + $a = \$b; + $b = \$c; + $c = \$a; + + my($d,$e,$f); + $d = \$e; + $e = \$f; + $f = \$d; + + is_deeply( $a, $a ); + is_deeply( $a, $d ); +} + + +{ + # rt.cpan.org 11623 + # Make sure the circular ref checks don't get confused by a reference + # which is simply repeating. + my $a = {}; + my $b = {}; + my $c = {}; + + is_deeply( [$a, $a], [$b, $c] ); + is_deeply( { foo => $a, bar => $a }, { foo => $b, bar => $c } ); + is_deeply( [\$a, \$a], [\$b, \$c] ); +} diff --git a/lib/Test/Simple/t/exit.t b/lib/Test/Simple/t/exit.t index 0ba76ba..0e30ce7 100644 --- a/lib/Test/Simple/t/exit.t +++ b/lib/Test/Simple/t/exit.t @@ -58,6 +58,7 @@ my %Tests = ( 'pre_plan_death.plx' => ['not zero', 'not zero'], 'death_in_eval.plx' => [0, 0], 'require.plx' => [0, 0], + 'exit.plx' => [1, 4], ); print "1..".keys(%Tests)."\n"; diff --git a/lib/Test/Simple/t/fork.t b/lib/Test/Simple/t/fork.t index ca103b1..55d7aec 100644 --- a/lib/Test/Simple/t/fork.t +++ b/lib/Test/Simple/t/fork.t @@ -10,7 +10,13 @@ BEGIN { use Test::More; use Config; -if( !$Config{d_fork} ) { +my $Can_Fork = $Config{d_fork} || + (($^O eq 'MSWin32' || $^O eq 'NetWare') and + $Config{useithreads} and + $Config{ccflags} =~ /-DPERL_IMPLICIT_SYS/ + ); + +if( !$Can_Fork ) { plan skip_all => "This system cannot fork"; } else { @@ -23,3 +29,4 @@ if( fork ) { # parent else { exit; # child } + diff --git a/lib/Test/Simple/t/has_plan.t b/lib/Test/Simple/t/has_plan.t index d3f888f..d0be86a 100644 --- a/lib/Test/Simple/t/has_plan.t +++ b/lib/Test/Simple/t/has_plan.t @@ -14,10 +14,10 @@ my $unplanned; BEGIN { $unplanned = 'oops'; - $unplanned = Test::Builder->has_plan; + $unplanned = Test::Builder->new->has_plan; }; use Test::More tests => 2; is($unplanned, undef, 'no plan yet defined'); -is(Test::Builder->has_plan, 2, 'has fixed plan'); +is(Test::Builder->new->has_plan, 2, 'has fixed plan'); diff --git a/lib/Test/Simple/t/has_plan2.t b/lib/Test/Simple/t/has_plan2.t index b988737..33e0923 100644 --- a/lib/Test/Simple/t/has_plan2.t +++ b/lib/Test/Simple/t/has_plan2.t @@ -31,4 +31,4 @@ use strict; use Test::Builder; plan 'no_plan'; -is(Test::Builder->has_plan, 'no_plan', 'has no_plan'); +is(Test::Builder->new->has_plan, 'no_plan', 'has no_plan'); diff --git a/lib/Test/Simple/t/is_deeply.t b/lib/Test/Simple/t/is_deeply.t deleted file mode 100644 index c6b1625..0000000 --- a/lib/Test/Simple/t/is_deeply.t +++ /dev/null @@ -1,303 +0,0 @@ -#!/usr/bin/perl -w - -BEGIN { - if( $ENV{PERL_CORE} ) { - chdir 't'; - @INC = ('../lib', 'lib'); - } - else { - unshift @INC, 't/lib'; - } -} - -use strict; - -use Test::Builder; -require Test::Simple::Catch; -my($out, $err) = Test::Simple::Catch::caught(); -Test::Builder->new->no_header(1); -Test::Builder->new->no_ending(1); -local $ENV{HARNESS_ACTIVE} = 0; - - -# Can't use Test.pm, that's a 5.005 thing. -package main; - -print "1..38\n"; - -my $test_num = 1; -# Utility testing functions. -sub ok ($;$) { - my($test, $name) = @_; - my $ok = ''; - $ok .= "not " unless $test; - $ok .= "ok $test_num"; - $ok .= " - $name" if defined $name; - $ok .= "\n"; - print $ok; - $test_num++; - - return $test; -} - -sub is ($$;$) { - my($this, $that, $name) = @_; - my $test = $$this eq $that; - my $ok = ''; - $ok .= "not " unless $test; - $ok .= "ok $test_num"; - $ok .= " - $name" if defined $name; - $ok .= "\n"; - print $ok; - - unless( $test ) { - print "# got \n$$this"; - print "# expected \n$that"; - } - $test_num++; - - $$this = ''; - - return $test; -} - -sub like ($$;$) { - my($this, $regex, $name) = @_; - - $regex = qr/$regex/ unless ref $regex; - my $test = $$this =~ $regex; - - my $ok = ''; - $ok .= "not " unless $test; - $ok .= "ok $test_num"; - $ok .= " - $name" if defined $name; - $ok .= "\n"; - print $ok; - - unless( $test ) { - print "# got \n$$this"; - print "# expected \n$regex"; - } - $test_num++; - - $$this = ''; - - - return $test; -} - - -require Test::More; -Test::More->import(tests => 11, import => ['is_deeply']); - -my $Filename = quotemeta $0; - -#line 68 -is_deeply('foo', 'bar', 'plain strings'); -is( $out, "not ok 1 - plain strings\n", 'plain strings' ); -is( $err, < 42 }, { this => 43 }, 'hashes with different values'); -is( $out, "not ok 3 - hashes with different values\n", - 'hashes with different values' ); -is( $err, <{this} = '42' -# \$expected->{this} = '43' -ERR - -#line 99 -is_deeply({ that => 42 }, { this => 42 }, 'hashes with different keys'); -is( $out, "not ok 4 - hashes with different keys\n", - 'hashes with different keys' ); -is( $err, <{this} = Does not exist -# \$expected->{this} = '42' -ERR - -#line 110 -is_deeply([1..9], [1..10], 'arrays of different length'); -is( $out, "not ok 5 - arrays of different length\n", - 'arrays of different length' ); -is( $err, <[9] = Does not exist -# \$expected->[9] = '10' -ERR - -#line 121 -is_deeply([undef, undef], [undef], 'arrays of undefs' ); -is( $out, "not ok 6 - arrays of undefs\n", 'arrays of undefs' ); -is( $err, <[1] = undef -# \$expected->[1] = Does not exist -ERR - -#line 131 -is_deeply({ foo => undef }, {}, 'hashes of undefs' ); -is( $out, "not ok 7 - hashes of undefs\n", 'hashes of undefs' ); -is( $err, <{foo} = undef -# \$expected->{foo} = Does not exist -ERR - -#line 141 -is_deeply(\42, \23, 'scalar refs'); -is( $out, "not ok 8 - scalar refs\n", 'scalar refs' ); -is( $err, < \$a3 }; -# $b2 = { foo => \$b3 }; -# is_deeply([$a1], [$b1], 'deep mixed scalar refs'); - -my $foo = { - this => [1..10], - that => { up => "down", left => "right" }, - }; - -my $bar = { - this => [1..10], - that => { up => "down", left => "right", foo => 42 }, - }; - -#line 198 -is_deeply( $foo, $bar, 'deep structures' ); -ok( @Test::More::Data_Stack == 0, '@Data_Stack not holding onto things' ); -is( $out, "not ok 11 - deep structures\n", 'deep structures' ); -is( $err, <{that}{foo} = Does not exist -# \$expected->{that}{foo} = '42' -ERR - - -#line 221 -my @tests = ([], - [qw(42)], - [qw(42 23), qw(42 23)] - ); - -foreach my $test (@tests) { - my $num_args = @$test; - - my $warning; - local $SIG{__WARN__} = sub { $warning .= join '', @_; }; - is_deeply(@$test); - - like \$warning, - qr/^is_deeply\(\) takes two or three args, you gave $num_args\.\n/; -} - - -#line 240 -# [rt.cpan.org 6837] -ok !is_deeply([{Foo => undef}],[{Foo => ""}]), 'undef != ""'; -ok( @Test::More::Data_Stack == 0, '@Data_Stack not holding onto things' ); - - -#line 258 -# [rt.cpan.org 7031] -my $a = []; -ok !is_deeply($a, $a.''), "don't compare refs like strings"; -ok !is_deeply([$a], [$a.'']), " even deep inside"; - - -#line 265 -# [rt.cpan.org 7030] -ok !is_deeply( {}, {key => []} ), '[] could match non-existent values'; -ok !is_deeply( [], [[]] ); - - -#line 273 -$$err = $$out = ''; -is_deeply( [\'a', 'b'], [\'a', 'c'] ); -is( $out, "not ok 20\n", 'scalar refs in an array' ); -is( $err, <[1] = 'b' -# \$expected->[1] = 'c' -ERR - - -#line 285 -my $ref = \23; -is_deeply( 23, $ref ); -is( $out, "not ok 21\n", 'scalar vs ref' ); -is( $err, < 6; +use Test::More tests => 8; use TieOut; ok( !Test::Builder::_is_fh("foo"), 'string is not a filehandle' ); +ok( !Test::Builder::_is_fh(''), 'empty string' ); +ok( !Test::Builder::_is_fh(undef), 'undef' ); ok( open(FILE, '>foo') ); -END { unlink 'foo' } +END { close FILE; unlink 'foo' } ok( Test::Builder::_is_fh(*FILE) ); ok( Test::Builder::_is_fh(\*FILE) ); ok( Test::Builder::_is_fh(*FILE{IO}) ); tie *OUT, 'TieOut'; -ok( Test::Builder::_is_fh(*OUT) ); \ No newline at end of file +ok( Test::Builder::_is_fh(*OUT) ); diff --git a/lib/Test/Simple/t/require_ok.t b/lib/Test/Simple/t/require_ok.t index 269b951..463a007 100644 --- a/lib/Test/Simple/t/require_ok.t +++ b/lib/Test/Simple/t/require_ok.t @@ -11,7 +11,7 @@ BEGIN { } use strict; -use Test::More tests => 7; +use Test::More tests => 8; # Symbol and Class::Struct are both non-XS core modules back to 5.004. # So they'll always be there. @@ -26,3 +26,4 @@ ok( $INC{'Class/Struct.pm'}, "require_ok FILE" ); ok !Test::More::_is_module_name('foo:bar'); ok !Test::More::_is_module_name('foo/bar.thing'); ok !Test::More::_is_module_name('Foo::Bar::'); +ok Test::More::_is_module_name('V');