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
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
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
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.
Returns a Test::Builder object representing the current state of the
test.
-Since you only run one test per program, there is B<one and only one>
+Since you only run one test per program C<new> 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<create>.
=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<create>
+
+ 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<new()> if you're testing
+a Test::Builder based module, but otherwise you probably want C<new>.
+
+B<NOTE>: the implementation is not complete. C<level>, for example, is
+still shared amongst B<all> 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<reset>
$Test->reset;
=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;
my($self, $pack) = @_;
if( defined $pack ) {
- $Exported_To = $pack;
+ $self->{Exported_To} = $pack;
}
- return $Exported_To;
+ return $self->{Exported_To};
}
=item B<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];
}
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};
}
=cut
sub no_plan {
- $No_Plan = 1;
- $Have_Plan = 1;
+ my $self = shift;
+
+ $self->{No_Plan} = 1;
+ $self->{Have_Plan} = 1;
}
=item B<has_plan>
$plan = $Test->has_plan
-
+
Find out whether a plan has been defined. $plan is either C<undef> (no plan has been set), C<no_plan> (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);
};
$out .= " # Skip $reason" if $reason;
$out .= "\n";
- $Skip_All = 1;
+ $self->{Skip_All} = 1;
$self->_print($out) unless $self->no_header;
exit(0);
# 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);
}
$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.
$result->{type} = '';
}
- $Test_Results[$Curr_Test-1] = $result;
+ $self->{Test_Results}[$self->{Curr_Test}-1] = $result;
$out .= "\n";
$self->_print($out);
$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 => '',
});
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;
}
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 => '',
});
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;
}
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<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};
}
=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};
}
$fh = do { local *FH };
open $fh, ">$file_or_fh" or
die "Can't open test output log $file_or_fh: $!";
+ _autoflush($fh);
}
return $fh;
}
-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.
_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: $!";
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',
}
}
# 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};
}
sub summary {
my($self) = shift;
- return map { $_->{'ok'} } @Test_Results;
+ return map { $_->{'ok'} } @{ $self->{Test_Results} };
}
=item B<details>
=cut
sub details {
- return @Test_Results;
+ my $self = shift;
+ return @{ $self->{Test_Results} };
}
=item B<todo>
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
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'}
=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
#'#
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!');
}
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;
_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
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);
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;
# 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
=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<NOTE> I'm not quite sure what will happen with filehandles.
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));
}
}
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";
}
+=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<is_deeply()> can do that better and with diagnostics.
+
+ is_deeply( \@this, \@that );
+
+They may be deprecated in future versions.
+
+
=item B<eq_array>
- 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.
#'#
sub eq_array {
local @Data_Stack;
- local %Refs_Seen;
- _eq_array(@_);
+ _deep_check(@_);
}
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) {
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;
# 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;
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' ) {
$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;
}
$ok = _deep_check($$e1, $$e2);
pop @Data_Stack if $ok;
}
+ else {
+ _whoa(1, "No type in _deep_check");
+ }
}
}
}
+sub _whoa {
+ my($check, $desc) = @_;
+ if( $check ) {
+ die <<WHOA;
+WHOA! $desc
+This should never happen! Please contact the author immediately!
+WHOA
+ }
+}
+
+
=item B<eq_hash>
- 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.
sub eq_hash {
local @Data_Stack;
- local %Refs_Seen;
- return _eq_hash(@_);
+ return _deep_check(@_);
}
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) {
=item B<eq_set>
- eq_set(\@this, \@that);
+ my $is_eq = eq_set(\@this, \@that);
Similar to eq_array(), except the order of the elements is B<not>
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<NOTE> 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 {
If you fail more than 254 tests, it will be reported as 254.
+B<NOTE> This behavior may go away in future versions.
+
=head1 CAVEATS and NOTES
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
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' );
+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.
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";
}
+
}
use strict;
-use Test::More tests => 5;
+use Test::More tests => 11;
my $a1 = [ 1, 2, 3 ];
push @$a1, $a1;
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] );
+}
'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";
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 {
else {
exit; # child
}
+
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');
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');
+++ /dev/null
-#!/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, <<ERR, ' right diagnostic' );
-# Failed test ($0 at line 68)
-# got: 'foo'
-# expected: 'bar'
-ERR
-
-
-#line 78
-is_deeply({}, [], 'different types');
-is( $out, "not ok 2 - different types\n", 'different types' );
-like( $err, <<ERR, ' right diagnostic' );
-# Failed test \\($Filename at line 78\\)
-# Structures begin differing at:
-# \\\$got = 'HASH\\(0x[0-9a-f]+\\)'
-# \\\$expected = 'ARRAY\\(0x[0-9a-f]+\\)'
-ERR
-
-#line 88
-is_deeply({ this => 42 }, { this => 43 }, 'hashes with different values');
-is( $out, "not ok 3 - hashes with different values\n",
- 'hashes with different values' );
-is( $err, <<ERR, ' right diagnostic' );
-# Failed test ($0 at line 88)
-# Structures begin differing at:
-# \$got->{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, <<ERR, ' right diagnostic' );
-# Failed test ($0 at line 99)
-# Structures begin differing at:
-# \$got->{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, <<ERR, ' right diagnostic' );
-# Failed test ($0 at line 110)
-# Structures begin differing at:
-# \$got->[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, <<ERR, ' right diagnostic' );
-# Failed test ($0 at line 121)
-# Structures begin differing at:
-# \$got->[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, <<ERR, ' right diagnostic' );
-# Failed test ($0 at line 131)
-# Structures begin differing at:
-# \$got->{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, <<ERR, ' right diagnostic' );
-# Failed test ($0 at line 141)
-# Structures begin differing at:
-# \${ \$got} = '42'
-# \${\$expected} = '23'
-ERR
-
-#line 151
-is_deeply([], \23, 'mixed scalar and array refs');
-is( $out, "not ok 9 - mixed scalar and array refs\n",
- 'mixed scalar and array refs' );
-like( $err, <<ERR, ' right diagnostic' );
-# Failed test \\($Filename at line 151\\)
-# Structures begin differing at:
-# \\\$got = 'ARRAY\\(0x[0-9a-f]+\\)'
-# \\\$expected = 'SCALAR\\(0x[0-9a-f]+\\)'
-ERR
-
-
-my($a1, $a2, $a3);
-$a1 = \$a2; $a2 = \$a3;
-$a3 = 42;
-
-my($b1, $b2, $b3);
-$b1 = \$b2; $b2 = \$b3;
-$b3 = 23;
-
-#line 173
-is_deeply($a1, $b1, 'deep scalar refs');
-is( $out, "not ok 10 - deep scalar refs\n", 'deep scalar refs' );
-is( $err, <<ERR, ' right diagnostic' );
-# Failed test ($0 at line 173)
-# Structures begin differing at:
-# \${\${ \$got}} = '42'
-# \${\${\$expected}} = '23'
-ERR
-
-# I don't know how to properly display this structure.
-# $a2 = { foo => \$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, <<ERR, ' right diagnostic' );
-# Failed test ($0 at line 198)
-# Structures begin differing at:
-# \$got->{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, <<ERR, ' right diagnostic' );
-# Failed test ($0 at line 274)
-# Structures begin differing at:
-# \$got->[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, <<ERR, ' right diagnostic');
-# Failed test ($0 at line 286)
-# Structures begin differing at:
-# \$got = '23'
-# \$expected = '$ref'
-ERR
-
-#line 296
-is_deeply( $ref, 23 );
-is( $out, "not ok 22\n", 'ref vs scalar' );
-is( $err, <<ERR, ' right diagnostic');
-# Failed test ($0 at line 296)
-# Structures begin differing at:
-# \$got = '$ref'
-# \$expected = '23'
-ERR
}
use strict;
-use Test::More tests => 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) );
}
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.
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');
projects / p5sagit/p5-mst-13.2.git / commitdiff