use 5.004;
use strict;
-use Carp;
-use Test::Utils;
+use Test::Builder;
-BEGIN {
- require Test::Simple;
- *TESTOUT = \*Test::Simple::TESTOUT;
- *TESTERR = \*Test::Simple::TESTERR;
+
+# Can't use Carp because it might cause use_ok() to accidentally succeed
+# even though the module being used forgot to use Carp. Yes, this
+# actually happened.
+sub _carp {
+ my($file, $line) = (caller(1))[1,2];
+ warn @_, " at $file line $line\n";
}
+
+
require Exporter;
-use vars qw($VERSION @ISA @EXPORT);
-$VERSION = '0.18';
+use vars qw($VERSION @ISA @EXPORT %EXPORT_TAGS $TODO);
+$VERSION = '0.54';
+$VERSION = eval $VERSION; # make the alpha version come out as a number
+
@ISA = qw(Exporter);
@EXPORT = qw(ok use_ok require_ok
- is isnt like
- skip todo
+ is isnt like unlike is_deeply
+ cmp_ok
+ skip todo todo_skip
pass fail
eq_array eq_hash eq_set
- skip
$TODO
plan
can_ok isa_ok
+ diag
);
+my $Test = Test::Builder->new;
+my $Show_Diag = 1;
-sub import {
- my($class, $plan, @args) = @_;
-
- if( defined $plan ) {
- if( $plan eq 'skip_all' ) {
- $Test::Simple::Skip_All = 1;
- my $out = "1..0";
- $out .= " # Skip @args" if @args;
- $out .= "\n";
-
- my_print *TESTOUT, $out;
- exit(0);
- }
- else {
- Test::Simple->import($plan => @args);
- }
- }
- else {
- Test::Simple->import;
- }
-
- __PACKAGE__->_export_to_level(1, __PACKAGE__);
-}
# 5.004's Exporter doesn't have export_to_level.
sub _export_to_level
{
my $pkg = shift;
my $level = shift;
- (undef) = shift; # XXX redundant arg
+ (undef) = shift; # redundant arg
my $callpkg = caller($level);
$pkg->export($callpkg, @_);
}
is ($this, $that, $test_name);
isnt($this, $that, $test_name);
- like($this, qr/that/, $test_name);
+
+ # Rather than print STDERR "# here's what went wrong\n"
+ diag("here's what went wrong");
+
+ like ($this, qr/that/, $test_name);
+ unlike($this, qr/that/, $test_name);
+
+ cmp_ok($this, '==', $that, $test_name);
+
+ is_deeply($complex_structure1, $complex_structure2, $test_name);
SKIP: {
skip $why, $how_many unless $have_some_feature;
=head1 DESCRIPTION
-If you're just getting started writing tests, have a look at
+B<STOP!> If you're just getting started writing tests, have a look at
Test::Simple first. This is a drop in replacement for Test::Simple
which you can switch to once you get the hang of basic testing.
-This module provides a very wide range of testing utilities. Various
-ways to say "ok", facilities to skip tests, test future features
-and compare complicated data structures.
+The purpose of this module is to provide a wide range of testing
+utilities. Various ways to say "ok" with better diagnostics,
+facilities to skip tests, test future features and compare complicated
+data structures. While you can do almost anything with a simple
+C<ok()> function, it doesn't provide good diagnostic output.
=head2 I love it when a plan comes together
how many tests your script is going to run to protect against premature
failure.
-The prefered way to do this is to declare a plan when you C<use Test::More>.
+The preferred way to do this is to declare a plan when you C<use Test::More>.
use Test::More tests => $Num_Tests;
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<BUGS and CAVEATS>)
+
In some cases, you'll want to completely skip an entire testing script.
use Test::More skip_all => $skip_reason;
exit immediately with a zero (success). See L<Test::Harness> for
details.
+If you want to control what functions Test::More will export, you
+have to use the 'import' option. For example, to import everything
+but 'fail', you'd do:
+
+ use Test::More tests => 23, import => ['!fail'];
+
+Alternatively, you can use the plan() function. Useful for when you
+have to calculate the number of tests.
+
+ use Test::More;
+ plan tests => keys %Stuff * 3;
+
+or for deciding between running the tests at all:
+
+ use Test::More;
+ if( $^O eq 'MacOS' ) {
+ plan skip_all => 'Test irrelevant on MacOS';
+ }
+ else {
+ plan tests => 42;
+ }
+
+=cut
+
+sub plan {
+ my(@plan) = @_;
+
+ my $idx = 0;
+ my @cleaned_plan;
+ while( $idx <= $#plan ) {
+ my $item = $plan[$idx];
+
+ if( $item eq 'no_diag' ) {
+ $Show_Diag = 0;
+ }
+ else {
+ push @cleaned_plan, $item;
+ }
+
+ $idx++;
+ }
+
+ $Test->plan(@cleaned_plan);
+}
+
+sub import {
+ my($class) = shift;
+
+ my $caller = caller;
+
+ $Test->exported_to($caller);
+
+ my $idx = 0;
+ my @plan;
+ my @imports;
+ while( $idx <= $#_ ) {
+ my $item = $_[$idx];
+
+ if( $item eq 'import' ) {
+ push @imports, @{$_[$idx+1]};
+ $idx++;
+ }
+ else {
+ push @plan, $item;
+ }
+
+ $idx++;
+ }
+
+ plan(@plan);
+
+ __PACKAGE__->_export_to_level(1, __PACKAGE__, @imports);
+}
+
=head2 Test names
By convention, each test is assigned a number in order. This is
-largely done automatically for you. However, its often very useful to
+largely done automatically for you. However, it's often very useful to
assign a name to each test. Which would you rather see:
ok 4
to find the test in your script, simply search for "simple
exponential".
-All test functions take a name argument. Its optional, but highly
+All test functions take a name argument. It's optional, but highly
suggested that you use it.
=cut
-# We get ok() from Test::Simple's import().
+sub ok ($;$) {
+ my($test, $name) = @_;
+ $Test->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 (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 ($$;$) {
- my($this, $that, $name) = @_;
-
- my $test;
- {
- local $^W = 0; # so is(undef, undef) works quietly.
- $test = $this eq $that;
- }
- my $ok = @_ == 3 ? ok($test, $name)
- : ok($test);
-
- unless( $ok ) {
- $this = defined $this ? "'$this'" : 'undef';
- $that = defined $that ? "'$that'" : 'undef';
- my_print *TESTERR, sprintf <<DIAGNOSTIC, $this, $that;
-# got: %s
-# expected: %s
-DIAGNOSTIC
-
- }
-
- return $ok;
+ $Test->is_eq(@_);
}
sub isnt ($$;$) {
- my($this, $that, $name) = @_;
-
- my $test;
- {
- local $^W = 0; # so isnt(undef, undef) works quietly.
- $test = $this ne $that;
- }
-
- my $ok = @_ == 3 ? ok($test, $name)
- : ok($test);
-
- unless( $ok ) {
- $that = defined $that ? "'$that'" : 'undef';
-
- my_print *TESTERR, sprintf <<DIAGNOSTIC, $that;
-# it should not be %s
-# but it is.
-DIAGNOSTIC
-
- }
-
- return $ok;
+ $Test->isnt_eq(@_);
}
*isn't = \&isnt;
(Mnemonic "This is like that".)
The second argument is a regular expression. It may be given as a
-regex reference (ie. C<qr//>) or (for better compatibility with older
+regex reference (i.e. C<qr//>) or (for better compatibility with older
perls) as a string that looks like a regex (alternative delimiters are
currently not supported):
=cut
sub like ($$;$) {
- my($this, $regex, $name) = @_;
+ $Test->like(@_);
+}
- my $ok = 0;
- if( ref $regex eq 'Regexp' ) {
- local $^W = 0;
- $ok = @_ == 3 ? ok( $this =~ $regex ? 1 : 0, $name )
- : ok( $this =~ $regex ? 1 : 0 );
- }
- # Check if it looks like '/foo/i'
- elsif( my($re, $opts) = $regex =~ m{^ /(.*)/ (\w*) $ }sx ) {
- local $^W = 0;
- $ok = @_ == 3 ? ok( $this =~ /(?$opts)$re/ ? 1 : 0, $name )
- : ok( $this =~ /(?$opts)$re/ ? 1 : 0 );
- }
- else {
- # Can't use fail() here, the call stack will be fucked.
- my $ok = @_ == 3 ? ok(0, $name )
- : ok(0);
- my_print *TESTERR, <<ERR;
-# '$regex' doesn't look much like a regex to me. Failing the test.
-ERR
+=item B<unlike>
- return $ok;
- }
+ unlike( $this, qr/that/, $test_name );
- unless( $ok ) {
- $this = defined $this ? "'$this'" : 'undef';
- my_print *TESTERR, sprintf <<DIAGNOSTIC, $this;
-# %s
-# doesn't match '$regex'
-DIAGNOSTIC
+Works exactly as like(), only it checks if $this B<does not> match the
+given pattern.
- }
+=cut
- return $ok;
+sub unlike ($$;$) {
+ $Test->unlike(@_);
+}
+
+
+=item B<cmp_ok>
+
+ cmp_ok( $this, $op, $that, $test_name );
+
+Halfway between ok() and is() lies cmp_ok(). This allows you to
+compare two arguments using any binary perl operator.
+
+ # ok( $this eq $that );
+ cmp_ok( $this, 'eq', $that, 'this eq that' );
+
+ # ok( $this == $that );
+ cmp_ok( $this, '==', $that, 'this == that' );
+
+ # ok( $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)
+ # '23'
+ # &&
+ # undef
+
+It's also useful in those cases where you are comparing numbers and
+is()'s use of C<eq> will interfere:
+
+ cmp_ok( $big_hairy_number, '==', $another_big_hairy_number );
+
+=cut
+
+sub cmp_ok($$$;$) {
+ $Test->cmp_ok(@_);
}
+
=item B<can_ok>
can_ok($module, @methods);
only without all the typing and with a better interface. Handy for
quickly testing an interface.
+No matter how many @methods you check, a single can_ok() call counts
+as one test. If you desire otherwise, use:
+
+ foreach my $meth (@methods) {
+ can_ok('Foo', $meth);
+ }
+
=cut
sub can_ok ($@) {
my($proto, @methods) = @_;
- my $class= ref $proto || $proto;
+ my $class = ref $proto || $proto;
+
+ unless( @methods ) {
+ my $ok = $Test->ok( 0, "$class->can(...)" );
+ $Test->diag(' can_ok() called with no methods');
+ return $ok;
+ }
my @nok = ();
foreach my $method (@methods) {
- my $test = "$class->can('$method')";
- eval $test || push @nok, $method;
+ local($!, $@); # don't interfere with caller's $@
+ # eval sometimes resets $!
+ eval { $proto->can($method) } || push @nok, $method;
}
my $name;
- $name = @methods == 1 ? "$class->can($methods[0])"
+ $name = @methods == 1 ? "$class->can('$methods[0]')"
: "$class->can(...)";
- ok( !@nok, $name );
+ my $ok = $Test->ok( !@nok, $name );
- my_print *TESTERR, map "# $class->can('$_') failed\n", @nok;
+ $Test->diag(map " $class->can('$_') failed\n", @nok);
- return !@nok;
+ return $ok;
}
=item B<isa_ok>
- isa_ok($object, $class);
+ 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:
to safeguard against your test script blowing up.
+It works on references, too:
+
+ isa_ok( $array_ref, 'ARRAY' );
+
+The diagnostics of this test normally just refer to 'the object'. If
+you'd like them to be more specific, you can supply an $object_name
+(for example 'Test customer').
+
=cut
-sub isa_ok ($$) {
- my($object, $class) = @_;
+sub isa_ok ($$;$) {
+ my($object, $class, $obj_name) = @_;
my $diag;
- my $name = "object->isa('$class')";
+ $obj_name = 'The object' unless defined $obj_name;
+ my $name = "$obj_name isa $class";
if( !defined $object ) {
- $diag = "The object isn't defined";
+ $diag = "$obj_name isn't defined";
}
elsif( !ref $object ) {
- $diag = "The object isn't a reference";
+ $diag = "$obj_name isn't a reference";
}
- elsif( !$object->isa($class) ) {
- $diag = "The object isn't a '$class'";
+ else {
+ # We can't use UNIVERSAL::isa because we want to honor isa() overrides
+ local($@, $!); # eval sometimes resets $!
+ my $rslt = eval { $object->isa($class) };
+ if( $@ ) {
+ if( $@ =~ /^Can't call method "isa" on unblessed reference/ ) {
+ if( !UNIVERSAL::isa($object, $class) ) {
+ my $ref = ref $object;
+ $diag = "$obj_name isn't a '$class' it's a '$ref'";
+ }
+ } else {
+ die <<WHOA;
+WHOA! I tried to call ->isa on your object and got some weird error.
+This should never happen. Please contact the author immediately.
+Here's the error.
+$@
+WHOA
+ }
+ }
+ elsif( !$rslt ) {
+ my $ref = ref $object;
+ $diag = "$obj_name isn't a '$class' it's a '$ref'";
+ }
}
+
+
+ my $ok;
if( $diag ) {
- ok( 0, $name );
- my_print *TESTERR, "# $diag\n";
- return 0;
+ $ok = $Test->ok( 0, $name );
+ $Test->diag(" $diag\n");
}
else {
- ok( 1, $name );
- return 1;
+ $ok = $Test->ok( 1, $name );
}
+
+ return $ok;
}
=cut
sub pass (;$) {
- my($name) = @_;
- return @_ == 1 ? ok(1, $name)
- : ok(1);
+ $Test->ok(1, @_);
}
sub fail (;$) {
- my($name) = @_;
- return @_ == 1 ? ok(0, $name)
- : ok(0);
+ $Test->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. Like C<print> @diagnostic_message is simply concatinated
+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 (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()>.
+
+All diag()s can be made silent by passing the "no_diag" option to
+Test::More. C<use Test::More tests => 1, 'no_diag'>. This is useful
+if you have diagnostics for personal testing but then wish to make
+them silent for release without commenting out each individual
+statement.
+
+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 {
+ return unless $Show_Diag;
+ $Test->diag(@_);
+}
+
+
+=back
+
=head2 Module tests
You usually want to test if the module you're testing loads ok, rather
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
my($module, @imports) = @_;
@imports = () unless @imports;
- my $pack = caller;
+ my($pack,$filename,$line) = caller;
- eval <<USE;
+ local($@,$!); # eval sometimes interferes with $!
+
+ 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 = ok( !$@, "use $module;" );
+ my $ok = $Test->ok( !$@, "use $module;" );
unless( $ok ) {
- my_print *TESTERR, <<DIAGNOSTIC;
-# Tried to use '$module'.
-# Error: $@
+ chomp $@;
+ $@ =~ s{^BEGIN failed--compilation aborted at .*$}
+ {BEGIN failed--compilation aborted at $filename line $line.}m;
+ $Test->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
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 = ok( !$@, "require $module;" );
+ my $ok = $Test->ok( !$@, "require $module;" );
unless( $ok ) {
- my_print *TESTERR, <<DIAGNOSTIC;
-# Tried to require '$module'.
-# Error: $@
+ chomp $@;
+ $Test->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 Conditional tests
-B<WARNING!> The following describes an I<experimental> interface that
-is subject to change B<WITHOUT NOTICE>! Use at your peril.
-
Sometimes running a test under certain conditions will cause the
test script to die. A certain function or method isn't implemented
(such as fork() on MacOS), some resource isn't available (like a
necessary to skip tests, or declare that they are supposed to fail
but will work in the future (a todo test).
-For more details on skip and todo tests see L<Test::Harness>.
+For more details on the mechanics of skip and todo tests see
+L<Test::Harness>.
The way Test::More handles this is with a named block. Basically, a
block of tests which can be skipped over or made todo. It's best if I
...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 };
+
+ skip "HTML::Lint not installed", 2 if $@;
- my $pig = Pigs->new;
- $pig->takeoff;
+ my $lint = new HTML::Lint;
+ isa_ok( $lint, "HTML::Lint" );
- ok( $pig->altitude > 0, 'Pig is airborne' );
- ok( $pig->airspeed > 0, ' and moving' );
+ $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>).
+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.
-You'll typically use this when a feature is missing, 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 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.
-=for _Future
-See L</Why are skip and todo so weird?>
+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, or for which you don't yet have code written. For that you
+use TODO. Read on.
=cut
#'#
sub skip {
my($why, $how_many) = @_;
- unless( $how_many >= 1 ) {
+
+ 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"
- if $Test::Simple::Planned_Tests;
+ _carp "skip() needs to know \$how_many tests are in the block"
+ unless $Test->has_plan eq 'no_plan';
$how_many = 1;
}
for( 1..$how_many ) {
- Test::Simple::_skipped($why);
+ $Test->skip($why);
}
local $^W = 0;
=item B<TODO: BLOCK>
TODO: {
- local $TODO = $why;
+ local $TODO = $why if $condition;
...normal testing code goes here...
}
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 programatic todo list. You know
+block of tests, is it's like having a programmatic todo list. You know
how much work is left to be done, you're aware of what bugs there are,
and you'll know immediately when they're fixed.
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<BUGS and CAVEATS>)
+
+
+=item B<todo_skip>
+
+ TODO: {
+ todo_skip $why, $how_many if $condition;
+
+ ...normal testing code...
+ }
+
+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
+cases you have no choice but to skip over the broken tests entirely.
+
+The syntax and behavior is similar to a C<SKIP: BLOCK> except the
+tests will be marked as failing but todo. Test::Harness will
+interpret them as passing.
+
+=cut
+
+sub todo_skip {
+ my($why, $how_many) = @_;
+
+ 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->has_plan eq 'no_plan';
+ $how_many = 1;
+ }
+
+ for( 1..$how_many ) {
+ $Test->todo_skip($why);
+ }
+
+ local $^W = 0;
+ last TODO;
+}
+
+=item When do I use SKIP vs. TODO?
+
+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.
+
+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).
+
=back
-=head2 Comparision functions
+=head2 Comparison functions
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.
+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 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.
+
+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 {
+ 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 @_;
+ }
+
+ 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 ) {
+ $ok = $Test->is_eq($this, $that, $name);
+ }
+ else {
+ 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));
+ }
+ }
+
+ 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"
+ : "'$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 Regexp)) {
+ return $type if UNIVERSAL::isa($thing, $type);
+ }
+
+ return '';
+}
+
+
=item B<eq_array>
eq_array(\@this, \@that);
=cut
#'#
-sub eq_array {
+sub eq_array {
+ local @Data_Stack;
+ local %Refs_Seen;
+ _eq_array(@_);
+}
+
+sub _eq_array {
my($a1, $a2) = @_;
- return 0 unless @$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;
+ if($Refs_Seen{$a1}) {
+ return $Refs_Seen{$a1} eq $a2;
+ }
+ else {
+ $Refs_Seen{$a1} = "$a2";
+ }
+
my $ok = 1;
- for (0..$#{$a1}) {
- my($e1,$e2) = ($a1->[$_], $a2->[$_]);
+ my $max = $#$a1 > $#$a2 ? $#$a1 : $#$a2;
+ for (0..$max) {
+ my $e1 = $_ > $#$a1 ? $DNE : $a1->[$_];
+ my $e2 = $_ > $#$a2 ? $DNE : $a2->[$_];
+
+ push @Data_Stack, { type => 'ARRAY', idx => $_, vals => [$e1, $e2] };
$ok = _deep_check($e1,$e2);
+ pop @Data_Stack if $ok;
+
last unless $ok;
}
+
return $ok;
}
my($e1, $e2) = @_;
my $ok = 0;
- my $eq;
{
- # Quiet unintialized value warnings when comparing undefs.
+ # Quiet uninitialized value warnings when comparing undefs.
local $^W = 0;
- if( $e1 eq $e2 ) {
+ $Test->_unoverload(\$e1, \$e2);
+
+ # Either they're both references or both not.
+ my $same_ref = !(!ref $e1 xor !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;
}
else {
- if( UNIVERSAL::isa($e1, 'ARRAY') and
- UNIVERSAL::isa($e2, 'ARRAY') )
- {
- $ok = eq_array($e1, $e2);
+ my $type = _type($e1);
+ $type = '' unless _type($e2) eq $type;
+
+ if( !$type ) {
+ push @Data_Stack, { vals => [$e1, $e2] };
+ $ok = 0;
}
- elsif( UNIVERSAL::isa($e1, 'HASH') and
- UNIVERSAL::isa($e2, 'HASH') )
- {
- $ok = eq_hash($e1, $e2);
+ elsif( $type eq 'ARRAY' ) {
+ $ok = _eq_array($e1, $e2);
}
- else {
- $ok = 0;
+ elsif( $type eq 'HASH' ) {
+ $ok = _eq_hash($e1, $e2);
+ }
+ elsif( $type eq 'REF' ) {
+ push @Data_Stack, { type => 'REF', vals => [$e1, $e2] };
+ $ok = _deep_check($$e1, $$e2);
+ pop @Data_Stack if $ok;
+ }
+ elsif( $type eq 'SCALAR' ) {
+ push @Data_Stack, { type => 'REF', vals => [$e1, $e2] };
+ $ok = _deep_check($$e1, $$e2);
+ pop @Data_Stack if $ok;
}
}
}
=cut
sub eq_hash {
+ local @Data_Stack;
+ local %Refs_Seen;
+ return _eq_hash(@_);
+}
+
+sub _eq_hash {
my($a1, $a2) = @_;
- return 0 unless keys %$a1 == keys %$a2;
+
+ if( grep !_type($_) eq 'HASH', $a1, $a2 ) {
+ warn "eq_hash passed a non-hash ref";
+ return 0;
+ }
+
return 1 if $a1 eq $a2;
+ if( $Refs_Seen{$a1} ) {
+ return $Refs_Seen{$a1} eq $a2;
+ }
+ else {
+ $Refs_Seen{$a1} = "$a2";
+ }
+
my $ok = 1;
- foreach my $k (keys %$a1) {
- my($e1, $e2) = ($a1->{$k}, $a2->{$k});
+ my $bigger = keys %$a1 > keys %$a2 ? $a1 : $a2;
+ foreach my $k (keys %$bigger) {
+ my $e1 = exists $a1->{$k} ? $a1->{$k} : $DNE;
+ my $e2 = exists $a2->{$k} ? $a2->{$k} : $DNE;
+
+ push @Data_Stack, { type => 'HASH', idx => $k, vals => [$e1, $e2] };
$ok = _deep_check($e1, $e2);
+ pop @Data_Stack if $ok;
+
last unless $ok;
}
important. This is a deep check, but the irrelevancy of order only
applies to the top level.
-=cut
+B<NOTE> By historical accident, this is not a true set comparision.
+While the order of elements does not matter, duplicate elements do.
-# 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 }
+=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;
+
+ # 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.
+ # Have to inline the sort routine due to a threading/sort bug.
+ # See [rt.cpan.org 6782]
+ return eq_array(
+ [sort { ref $a ? -1 : ref $b ? 1 : $a cmp $b } @$a1],
+ [sort { ref $a ? -1 : ref $b ? 1 : $a cmp $b } @$a2]
+ );
}
+=back
+
+
+=head2 Extending and Embedding Test::More
+
+Sometimes the Test::More interface isn't quite enough. Fortunately,
+Test::More is built on top of Test::Builder which provides a single,
+unified backend for any test library to use. This means two test
+libraries which both use Test::Builder B<can be used together in the
+same program>.
+
+If you simply want to do a little tweaking of how the tests behave,
+you can access the underlying Test::Builder object like so:
+
+=over 4
+
+=item B<builder>
+
+ my $test_builder = Test::More->builder;
+
+Returns the Test::Builder object underlying Test::More for you to play
+with.
+
+=cut
+
+sub builder {
+ return Test::Builder->new;
+}
=back
-=head1 NOTES
-Test::More is B<explicitly> tested all the way back to perl 5.004.
+=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
+ any other number how many failed (including missing or extras)
+
+If you fail more than 254 tests, it will be reported as 254.
-=head1 BUGS and CAVEATS
+
+=head1 CAVEATS and NOTES
=over 4
-=item Making your own ok()
+=item Backwards compatibility
-This will not do what you mean:
+Test::More works with Perls as old as 5.004_05.
- sub my_ok {
- ok( @_ );
- }
- my_ok( 2 + 2 == 5, 'Basic addition' );
+=item Overloaded objects
-since ok() takes it's arguments as scalars, it will see the length of
-@_ (2) and always pass the test. You want to do this instead:
+String overloaded objects are compared B<as strings>. 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.
- sub my_ok {
- ok( $_[0], $_[1] );
- }
+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.
-The other functions act similiarly.
-=item The eq_* family have some caveats.
+=item Threads
-=item Test::Harness upgrades
+Test::More will only be aware of threads if "use threads" has been done
+I<before> Test::More is loaded. This is ok:
-no_plan and todo depend on new Test::Harness features and fixes. If
-you're going to distribute tests that use no_plan your end-users will
-have to upgrade Test::Harness to the latest one on CPAN.
+ use threads;
+ use Test::More;
-If you simply depend on Test::More, it's own dependencies will cause a
-Test::Harness upgrade.
+This may cause problems:
-=back
+ use Test::More
+ use threads;
-=head1 AUTHOR
-Michael G Schwern E<lt>schwern@pobox.comE<gt> with much inspiration from
-Joshua Pritikin's Test module and lots of discussion with Barrie
-Slaymaker and the perl-qa gang.
+=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
+end-users will have to upgrade Test::Harness to the latest one on
+CPAN. If you avoid no_plan and TODO tests, the stock Test::Harness
+will work fine.
+
+Installing Test::More should also upgrade Test::Harness.
+
+=back
=head1 HISTORY
This is a case of convergent evolution with Joshua Pritikin's Test
-module. I was largely unware of its existence when I'd first
+module. I was largely unaware of its existence when I'd first
written my own ok() routines. This module exists because I can't
figure out how to easily wedge test names into Test's interface (along
with a few other problems).
=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> for a similar testing module.
+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<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, 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, 2002, 2004 by Michael G Schwern E<lt>schwern@pobox.comE<gt>.
-L<Pod::Tests> shows the idea of embedded testing.
+This program is free software; you can redistribute it and/or
+modify it under the same terms as Perl itself.
-L<SelfTest> is another approach to embedded testing.
+See F<http://www.perl.com/perl/misc/Artistic.html>
=cut
projects / p5sagit/p5-mst-13.2.git / blobdiff