use 5.004;
use strict;
-use Test::Builder;
# Can't use Carp because it might cause use_ok() to accidentally succeed
-require Exporter;
use vars qw($VERSION @ISA @EXPORT %EXPORT_TAGS $TODO);
-$VERSION = '0.42';
-@ISA = qw(Exporter);
+$VERSION = '0.62';
+$VERSION = eval $VERSION; # make the alpha version come out as a number
+
+use Test::Builder::Module;
+@ISA = qw(Test::Builder::Module);
@EXPORT = qw(ok use_ok require_ok
is isnt like unlike is_deeply
cmp_ok
plan
can_ok isa_ok
diag
+ BAIL_OUT
);
-my $Test = Test::Builder->new;
-
-
-# 5.004's Exporter doesn't have export_to_level.
-sub _export_to_level
-{
- my $pkg = shift;
- my $level = shift;
- (undef) = shift; # redundant arg
- my $callpkg = caller($level);
- $pkg->export($callpkg, @_);
-}
-
=head1 NAME
pass($test_name);
fail($test_name);
- # Utility comparison functions.
- eq_array(\@this, \@that);
- eq_hash(\%this, \%that);
- eq_set(\@this, \@that);
+ BAIL_OUT($why);
# UNIMPLEMENTED!!!
my @status = Test::More::status;
- # UNIMPLEMENTED!!!
- BAIL_OUT($why);
-
=head1 DESCRIPTION
use Test::More qw(no_plan);
+B<NOTE>: using no_plan requires a Test::Harness upgrade else it will
+think everything has failed. See L<CAVEATS and NOTES>).
+
In some cases, you'll want to completely skip an entire testing script.
use Test::More skip_all => $skip_reason;
=cut
sub plan {
- my(@plan) = @_;
+ my $tb = Test::More->builder;
+
+ $tb->plan(@_);
+}
+
- my $caller = caller;
+# This implements "use Test::More 'no_diag'" but the behavior is
+# deprecated.
+sub import_extra {
+ my $class = shift;
+ my $list = shift;
- $Test->exported_to($caller);
- $Test->plan(@plan);
+ my @other = ();
+ my $idx = 0;
+ while( $idx <= $#{$list} ) {
+ my $item = $list->[$idx];
- my @imports = ();
- foreach my $idx (0..$#plan) {
- if( $plan[$idx] eq 'import' ) {
- @imports = @{$plan[$idx+1]};
- last;
+ if( defined $item and $item eq 'no_diag' ) {
+ $class->builder->no_diag(1);
+ }
+ else {
+ push @other, $item;
}
- }
- __PACKAGE__->_export_to_level(1, __PACKAGE__, @imports);
-}
+ $idx++;
+ }
-sub import {
- my($class) = shift;
- goto &plan;
+ @$list = @other;
}
Should an ok() fail, it will produce some diagnostics:
not ok 18 - sufficient mucus
- # Failed test 18 (foo.t at line 42)
+ # Failed test 'sufficient mucus'
+ # in foo.t at line 42.
This is actually Test::Simple's ok() routine.
sub ok ($;$) {
my($test, $name) = @_;
- $Test->ok($test, $name);
+ my $tb = Test::More->builder;
+
+ $tb->ok($test, $name);
}
=item B<is>
Will produce something like this:
not ok 17 - Is foo the same as bar?
- # Failed test 1 (foo.t at line 139)
+ # Failed test 'Is foo the same as bar?'
+ # in foo.t at line 139.
# got: 'waffle'
# expected: 'yarblokos'
however do not be tempted to use them to find out if something is
true or false!
- # XXX BAD! $pope->isa('Catholic') eq 1
- is( $pope->isa('Catholic'), 1, 'Is the Pope Catholic?' );
+ # XXX BAD!
+ is( exists $brooklyn{tree}, 1, 'A tree grows in Brooklyn' );
-This does not check if C<$pope->isa('Catholic')> is true, it checks if
+This does not check if C<exists $brooklyn{tree}> is true, it checks if
it returns 1. Very different. Similar caveats exist for false and 0.
In these cases, use ok().
- ok( $pope->isa('Catholic') ), 'Is the Pope Catholic?' );
+ ok( exists $brooklyn{tree}, 'A tree grows in Brooklyn' );
For those grammatical pedants out there, there's an C<isn't()>
function which is an alias of isnt().
=cut
sub is ($$;$) {
- $Test->is_eq(@_);
+ my $tb = Test::More->builder;
+
+ $tb->is_eq(@_);
}
sub isnt ($$;$) {
- $Test->isnt_eq(@_);
+ my $tb = Test::More->builder;
+
+ $tb->isnt_eq(@_);
}
*isn't = \&isnt;
=cut
sub like ($$;$) {
- $Test->like(@_);
+ my $tb = Test::More->builder;
+
+ $tb->like(@_);
}
=cut
-sub unlike {
- $Test->unlike(@_);
+sub unlike ($$;$) {
+ my $tb = Test::More->builder;
+
+ $tb->unlike(@_);
}
cmp_ok( $this, '==', $that, 'this == that' );
# ok( $this && $that );
- cmp_ok( $this, '&&', $that, 'this || that' );
+ cmp_ok( $this, '&&', $that, 'this && that' );
...etc...
Its advantage over ok() is when the test fails you'll know what $this
and $that were:
not ok 1
- # Failed test (foo.t at line 12)
+ # Failed test in foo.t at line 12.
# '23'
# &&
# undef
=cut
sub cmp_ok($$$;$) {
- $Test->cmp_ok(@_);
+ my $tb = Test::More->builder;
+
+ $tb->cmp_ok(@_);
}
sub can_ok ($@) {
my($proto, @methods) = @_;
- my $class= ref $proto || $proto;
+ my $class = ref $proto || $proto;
+ my $tb = Test::More->builder;
unless( @methods ) {
- my $ok = $Test->ok( 0, "$class->can(...)" );
- $Test->diag(' can_ok() called with no methods');
+ my $ok = $tb->ok( 0, "$class->can(...)" );
+ $tb->diag(' can_ok() called with no methods');
return $ok;
}
my @nok = ();
foreach my $method (@methods) {
- my $test = "'$class'->can('$method')";
local($!, $@); # don't interfere with caller's $@
# eval sometimes resets $!
- eval $test || push @nok, $method;
+ eval { $proto->can($method) } || push @nok, $method;
}
my $name;
$name = @methods == 1 ? "$class->can('$methods[0]')"
: "$class->can(...)";
- my $ok = $Test->ok( !@nok, $name );
+ my $ok = $tb->ok( !@nok, $name );
- $Test->diag(map " $class->can('$_') failed\n", @nok);
+ $tb->diag(map " $class->can('$_') failed\n", @nok);
return $ok;
}
isa_ok($object, $class, $object_name);
isa_ok($ref, $type, $ref_name);
-Checks to see if the given $object->isa($class). Also checks to make
+Checks to see if the given C<< $object->isa($class) >>. Also checks to make
sure the object was defined in the first place. Handy for this sort
of thing:
sub isa_ok ($$;$) {
my($object, $class, $obj_name) = @_;
+ my $tb = Test::More->builder;
my $diag;
$obj_name = 'The object' unless defined $obj_name;
my $ok;
if( $diag ) {
- $ok = $Test->ok( 0, $name );
- $Test->diag(" $diag\n");
+ $ok = $tb->ok( 0, $name );
+ $tb->diag(" $diag\n");
}
else {
- $ok = $Test->ok( 1, $name );
+ $ok = $tb->ok( 1, $name );
}
return $ok;
=cut
sub pass (;$) {
- $Test->ok(1, @_);
+ my $tb = Test::More->builder;
+ $tb->ok(1, @_);
}
sub fail (;$) {
- $Test->ok(0, @_);
+ my $tb = Test::More->builder;
+ $tb->ok(0, @_);
}
=back
-=head2 Diagnostics
-
-If you pick the right test function, you'll usually get a good idea of
-what went wrong when it failed. But sometimes it doesn't work out
-that way. So here we have ways for you to write your own diagnostic
-messages which are safer than just C<print STDERR>.
-
-=over 4
-
-=item B<diag>
-
- diag(@diagnostic_message);
-
-Prints a diagnostic message which is guaranteed not to interfere with
-test output. Handy for this sort of thing:
-
- ok( grep(/foo/, @users), "There's a foo user" ) or
- diag("Since there's no foo, check that /etc/bar is set up right");
-
-which would produce:
-
- not ok 42 - There's a foo user
- # Failed test (foo.t at line 52)
- # Since there's no foo, check that /etc/bar is set up right.
-
-You might remember C<ok() or diag()> with the mnemonic C<open() or
-die()>.
-
-B<NOTE> The exact formatting of the diagnostic output is still
-changing, but it is guaranteed that whatever you throw at it it won't
-interfere with the test.
-
-=cut
-
-sub diag {
- $Test->diag(@_);
-}
-
-
-=back
=head2 Module tests
BEGIN { use_ok($module, @imports); }
These simply use the given $module and test to make sure the load
-happened ok. Its recommended that you run use_ok() inside a BEGIN
+happened ok. It's recommended that you run use_ok() inside a BEGIN
block so its functions are exported at compile-time and prototypes are
properly honored.
use Some::Module qw(foo bar);
+Version numbers can be checked like so:
+
+ # Just like "use Some::Module 1.02"
+ BEGIN { use_ok('Some::Module', 1.02) }
+
+Don't try to do this:
+
+ BEGIN {
+ use_ok('Some::Module');
+
+ ...some code that depends on the use...
+ ...happening at compile time...
+ }
+
+because the notion of "compile-time" is relative. Instead, you want:
+
+ BEGIN { use_ok('Some::Module') }
+ BEGIN { ...some code that depends on the use... }
+
=cut
sub use_ok ($;@) {
my($module, @imports) = @_;
@imports = () unless @imports;
+ my $tb = Test::More->builder;
- my $pack = caller;
+ my($pack,$filename,$line) = caller;
local($@,$!); # eval sometimes interferes with $!
- eval <<USE;
+
+ if( @imports == 1 and $imports[0] =~ /^\d+(?:\.\d+)?$/ ) {
+ # probably a version check. Perl needs to see the bare number
+ # for it to work with non-Exporter based modules.
+ eval <<USE;
package $pack;
-require $module;
-$module->import(\@imports);
+use $module $imports[0];
USE
+ }
+ else {
+ eval <<USE;
+package $pack;
+use $module \@imports;
+USE
+ }
- my $ok = $Test->ok( !$@, "use $module;" );
+ my $ok = $tb->ok( !$@, "use $module;" );
unless( $ok ) {
chomp $@;
- $Test->diag(<<DIAGNOSTIC);
+ $@ =~ s{^BEGIN failed--compilation aborted at .*$}
+ {BEGIN failed--compilation aborted at $filename line $line.}m;
+ $tb->diag(<<DIAGNOSTIC);
Tried to use '$module'.
Error: $@
DIAGNOSTIC
=item B<require_ok>
require_ok($module);
+ require_ok($file);
-Like use_ok(), except it requires the $module.
+Like use_ok(), except it requires the $module or $file.
=cut
sub require_ok ($) {
my($module) = shift;
+ my $tb = Test::More->builder;
my $pack = caller;
+ # Try to deterine if we've been given a module name or file.
+ # Module names must be barewords, files not.
+ $module = qq['$module'] unless _is_module_name($module);
+
local($!, $@); # eval sometimes interferes with $!
eval <<REQUIRE;
package $pack;
require $module;
REQUIRE
- my $ok = $Test->ok( !$@, "require $module;" );
+ my $ok = $tb->ok( !$@, "require $module;" );
unless( $ok ) {
chomp $@;
- $Test->diag(<<DIAGNOSTIC);
+ $tb->diag(<<DIAGNOSTIC);
Tried to require '$module'.
Error: $@
DIAGNOSTIC
return $ok;
}
+
+sub _is_module_name {
+ my $module = shift;
+
+ # Module names start with a letter.
+ # End with an alphanumeric.
+ # The rest is an alphanumeric or ::
+ $module =~ s/\b::\b//g;
+ $module =~ /^[a-zA-Z]\w*$/;
+}
+
+=back
+
+
+=head2 Complex data structures
+
+Not everything is a simple eq check or regex. There are times you
+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.
+
+=over 4
+
+=item B<is_deeply>
+
+ is_deeply( $this, $that, $test_name );
+
+Similar to is(), except that if $this and $that are references, it
+does a deep comparison walking each data structure to see if they are
+equivalent. If the two structures are different, it will display the
+place where they start differing.
+
+is_deeply() compares the dereferenced values of references, the
+references themselves (except for their type) are ignored. This means
+aspects such as blessing and ties are not considered "different".
+
+is_deeply() current has very limited handling of function reference
+and globs. It merely checks if they have the same referent. This may
+improve in the future.
+
+Test::Differences and Test::Deep provide more in-depth functionality
+along these lines.
+
+=cut
+
+use vars qw(@Data_Stack %Refs_Seen);
+my $DNE = bless [], 'Does::Not::Exist';
+sub is_deeply {
+ my $tb = Test::More->builder;
+
+ unless( @_ == 2 or @_ == 3 ) {
+ my $msg = <<WARNING;
+is_deeply() takes two or three args, you gave %d.
+This usually means you passed an array or hash instead
+of a reference to it
+WARNING
+ chop $msg; # clip off newline so carp() will put in line/file
+
+ _carp sprintf $msg, scalar @_;
+
+ return $tb->ok(0);
+ }
+
+ my($this, $that, $name) = @_;
+
+ $tb->_unoverload_str(\$that, \$this);
+
+ my $ok;
+ if( !ref $this and !ref $that ) { # neither is a reference
+ $ok = $tb->is_eq($this, $that, $name);
+ }
+ elsif( !ref $this xor !ref $that ) { # one's a reference, one isn't
+ $ok = $tb->ok(0, $name);
+ $tb->diag( _format_stack({ vals => [ $this, $that ] }) );
+ }
+ else { # both references
+ local @Data_Stack = ();
+ if( _deep_check($this, $that) ) {
+ $ok = $tb->ok(1, $name);
+ }
+ else {
+ $ok = $tb->ok(0, $name);
+ $tb->diag(_format_stack(@Data_Stack));
+ }
+ }
+
+ return $ok;
+}
+
+sub _format_stack {
+ my(@Stack) = @_;
+
+ my $var = '$FOO';
+ my $did_arrow = 0;
+ foreach my $entry (@Stack) {
+ my $type = $entry->{type} || '';
+ my $idx = $entry->{'idx'};
+ if( $type eq 'HASH' ) {
+ $var .= "->" unless $did_arrow++;
+ $var .= "{$idx}";
+ }
+ elsif( $type eq 'ARRAY' ) {
+ $var .= "->" unless $did_arrow++;
+ $var .= "[$idx]";
+ }
+ elsif( $type eq 'REF' ) {
+ $var = "\${$var}";
+ }
+ }
+
+ my @vals = @{$Stack[-1]{vals}}[0,1];
+ my @vars = ();
+ ($vars[0] = $var) =~ s/\$FOO/ \$got/;
+ ($vars[1] = $var) =~ s/\$FOO/\$expected/;
+
+ 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" :
+ ref $val ? "$val" :
+ "'$val'";
+ }
+
+ $out .= "$vars[0] = $vals[0]\n";
+ $out .= "$vars[1] = $vals[1]\n";
+
+ $out =~ s/^/ /msg;
+ return $out;
+}
+
+
+sub _type {
+ my $thing = shift;
+
+ return '' if !ref $thing;
+
+ for my $type (qw(ARRAY HASH REF SCALAR GLOB CODE Regexp)) {
+ return $type if UNIVERSAL::isa($thing, $type);
+ }
+
+ return '';
+}
+
=back
+
+=head2 Diagnostics
+
+If you pick the right test function, you'll usually get a good idea of
+what went wrong when it failed. But sometimes it doesn't work out
+that way. So here we have ways for you to write your own diagnostic
+messages which are safer than just C<print STDERR>.
+
+=over 4
+
+=item B<diag>
+
+ diag(@diagnostic_message);
+
+Prints a diagnostic message which is guaranteed not to interfere with
+test output. Like C<print> @diagnostic_message is simply concatenated
+together.
+
+Handy for this sort of thing:
+
+ ok( grep(/foo/, @users), "There's a foo user" ) or
+ diag("Since there's no foo, check that /etc/bar is set up right");
+
+which would produce:
+
+ not ok 42 - There's a foo user
+ # Failed test 'There's a foo user'
+ # in foo.t at line 52.
+ # Since there's no foo, check that /etc/bar is set up right.
+
+You might remember C<ok() or diag()> with the mnemonic C<open() or
+die()>.
+
+B<NOTE> The exact formatting of the diagnostic output is still
+changing, but it is guaranteed that whatever you throw at it it won't
+interfere with the test.
+
+=cut
+
+sub diag {
+ my $tb = Test::More->builder;
+
+ $tb->diag(@_);
+}
+
+
+=back
+
+
=head2 Conditional tests
Sometimes running a test under certain conditions will cause the
...normal testing code goes here...
}
-This declares a block of tests to skip, $how_many tests there are,
-$why and under what $condition to skip them. An example is the
-easiest way to illustrate:
+This declares a block of tests that might be skipped, $how_many tests
+there are, $why and under what $condition to skip them. An example is
+the easiest way to illustrate:
SKIP: {
- skip "Pigs don't fly here", 2 unless Pigs->can('fly');
+ eval { require HTML::Lint };
- my $pig = Pigs->new;
- $pig->takeoff;
+ skip "HTML::Lint not installed", 2 if $@;
- ok( $pig->altitude > 0, 'Pig is airborne' );
- ok( $pig->airspeed > 0, ' and moving' );
+ my $lint = new HTML::Lint;
+ isa_ok( $lint, "HTML::Lint" );
+
+ $lint->parse( $html );
+ is( $lint->errors, 0, "No errors found in HTML" );
}
-If pigs cannot fly, the whole block of tests will be skipped
-completely. Test::More will output special ok's which Test::Harness
-interprets as skipped tests. Its important to include $how_many tests
-are in the block so the total number of tests comes out right (unless
-you're using C<no_plan>, in which case you can leave $how_many off if
-you like).
+If the user does not have HTML::Lint installed, the whole block of
+code I<won't be run at all>. Test::More will output special ok's
+which Test::Harness interprets as skipped, but passing, tests.
-Its perfectly safe to nest SKIP blocks.
+It's important that $how_many accurately reflects the number of tests
+in the SKIP block so the # of tests run will match up with your plan.
+If your plan is C<no_plan> $how_many is optional and will default to 1.
-Tests are skipped when you B<never> expect them to B<ever> pass. Like
-an optional module is not installed or the operating system doesn't
-have some feature (like fork() or symlinks) or maybe you need an
-Internet connection and one isn't available.
+It's perfectly safe to nest SKIP blocks. Each SKIP block must have
+the label C<SKIP>, or Test::More can't work its magic.
You don't skip tests which are failing because there's a bug in your
-program. For that you use TODO. Read on.
-
-
-=for _Future
-See L</Why are skip and todo so weird?>
+program, or for which you don't yet have code written. For that you
+use TODO. Read on.
=cut
#'#
sub skip {
my($why, $how_many) = @_;
+ my $tb = Test::More->builder;
unless( defined $how_many ) {
# $how_many can only be avoided when no_plan is in use.
_carp "skip() needs to know \$how_many tests are in the block"
- unless $Test::Builder::No_Plan;
+ unless $tb->has_plan eq 'no_plan';
$how_many = 1;
}
for( 1..$how_many ) {
- $Test->skip($why);
+ $tb->skip($why);
}
local $^W = 0;
will run the tests normally, but print out special flags indicating
they are "todo". Test::Harness will interpret failures as being ok.
Should anything succeed, it will report it as an unexpected success.
+You then know the thing you had todo is done and can remove the
+TODO flag.
The nice part about todo tests, as opposed to simply commenting out a
block of tests, is it's like having a programmatic todo list. You know
Once a todo test starts succeeding, simply move it outside the block.
When the block is empty, delete it.
+B<NOTE>: TODO tests require a Test::Harness upgrade else it will
+treat it as a normal failure. See L<CAVEATS and NOTES>).
+
=item B<todo_skip>
...normal testing code...
}
-With todo tests, its best to have the tests actually run. That way
+With todo tests, it's best to have the tests actually run. That way
you'll know when they start passing. Sometimes this isn't possible.
Often a failing test will cause the whole program to die or hang, even
inside an C<eval BLOCK> with and using C<alarm>. In these extreme
sub todo_skip {
my($why, $how_many) = @_;
+ my $tb = Test::More->builder;
unless( defined $how_many ) {
# $how_many can only be avoided when no_plan is in use.
_carp "todo_skip() needs to know \$how_many tests are in the block"
- unless $Test::Builder::No_Plan;
+ unless $tb->has_plan eq 'no_plan';
$how_many = 1;
}
for( 1..$how_many ) {
- $Test->todo_skip($why);
+ $tb->todo_skip($why);
}
local $^W = 0;
last TODO;
}
+=item When do I use SKIP vs. TODO?
-=back
+B<If it's something the user might not be able to do>, use SKIP.
+This includes optional modules that aren't installed, running under
+an OS that doesn't have some feature (like fork() or symlinks), or maybe
+you need an Internet connection and one isn't available.
-=head2 Comparison functions
+B<If it's something the programmer hasn't done yet>, use TODO. This
+is for any code you haven't written yet, or bugs you have yet to fix,
+but want to put tests in your testing script (always a good idea).
-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.
-B<NOTE> These are NOT well-tested on circular references. Nor am I
-quite sure what will happen with filehandles.
+=back
+
+
+=head2 Test control
=over 4
-=item B<is_deeply>
+=item B<BAIL_OUT>
- is_deeply( $this, $that, $test_name );
+ BAIL_OUT($reason);
-Similar to is(), except that if $this and $that are hash or array
-references, it does a deep comparison walking each data structure to
-see if they are equivalent. If the two structures are different, it
-will display the place where they start differing.
+Incidates to the harness that things are going so badly all testing
+should terminate. This includes the running any additional test scripts.
-Barrie Slaymaker's Test::Differences module provides more in-depth
-functionality along these lines, and it plays well with Test::More.
+This is typically used when testing cannot continue such as a critical
+module failing to compile or a necessary external utility not being
+available such as a database connection failing.
-B<NOTE> Display of scalar refs is not quite 100%
+The test will exit with 255.
=cut
-use vars qw(@Data_Stack);
-my $DNE = bless [], 'Does::Not::Exist';
-sub is_deeply {
- my($this, $that, $name) = @_;
-
- my $ok;
- if( !ref $this || !ref $that ) {
- $ok = $Test->is_eq($this, $that, $name);
- }
- else {
- local @Data_Stack = ();
- if( _deep_check($this, $that) ) {
- $ok = $Test->ok(1, $name);
- }
- else {
- $ok = $Test->ok(0, $name);
- $ok = $Test->diag(_format_stack(@Data_Stack));
- }
- }
+sub BAIL_OUT {
+ my $reason = shift;
+ my $tb = Test::More->builder;
- return $ok;
+ $tb->BAIL_OUT($reason);
}
-sub _format_stack {
- my(@Stack) = @_;
+=back
- my $var = '$FOO';
- my $did_arrow = 0;
- foreach my $entry (@Stack) {
- my $type = $entry->{type} || '';
- my $idx = $entry->{'idx'};
- if( $type eq 'HASH' ) {
- $var .= "->" unless $did_arrow++;
- $var .= "{$idx}";
- }
- elsif( $type eq 'ARRAY' ) {
- $var .= "->" unless $did_arrow++;
- $var .= "[$idx]";
- }
- elsif( $type eq 'REF' ) {
- $var = "\${$var}";
- }
- }
- my @vals = @{$Stack[-1]{vals}}[0,1];
- my @vars = ();
- ($vars[0] = $var) =~ s/\$FOO/ \$got/;
- ($vars[1] = $var) =~ s/\$FOO/\$expected/;
+=head2 Discouraged comparison functions
- 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'";
- }
+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.
- $out .= "$vars[0] = $vals[0]\n";
- $out .= "$vars[1] = $vals[1]\n";
+These functions are usually used inside an ok().
- $out =~ s/^/ /msg;
- return $out;
-}
+ 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.
+
+=over 4
=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.
=cut
#'#
-sub eq_array {
+sub eq_array {
+ local @Data_Stack;
+ _deep_check(@_);
+}
+
+sub _eq_array {
my($a1, $a2) = @_;
+
+ if( grep !_type($_) eq 'ARRAY', $a1, $a2 ) {
+ warn "eq_array passed a non-array ref";
+ return 0;
+ }
+
return 1 if $a1 eq $a2;
my $ok = 1;
last unless $ok;
}
+
return $ok;
}
sub _deep_check {
my($e1, $e2) = @_;
+ my $tb = Test::More->builder;
+
my $ok = 0;
- my $eq;
+ # 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;
- if( $e1 eq $e2 ) {
+ $tb->_unoverload_str(\$e1, \$e2);
+
+ # 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 ( $e1 == $DNE xor $e2 == $DNE ) {
+ $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( UNIVERSAL::isa($e1, 'ARRAY') and
- UNIVERSAL::isa($e2, 'ARRAY') )
- {
- $ok = eq_array($e1, $e2);
+ if( $Refs_Seen{$e1} ) {
+ return $Refs_Seen{$e1} eq $e2;
}
- elsif( UNIVERSAL::isa($e1, 'HASH') and
- UNIVERSAL::isa($e2, 'HASH') )
- {
- $ok = eq_hash($e1, $e2);
+ else {
+ $Refs_Seen{$e1} = "$e2";
}
- elsif( UNIVERSAL::isa($e1, 'REF') and
- UNIVERSAL::isa($e2, 'REF') )
- {
- push @Data_Stack, { type => 'REF', vals => [$e1, $e2] };
+
+ my $type = _type($e1);
+ $type = 'DIFFERENT' unless _type($e2) eq $type;
+
+ if( $type eq 'DIFFERENT' ) {
+ push @Data_Stack, { type => $type, vals => [$e1, $e2] };
+ $ok = 0;
+ }
+ elsif( $type eq 'ARRAY' ) {
+ $ok = _eq_array($e1, $e2);
+ }
+ elsif( $type eq 'HASH' ) {
+ $ok = _eq_hash($e1, $e2);
+ }
+ elsif( $type eq 'REF' ) {
+ push @Data_Stack, { type => $type, vals => [$e1, $e2] };
$ok = _deep_check($$e1, $$e2);
pop @Data_Stack if $ok;
}
- elsif( UNIVERSAL::isa($e1, 'SCALAR') and
- UNIVERSAL::isa($e2, 'SCALAR') )
- {
+ elsif( $type eq 'SCALAR' ) {
push @Data_Stack, { type => 'REF', vals => [$e1, $e2] };
$ok = _deep_check($$e1, $$e2);
+ pop @Data_Stack if $ok;
}
- else {
- push @Data_Stack, { vals => [$e1, $e2] };
+ elsif( $type ) {
+ push @Data_Stack, { type => $type, vals => [$e1, $e2] };
$ok = 0;
}
+ 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.
=cut
sub eq_hash {
+ local @Data_Stack;
+ return _deep_check(@_);
+}
+
+sub _eq_hash {
my($a1, $a2) = @_;
+
+ if( grep !_type($_) eq 'HASH', $a1, $a2 ) {
+ warn "eq_hash passed a non-hash ref";
+ return 0;
+ }
+
return 1 if $a1 eq $a2;
my $ok = 1;
=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.
-=cut
+ ok( eq_set(\@this, \@that) );
+
+Is better written:
+
+ is_deeply( [sort @this], [sort @that] );
-# We must make sure that references are treated neutrally. It really
-# doesn't matter how we sort them, as long as both arrays are sorted
-# with the same algorithm.
-sub _bogus_sort { local $^W = 0; ref $a ? 0 : $a cmp $b }
+B<NOTE> By historical accident, this is not a true set comparison.
+While the order of elements does not matter, duplicate elements do.
+
+B<NOTE> eq_set() does not know how to deal with references at the top
+level. The following is an example of a comparison which might not work:
+
+ eq_set([\1, \2], [\2, \1]);
+
+Test::Deep contains much better set comparison functions.
+
+=cut
sub eq_set {
my($a1, $a2) = @_;
return 0 unless @$a1 == @$a2;
# There's faster ways to do this, but this is easiest.
- return eq_array( [sort _bogus_sort @$a1], [sort _bogus_sort @$a2] );
+ local $^W = 0;
+
+ # It really doesn't matter how we sort them, as long as both arrays are
+ # sorted with the same algorithm.
+ #
+ # Ensure that references are not accidentally treated the same as a
+ # string containing the reference.
+ #
+ # Have to inline the sort routine due to a threading/sort bug.
+ # See [rt.cpan.org 6782]
+ #
+ # I don't know how references would be sorted so we just don't sort
+ # them. This means eq_set doesn't really work with refs.
+ return eq_array(
+ [grep(ref, @$a1), sort( grep(!ref, @$a1) )],
+ [grep(ref, @$a2), sort( grep(!ref, @$a2) )],
+ );
}
=back
Returns the Test::Builder object underlying Test::More for you to play
with.
-=cut
-
-sub builder {
- return Test::Builder->new;
-}
=back
-=head1 NOTES
+=head1 EXIT CODES
+
+If all your tests passed, Test::Builder will exit with zero (which is
+normal). If anything failed it will exit with how many failed. If
+you run less (or more) tests than you planned, the missing (or extras)
+will be considered failures. If no tests were ever run Test::Builder
+will throw a warning and exit with 255. If the test died, even after
+having successfully completed all its tests, it will still be
+considered a failure and will exit with 255.
+
+So the exit codes are...
+
+ 0 all tests successful
+ 255 test died or all passed but wrong # of tests run
+ any other number how many failed (including missing or extras)
+
+If you fail more than 254 tests, it will be reported as 254.
+
+B<NOTE> This behavior may go away in future versions.
-Test::More is B<explicitly> tested all the way back to perl 5.004.
-=head1 BUGS and CAVEATS
+=head1 CAVEATS and NOTES
=over 4
-=item Making your own ok()
+=item Backwards compatibility
-If you are trying to extend Test::More, don't. Use Test::Builder
-instead.
+Test::More works with Perls as old as 5.004_05.
-=item The eq_* family has some caveats.
-=item Test::Harness upgrades
+=item Overloaded objects
+
+String overloaded objects are compared B<as strings> (or in cmp_ok()'s
+case, strings or numbers as appropriate to the comparison op). This
+prevents Test::More from piercing an object's interface allowing
+better blackbox testing. So if a function starts returning overloaded
+objects instead of bare strings your tests won't notice the
+difference. This is good.
+
+However, it does mean that functions like is_deeply() cannot be used to
+test the internals of string overloaded objects. In this case I would
+suggest Test::Deep which contains more flexible testing functions for
+complex data structures.
+
+
+=item Threads
+
+Test::More will only be aware of threads if "use threads" has been done
+I<before> Test::More is loaded. This is ok:
+
+ use threads;
+ use Test::More;
+
+This may cause problems:
+
+ use Test::More
+ use threads;
+
+
+=item Test::Harness upgrade
no_plan and todo depend on new Test::Harness features and fixes. If
you're going to distribute tests that use no_plan or todo your
CPAN. If you avoid no_plan and TODO tests, the stock Test::Harness
will work fine.
-If you simply depend on Test::More, it's own dependencies will cause a
-Test::Harness upgrade.
+Installing Test::More should also upgrade Test::Harness.
=back
=head1 SEE ALSO
L<Test::Simple> if all this confuses you and you just want to write
-some tests. You can upgrade to Test::More later (its forward
+some tests. You can upgrade to Test::More later (it's forward
compatible).
-L<Test::Differences> for more ways to test complex data structures.
-And it plays well with Test::More.
-
L<Test> is the old testing module. Its main benefit is that it has
been distributed with Perl since 5.004_05.
L<Test::Harness> for details on how your test results are interpreted
by Perl.
-L<Test::Unit> describes a very featureful unit testing interface.
+L<Test::Differences> for more ways to test complex data structures.
+And it plays well with Test::More.
+
+L<Test::Class> is like XUnit but more perlish.
+
+L<Test::Deep> gives you more powerful complex data structure testing.
+
+L<Test::Unit> is XUnit style testing.
L<Test::Inline> shows the idea of embedded testing.
-L<SelfTest> is another approach to embedded testing.
+L<Bundle::Test> installs a whole bunch of useful test modules.
=head1 AUTHORS
Michael G Schwern E<lt>schwern@pobox.comE<gt> with much inspiration
from Joshua Pritikin's Test module and lots of help from Barrie
-Slaymaker, Tony Bowden, chromatic and the perl-qa gang.
+Slaymaker, Tony Bowden, blackstar.co.uk, chromatic, Fergal Daly and
+the perl-qa gang.
+
+
+=head1 BUGS
+
+See F<http://rt.cpan.org> to report and view bugs.
=head1 COPYRIGHT
-Copyright 2001 by Michael G Schwern E<lt>schwern@pobox.comE<gt>.
+Copyright 2001, 2002, 2004 by Michael G Schwern E<lt>schwern@pobox.comE<gt>.
This program is free software; you can redistribute it and/or
modify it under the same terms as Perl itself.
https://perl5.git.perl.org / perl5.git / blobdiff