X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FTest%2FMore.pm;h=be7e9fcf05d0cc67a997211e52561d7ca3e57d13;hb=0295a53a2a0d7b08c078ea9d195ec919c7df2a35;hp=aa7032dfb22d5bc8be9c3bd4aa11d20e72f3f103;hpb=d020a79abca8a7921ca8873afa967fc2b6628b7d;p=p5sagit%2Fp5-mst-13.2.git diff --git a/lib/Test/More.pm b/lib/Test/More.pm index aa7032d..be7e9fc 100644 --- a/lib/Test/More.pm +++ b/lib/Test/More.pm @@ -3,66 +3,38 @@ package Test::More; use 5.004; use strict; -use Carp; -use Test::Utils; -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'; -@ISA = qw(Exporter); + + +use vars qw($VERSION @ISA @EXPORT %EXPORT_TAGS $TODO); +$VERSION = '0.63'; +$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 - 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 + BAIL_OUT ); -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 - my $callpkg = caller($level); - $pkg->export($callpkg, @_); -} - - =head1 NAME Test::More - yet another framework for writing test scripts @@ -83,7 +55,16 @@ Test::More - yet another framework for writing test scripts 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; @@ -105,27 +86,23 @@ Test::More - yet another framework for writing test scripts pass($test_name); fail($test_name); - # Utility comparison functions. - eq_array(\@this, \@that); - eq_hash(\%this, \%that); - eq_set(\@this, \@that); + BAIL_OUT($why); # UNIMPLEMENTED!!! my @status = Test::More::status; - # UNIMPLEMENTED!!! - BAIL_OUT($why); - =head1 DESCRIPTION -If you're just getting started writing tests, have a look at +B 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 function, it doesn't provide good diagnostic output. =head2 I love it when a plan comes together @@ -134,7 +111,7 @@ Before anything else, you need a testing plan. This basically declares 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. +The preferred way to do this is to declare a plan when you C. use Test::More tests => $Num_Tests; @@ -144,6 +121,9 @@ have no plan. (Try to avoid using this as it weakens your test.) use Test::More qw(no_plan); +B: using no_plan requires a Test::Harness upgrade else it will +think everything has failed. See L). + In some cases, you'll want to completely skip an entire testing script. use Test::More skip_all => $skip_reason; @@ -152,11 +132,66 @@ Your script will declare a skip with the reason why you skipped and exit immediately with a zero (success). See L 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 $tb = Test::More->builder; + + $tb->plan(@_); +} + + +# This implements "use Test::More 'no_diag'" but the behavior is +# deprecated. +sub import_extra { + my $class = shift; + my $list = shift; + + my @other = (); + my $idx = 0; + while( $idx <= $#{$list} ) { + my $item = $list->[$idx]; + + if( defined $item and $item eq 'no_diag' ) { + $class->builder->no_diag(1); + } + else { + push @other, $item; + } + + $idx++; + } + + @$list = @other; +} + =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 @@ -173,7 +208,7 @@ The later gives you some idea of what failed. It also makes it easier 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. @@ -214,13 +249,19 @@ but we B strongly encourage its use. 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. =cut -# We get ok() from Test::Simple's import(). +sub ok ($;$) { + my($test, $name) = @_; + my $tb = Test::More->builder; + + $tb->ok($test, $name); +} =item B @@ -257,7 +298,8 @@ test: 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' @@ -267,14 +309,14 @@ You are encouraged to use is() and isnt() over ok() where possible, 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 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 function which is an alias of isnt(). @@ -282,52 +324,15 @@ 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); + my $tb = Test::More->builder; - unless( $ok ) { - $this = defined $this ? "'$this'" : 'undef'; - $that = defined $that ? "'$that'" : 'undef'; - my_print *TESTERR, sprintf <is_eq(@_); } sub isnt ($$;$) { - my($this, $that, $name) = @_; + my $tb = Test::More->builder; - 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 <isnt_eq(@_); } *isn't = \&isnt; @@ -350,7 +355,7 @@ is similar to: (Mnemonic "This is like that".) The second argument is a regular expression. It may be given as a -regex reference (ie. C) or (for better compatibility with older +regex reference (i.e. C) or (for better compatibility with older perls) as a string that looks like a regex (alternative delimiters are currently not supported): @@ -364,44 +369,68 @@ diagnostics on failure. =cut sub like ($$;$) { - my($this, $regex, $name) = @_; + my $tb = Test::More->builder; - 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); + $tb->like(@_); +} - my_print *TESTERR, < - unless( $ok ) { - $this = defined $this ? "'$this'" : 'undef'; - my_print *TESTERR, sprintf < match the +given pattern. - return $ok; +=cut + +sub unlike ($$;$) { + my $tb = Test::More->builder; + + $tb->unlike(@_); +} + + +=item B + + 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 in 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 will interfere: + + cmp_ok( $big_hairy_number, '==', $another_big_hairy_number ); + +=cut + +sub cmp_ok($$$;$) { + my $tb = Test::More->builder; + + $tb->cmp_ok(@_); } + =item B can_ok($module, @methods); @@ -422,34 +451,56 @@ is almost exactly like saying: 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; + my $tb = Test::More->builder; + + unless( $class ) { + my $ok = $tb->ok( 0, "->can(...)" ); + $tb->diag(' can_ok() called with empty class or reference'); + return $ok; + } + + unless( @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')"; - 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 = $tb->ok( !@nok, $name ); - my_print *TESTERR, map "# $class->can('$_') failed\n", @nok; + $tb->diag(map " $class->can('$_') failed\n", @nok); - return !@nok; + return $ok; } =item B - 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: @@ -463,32 +514,66 @@ where you'd otherwise have to write 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 $tb = Test::More->builder; 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 <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 = $tb->ok( 0, $name ); + $tb->diag(" $diag\n"); } else { - ok( 1, $name ); - return 1; + $ok = $tb->ok( 1, $name ); } + + return $ok; } @@ -510,19 +595,18 @@ Use these very, very, very sparingly. =cut sub pass (;$) { - my($name) = @_; - return @_ == 1 ? ok(1, $name) - : ok(1); + my $tb = Test::More->builder; + $tb->ok(1, @_); } sub fail (;$) { - my($name) = @_; - return @_ == 1 ? ok(0, $name) - : ok(0); + my $tb = Test::More->builder; + $tb->ok(0, @_); } =back + =head2 Module tests You usually want to test if the module you're testing loads ok, rather @@ -537,7 +621,7 @@ C and C. 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. @@ -549,27 +633,61 @@ is like doing this: 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 <import(\@imports); +use $module $imports[0]; +USE + } + else { + eval <ok( !$@, "use $module;" ); unless( $ok ) { - my_print *TESTERR, <diag(< 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 <ok( !$@, "require $module;" ); unless( $ok ) { - my_print *TESTERR, <diag(< The following describes an I interface that -is subject to change B! Use at your peril. +=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 I'm not quite sure what will happen with filehandles. + +=over 4 + +=item B + + 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 = <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. + +=over 4 + +=item B + + diag(@diagnostic_message); + +Prints a diagnostic message which is guaranteed not to interfere with +test output. Like C @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 with the mnemonic C. + +B 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 test script to die. A certain function or method isn't implemented @@ -622,7 +939,8 @@ net connection) or a module isn't available. In these cases it's 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. +For more details on the mechanics of skip and todo tests see +L. 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 @@ -638,48 +956,53 @@ just show you... ...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). +If the user does not have HTML::Lint installed, the whole block of +code I. Test::More will output special ok's +which Test::Harness interprets as skipped, but passing, tests. + +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 $how_many is optional and will default to 1. -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 perfectly safe to nest SKIP blocks. Each SKIP block must have +the label C, or Test::More can't work its magic. -=for _Future -See L +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 ) { + 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" - if $Test::Simple::Planned_Tests; + _carp "skip() needs to know \$how_many tests are in the block" + unless $tb->has_plan eq 'no_plan'; $how_many = 1; } for( 1..$how_many ) { - Test::Simple::_skipped($why); + $tb->skip($why); } local $^W = 0; @@ -690,7 +1013,7 @@ sub skip { =item B TODO: { - local $TODO = $why; + local $TODO = $why if $condition; ...normal testing code goes here... } @@ -713,32 +1036,127 @@ With a todo block, the tests inside are expected to fail. Test::More 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: TODO tests require a Test::Harness upgrade else it will +treat it as a normal failure. See L). + + +=item B + + 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 with and using C. 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 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) = @_; + 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 $tb->has_plan eq 'no_plan'; + $how_many = 1; + } + + for( 1..$how_many ) { + $tb->todo_skip($why); + } + + local $^W = 0; + last TODO; +} + +=item When do I use SKIP vs. TODO? + +B, 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, 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 -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. +=head2 Test control + +=over 4 + +=item B + + BAIL_OUT($reason); + +Indicates to the harness that things are going so badly all testing +should terminate. This includes the running any additional test scripts. + +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. + +The test will exit with 255. + +=cut + +sub BAIL_OUT { + my $reason = shift; + my $tb = Test::More->builder; + + $tb->BAIL_OUT($reason); +} + +=back + + +=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) ); -B These are NOT well-tested on circular references. Nor am I -quite sure what will happen with filehandles. +C can do that better and with diagnostics. + + is_deeply( \@this, \@that ); + +They may be deprecated in future versions. =over 4 =item B - eq_array(\@this, \@that); + my $is_eq = eq_array(\@this, \@that); Checks if two arrays are equivalent. This is a deep check, so multi-level structures are handled correctly. @@ -746,46 +1164,109 @@ multi-level structures are handled correctly. =cut #'# -sub eq_array { +sub eq_array { + local @Data_Stack; + _deep_check(@_); +} + +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; 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; } 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 unintialized value warnings when comparing undefs. + # 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); - } - elsif( UNIVERSAL::isa($e1, 'HASH') and - UNIVERSAL::isa($e2, 'HASH') ) - { - $ok = eq_hash($e1, $e2); + if( $Refs_Seen{$e1} ) { + return $Refs_Seen{$e1} eq $e2; } else { + $Refs_Seen{$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( $type eq 'SCALAR' ) { + push @Data_Stack, { type => 'REF', vals => [$e1, $e2] }; + $ok = _deep_check($$e1, $$e2); + pop @Data_Stack if $ok; + } + elsif( $type ) { + push @Data_Stack, { type => $type, vals => [$e1, $e2] }; + $ok = 0; + } + else { + _whoa(1, "No type in _deep_check"); + } } } @@ -793,9 +1274,20 @@ sub _deep_check { } +sub _whoa { + my($check, $desc) = @_; + if( $check ) { + die < - eq_hash(\%this, \%that); + my $is_eq = eq_hash(\%this, \%that); Determines if the two hashes contain the same keys and values. This is a deep check. @@ -803,14 +1295,30 @@ is a deep check. =cut sub eq_hash { + local @Data_Stack; + return _deep_check(@_); +} + +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; 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; } @@ -819,81 +1327,157 @@ sub eq_hash { =item B - eq_set(\@this, \@that); + my $is_eq = eq_set(\@this, \@that); Similar to eq_array(), except the order of the elements is B important. This is a deep check, but the irrelevancy of order only applies to the top level. -=cut + ok( eq_set(\@this, \@that) ); + +Is better written: + + is_deeply( [sort @this], [sort @that] ); + +B By historical accident, this is not a true set comparison. +While the order of elements does not matter, duplicate elements do. + +B 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: -# 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 } + 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 + + +=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. + +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 + + my $test_builder = Test::More->builder; + +Returns the Test::Builder object underlying Test::More for you to play +with. + =back -=head1 NOTES -Test::More is B 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... -=head1 BUGS and CAVEATS + 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 This behavior may go away in future versions. + + +=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 (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. - 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 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 Eschwern@pobox.comE 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). @@ -908,19 +1492,50 @@ magic side-effects are kept to a minimum. WYSIWYG. =head1 SEE ALSO L 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 for a similar testing module. +L is the old testing module. Its main benefit is that it has +been distributed with Perl since 5.004_05. L for details on how your test results are interpreted by Perl. -L describes a very featureful unit testing interface. +L for more ways to test complex data structures. +And it plays well with Test::More. + +L is like XUnit but more perlish. + +L gives you more powerful complex data structure testing. + +L is XUnit style testing. + +L shows the idea of embedded testing. + +L installs a whole bunch of useful test modules. + + +=head1 AUTHORS + +Michael G Schwern Eschwern@pobox.comE 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 to report and view bugs. + + +=head1 COPYRIGHT + +Copyright 2001, 2002, 2004 by Michael G Schwern Eschwern@pobox.comE. -L 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 is another approach to embedded testing. +See F =cut