Here's a patch to eliminate the EvilSubWrapper from Parrot::Test. This should make Parrot::Test much easier to maintain.
Update to Test::More 0.41 which adds Test::Builder Delete the vestigal Test::Utils Change Parrot::Test so it uses Test::Builder instead of Evil Wrappers around Test::More output_* now returns whether the test passes or fails Parrot::Test no longer exports Test::More's functions. Instead they can simply be used together. The few tests which used Test::More features (ie. skip) have 'use Test::More' added. I ditched the export_to_level() crutch. Do we expect parrot to work on 5.004? (literally 5.004, not 5.004_04) As a side note, most of the skips in the tests should really be todo_skips, but Test::Harness didn't understand Test::More's syntax for todo until very recently. So they stay skips. --- MANIFEST 11 Jan 2002 00:32:56 -0000 1.93 +++ MANIFEST 12 Jan 2002 22:27:12 -0000 @@ -26,9 +26,9 @@ Parrot/Vtable.pm README TODO +Test/Builder.pm Test/More.pm Test/Simple.pm -Test/Utils.pm Types_pm.in VERSION assemble.pl --- Parrot/Test.pm 7 Jan 2002 20:48:52 -0000 1.11 +++ Parrot/Test.pm 12 Jan 2002 22:27:12 -0000 @@ -1,26 +1,3 @@ -# - -package Parrot::Test::EvilSubWrapper; -#This chamber of horrors allows us to goto a subroutine -# and still be able to perform actions afterwards. -# Inspired by something I read about on the Conway -# Channel. --BD 01/07/2002 - -sub new { - my($class, $action, $destruct)=@_; - - bless {action => $action, destruct => $destruct}, $class; -} - -sub subr { - $_[0]->{action} -} - -sub DESTROY { - goto &{$_[0]->{destruct}}; -} - - package Parrot::Test; use strict; @@ -28,17 +5,18 @@ use Parrot::Config; require Exporter; -require Test::More; +require Test::Builder; +my $Builder = Test::Builder->new; -@EXPORT = ( qw(output_is output_like output_isnt), @Test::More::EXPORT ); -@ISA = qw(Exporter Test::More); +@EXPORT = ( qw(output_is output_like output_isnt) ); +@ISA = qw(Exporter); sub import { my( $class, $plan, @args ) = @_; - Test::More->import( $plan, @args ); + Test::Builder->plan( $plan, @args ); - __PACKAGE__->_export_to_level( 2, __PACKAGE__ ); + __PACKAGE__->export_to_level( 2, __PACKAGE__ ); } # this kludge is an hopefully portable way of having @@ -63,10 +41,16 @@ my $count; -foreach my $i ( qw(is isnt like) ) { +# Map the Parrot::Test function to a Test::Builder method. +my %Test_Map = ( output_is => 'is_eq', + output_isnt => 'isnt_eq', + output_like => 'like' + ); + +foreach my $func ( keys %Test_Map ) { no strict 'refs'; - *{"Parrot::Test::output_$i"} = sub ($$;$) { + *{'Parrot::Test::'.$func} = sub ($$;$) { ++$count; my( $assembly, $output, $desc ) = @_; $output =~ s/\cM\cJ/\n/g; @@ -92,22 +76,16 @@ } close OUTPUT; - @_ = ( $prog_output, $output, $desc ); + my $meth = $Test_Map{$func}; + my $pass = $Builder->$meth( $prog_output, $output, $desc ); + + unless($ENV{POSTMORTERM}) { + foreach my $i ( $as_f, $by_f, $out_f ) { + unlink $i; + } + } - my $func=new Parrot::Test::EvilSubWrapper( - \&{"Test::More::$i"}, - sub { - unless($ENV{POSTMORTERM}) { - foreach my $i ( $as_f, $by_f, $out_f ) { - unlink $i; - } - } - } - ); - - goto &{$func->subr}; -# my $ok = &{"Test::More::$i"}( @_ ); -# if($ok) { foreach my $i ( $as_f, $by_f, $out_f ) { unlink $i } } + return $pass; } } --- Test/More.pm 22 Sep 2001 17:20:59 -0000 1.1 +++ Test/More.pm 12 Jan 2002 22:27:12 -0000 @@ -3,61 +3,44 @@ 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.41'; @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; -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, @_); } @@ -83,7 +66,16 @@ 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; @@ -119,13 +111,15 @@ =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 @@ -134,7 +128,7 @@ 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; @@ -152,6 +146,54 @@ 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 $caller = caller; + + $Test->exported_to($caller); + $Test->plan(@plan); + + my @imports = (); + foreach my $idx (0..$#plan) { + if( $plan[$idx] eq 'import' ) { + @imports = @{$plan[$idx+1]}; + last; + } + } + + __PACKAGE__->_export_to_level(1, __PACKAGE__, @imports); +} + +sub import { + my($class) = shift; + goto &plan; +} + =head2 Test names @@ -220,7 +262,10 @@ =cut -# We get ok() from Test::Simple's import(). +sub ok ($;$) { + my($test, $name) = @_; + $Test->ok($test, $name); +} =item B<is> @@ -282,52 +327,11 @@ =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; @@ -350,7 +354,7 @@ (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): @@ -364,44 +368,62 @@ =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 - return $ok; - } +=item B<unlike> - unless( $ok ) { - $this = defined $this ? "'$this'" : 'undef'; - my_print *TESTERR, sprintf <<DIAGNOSTIC, $this; -# %s -# doesn't match '$regex' -DIAGNOSTIC + unlike( $this, qr/that/, $test_name ); - } +Works exactly as like(), only it checks if $this B<does not> match the +given pattern. - return $ok; +=cut + +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 + +Its 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); @@ -422,15 +444,30 @@ 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; + 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')"; + my $test = "'$class'->can('$method')"; + local($!, $@); # don't interfere with caller's $@ + # eval sometimes resets $! eval $test || push @nok, $method; } @@ -438,16 +475,17 @@ $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 sure the object was defined in the first place. Handy for this sort @@ -463,32 +501,65 @@ 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' its 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' its 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; } @@ -510,17 +581,54 @@ =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. 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 @@ -558,18 +666,20 @@ my $pack = caller; + local($@,$!); # eval sometimes interferes with $! eval <<USE; package $pack; require $module; $module->import(\@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 $@; + $Test->diag(<<DIAGNOSTIC); + Tried to use '$module'. + Error: $@ DIAGNOSTIC } @@ -590,17 +700,19 @@ my $pack = caller; + 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 } @@ -612,9 +724,6 @@ =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 @@ -622,7 +731,8 @@ 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 @@ -656,12 +766,19 @@ 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>). +you're using C<no_plan>, in which case you can leave $how_many off if +you like). + +Its perfectly safe to nest SKIP blocks. + +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. + +You don't skip tests which are failing because there's a bug in your +program. For that you use TODO. Read on. -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. =for _Future See L</Why are skip and todo so weird?> @@ -671,15 +788,16 @@ #'# 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::Builder::No_Plan; $how_many = 1; } for( 1..$how_many ) { - Test::Simple::_skipped($why); + $Test->skip($why); } local $^W = 0; @@ -690,7 +808,7 @@ =item B<TODO: BLOCK> TODO: { - local $TODO = $why; + local $TODO = $why if $condition; ...normal testing code goes here... } @@ -715,7 +833,7 @@ Should anything succeed, it will report it as an unexpected success. 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. @@ -723,9 +841,48 @@ When the block is empty, delete it. +=item B<todo_skip> + + TODO: { + todo_skip $why, $how_many if $condition; + + ...normal testing code... + } + +With todo tests, its 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::Builder::No_Plan; + $how_many = 1; + } + + for( 1..$how_many ) { + $Test->todo_skip($why); + } + + local $^W = 0; + last TODO; +} + + =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 @@ -736,6 +893,87 @@ =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. + +Barrie Slaymaker's Test::Differences module provides more in-depth +functionality along these lines, and it plays well with Test::More. + +B<NOTE> Display of scalar refs is not quite 100% + +=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)); + } + } + + 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; +} + + =item B<eq_array> eq_array(\@this, \@that); @@ -748,13 +986,18 @@ #'# sub eq_array { my($a1, $a2) = @_; - return 0 unless @$a1 == @$a2; 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; @@ -766,7 +1009,7 @@ my $eq; { - # Quiet unintialized value warnings when comparing undefs. + # Quiet uninitialized value warnings when comparing undefs. local $^W = 0; if( $e1 eq $e2 ) { @@ -783,7 +1026,21 @@ { $ok = eq_hash($e1, $e2); } + elsif( UNIVERSAL::isa($e1, 'REF') and + UNIVERSAL::isa($e2, 'REF') ) + { + push @Data_Stack, { type => 'REF', vals => [$e1, $e2] }; + $ok = _deep_check($$e1, $$e2); + pop @Data_Stack if $ok; + } + elsif( UNIVERSAL::isa($e1, 'SCALAR') and + UNIVERSAL::isa($e2, 'SCALAR') ) + { + push @Data_Stack, { type => 'REF', vals => [$e1, $e2] }; + $ok = _deep_check($$e1, $$e2); + } else { + push @Data_Stack, { vals => [$e1, $e2] }; $ok = 0; } } @@ -804,13 +1061,18 @@ sub eq_hash { my($a1, $a2) = @_; - return 0 unless keys %$a1 == keys %$a2; 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; } @@ -840,60 +1102,71 @@ return eq_array( [sort _bogus_sort @$a1], [sort _bogus_sort @$a2] ); } - =back -=head1 NOTES -Test::More is B<explicitly> tested all the way back to perl 5.004. +=head2 Extending and Embedding Test::More -=head1 BUGS and CAVEATS +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 Making your own ok() +=item B<builder> -This will not do what you mean: + my $test_builder = Test::More->builder; - sub my_ok { - ok( @_ ); - } +Returns the Test::Builder object underlying Test::More for you to play +with. - my_ok( 2 + 2 == 5, 'Basic addition' ); +=cut -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: +sub builder { + return Test::Builder->new; +} - sub my_ok { - ok( $_[0], $_[1] ); - } +=back + + +=head1 NOTES + +Test::More is B<explicitly> tested all the way back to perl 5.004. + +=head1 BUGS and CAVEATS + +=over 4 + +=item Making your own ok() -The other functions act similiarly. +If you are trying to extend Test::More, don't. Use Test::Builder +instead. -=item The eq_* family have some caveats. +=item The eq_* family has some caveats. =item Test::Harness upgrades 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. +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. If you simply depend on Test::More, it's own dependencies will cause a Test::Harness upgrade. =back -=head1 AUTHOR - -Michael G Schwern E<lt>[EMAIL PROTECTED]<gt> with much inspiration from -Joshua Pritikin's Test module and lots of discussion with Barrie -Slaymaker and the perl-qa gang. - =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). @@ -911,16 +1184,37 @@ some tests. You can upgrade to Test::More later (its forward compatible). -L<Test> for a similar testing module. +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<Pod::Tests> shows the idea of embedded testing. +L<Test::Inline> shows the idea of embedded testing. L<SelfTest> is another approach to embedded testing. + + +=head1 AUTHORS + +Michael G Schwern E<lt>[EMAIL PROTECTED]<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. + + +=head1 COPYRIGHT + +Copyright 2001 by Michael G Schwern E<lt>[EMAIL PROTECTED]<gt>. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F<http://www.perl.com/perl/misc/Artistic.html> =cut --- Test/Simple.pm 22 Sep 2001 17:20:59 -0000 1.1 +++ Test/Simple.pm 12 Jan 2002 22:27:12 -0000 @@ -3,85 +3,23 @@ use 5.004; use strict 'vars'; -use Test::Utils; - use vars qw($VERSION); +$VERSION = '0.41'; -$VERSION = '0.18'; - -my(@Test_Results) = (); -my($Num_Tests, $Planned_Tests, $Test_Died) = (0,0,0); -my($Have_Plan) = 0; - -my $IsVMS = $^O eq 'VMS'; +use Test::Builder; +my $Test = Test::Builder->new; -# I'd like to have Test::Simple interfere with the program being -# tested as little as possible. This includes using Exporter or -# anything else (including strict). sub import { - # preserve caller() - if( @_ > 1 ) { - if( $_[1] eq 'no_plan' ) { - goto &no_plan; - } - else { - goto &plan - } - } -} - -sub plan { - my($class, %config) = @_; - - if( !exists $config{tests} ) { - die "You have to tell $class how many tests you plan to run.\n". - " use $class tests => 42; for example.\n"; - } - elsif( !defined $config{tests} ) { - die "Got an undefined number of tests. Looks like you tried to tell ". - "$class how many tests you plan to run but made a mistake.\n"; - } - elsif( !$config{tests} ) { - die "You told $class you plan to run 0 tests! You've got to run ". - "something.\n"; - } - else { - $Planned_Tests = $config{tests}; - } - - $Have_Plan = 1; - - my_print *TESTOUT, "1..$Planned_Tests\n"; - - no strict 'refs'; - my($caller) = caller; + my $self = shift; + my $caller = caller; *{$caller.'::ok'} = \&ok; - -} - -sub no_plan { - $Have_Plan = 1; - - my($caller) = caller; - no strict 'refs'; - *{$caller.'::ok'} = \&ok; + $Test->exported_to($caller); + $Test->plan(@_); } - -$| = 1; -open(*TESTOUT, ">&STDOUT") or _whoa(1, "Can't dup STDOUT!"); -open(*TESTERR, ">&STDERR") or _whoa(1, "Can't dup STDERR!"); -{ - my $orig_fh = select TESTOUT; - $| = 1; - select TESTERR; - $| = 1; - select $orig_fh; -} - =head1 NAME Test::Simple - Basic utilities for writing tests. @@ -106,7 +44,7 @@ test your program will print out an "ok" or "not ok" to indicate pass or fail. You do this with the ok() function (see below). -The only other constraint is you must predeclare how many tests you +The only other constraint is you must pre-declare how many tests you plan to run. This is in case something goes horribly wrong during the test and your test program aborts, or skips a test or whatever. You do this like so: @@ -146,80 +84,7 @@ =cut sub ok ($;$) { - my($test, $name) = @_; - - unless( $Have_Plan ) { - die "You tried to use ok() without a plan! Gotta have a plan.\n". - " use Test::Simple tests => 23; for example.\n"; - } - - $Num_Tests++; - - my_print *TESTERR, <<ERR if defined $name and $name !~ /\D/; -You named your test '$name'. You shouldn't use numbers for your test names. -Very confusing. -ERR - - - my($pack, $file, $line) = caller; - if( $pack eq 'Test::More' ) { # special case for Test::More's calls - ($pack, $file, $line) = caller(1); - } - - my($is_todo) = ${$pack.'::TODO'} ? 1 : 0; - - # We must print this all in one shot or else it will break on VMS - my $msg; - unless( $test ) { - $msg .= "not "; - $Test_Results[$Num_Tests-1] = $is_todo ? 1 : 0; - } - else { - $Test_Results[$Num_Tests-1] = 1; - } - $msg .= "ok $Num_Tests"; - - if( @_ == 2 ) { - $name =~ s|#|\\#|g; # # in a name can confuse Test::Harness. - $msg .= " - $name"; - } - if( $is_todo ) { - my $what_todo = ${$pack.'::TODO'}; - $msg .= " # TODO $what_todo"; - } - $msg .= "\n"; - - my_print *TESTOUT, $msg; - - #'# - unless( $test or $is_todo ) { - my_print *TESTERR, "# Failed test ($file at line $line)\n"; - } - - return $test ? 1 : 0; -} - - -sub _skipped { - my($why) = shift; - - unless( $Have_Plan ) { - die "You tried to use ok() without a plan! Gotta have a plan.\n". - " use Test::Simple tests => 23; for example.\n"; - } - - $Num_Tests++; - - # XXX Set this to "Skip" instead? - $Test_Results[$Num_Tests-1] = 1; - - # We must print this all in one shot or else it will break on VMS - my $msg; - $msg .= "ok $Num_Tests # skip $why\n"; - - my_print *TESTOUT, $msg; - - return 1; + $Test->ok(@_); } @@ -246,142 +111,6 @@ If you fail more than 254 tests, it will be reported as 254. -=begin _private - -=over 4 - -=item B<_sanity_check> - - _sanity_check(); - -Runs a bunch of end of test sanity checks to make sure reality came -through ok. If anything is wrong it will die with a fairly friendly -error message. - -=cut - -#'# -sub _sanity_check { - _whoa($Num_Tests < 0, 'Says here you ran a negative number of tests!'); - _whoa(!$Have_Plan and $Num_Tests, - 'Somehow your tests ran without a plan!'); - _whoa($Num_Tests != @Test_Results, - 'Somehow you got a different number of results than tests ran!'); -} - -=item B<_whoa> - - _whoa($check, $description); - -A sanity check, similar to assert(). If the $check is true, something -has gone horribly wrong. It will die with the given $description and -a note to contact the author. - -=cut - -sub _whoa { - my($check, $desc) = @_; - if( $check ) { - die <<WHOA; -WHOA! $desc -This should never happen! Please contact the author immediately! -WHOA - } -} - -=item B<_my_exit> - - _my_exit($exit_num); - -Perl seems to have some trouble with exiting inside an END block. 5.005_03 -and 5.6.1 both seem to do odd things. Instead, this function edits $? -directly. It should ONLY be called from inside an END block. It -doesn't actually exit, that's your job. - -=cut - -sub _my_exit { - $? = $_[0]; - - return 1; -} - - -=back - -=end _private - -=cut - -$SIG{__DIE__} = sub { - # We don't want to muck with death in an eval, but $^S isn't - # totally reliable. 5.005_03 and 5.6.1 both do the wrong thing - # with it. Instead, we use caller. This also means it runs under - # 5.004! - my $in_eval = 0; - for( my $stack = 1; my $sub = (caller($stack))[3]; $stack++ ) { - $in_eval = 1 if $sub =~ /^\(eval\)/; - } - $Test_Died = 1 unless $in_eval; -}; - -END { - _sanity_check(); - - # Bailout if import() was never called. This is so - # "require Test::Simple" doesn't puke. - do{ _my_exit(0) && return } if !$Have_Plan and !$Num_Tests; - - # Figure out if we passed or failed and print helpful messages. - if( $Num_Tests ) { - # The plan? We have no plan. - unless( $Planned_Tests ) { - my_print *TESTOUT, "1..$Num_Tests\n"; - $Planned_Tests = $Num_Tests; - } - - my $num_failed = grep !$_, @Test_Results[0..$Planned_Tests-1]; - $num_failed += abs($Planned_Tests - @Test_Results); - - if( $Num_Tests < $Planned_Tests ) { - my_print *TESTERR, <<"FAIL"; -# Looks like you planned $Planned_Tests tests but only ran $Num_Tests. -FAIL - } - elsif( $Num_Tests > $Planned_Tests ) { - my $num_extra = $Num_Tests - $Planned_Tests; - my_print *TESTERR, <<"FAIL"; -# Looks like you planned $Planned_Tests tests but ran $num_extra extra. -FAIL - } - elsif ( $num_failed ) { - my_print *TESTERR, <<"FAIL"; -# Looks like you failed $num_failed tests of $Planned_Tests. -FAIL - } - - if( $Test_Died ) { - my_print *TESTERR, <<"FAIL"; -# Looks like your test died just after $Num_Tests. -FAIL - - _my_exit( 255 ) && return; - } - - _my_exit( $num_failed <= 254 ? $num_failed : 254 ) && return; - } - elsif ( $Test::Simple::Skip_All ) { - _my_exit( 0 ) && return; - } - else { - my_print *TESTERR, "# No tests run!\n"; - _my_exit( 255 ) && return; - } -} - - -=pod - This module is by no means trying to be a complete testing system. Its just to get you started. Once you're off the ground its recommended you look at L<Test::More>. @@ -455,12 +184,6 @@ he wasn't in Tony's kitchen). This is it. -=head1 AUTHOR - -Idea by Tony Bowden and Paul Johnson, code by Michael G Schwern -E<lt>[EMAIL PROTECTED]<gt>, wardrobe by Calvin Klein. - - =head1 SEE ALSO =over 4 @@ -469,7 +192,7 @@ More testing functions! Once you outgrow Test::Simple, look at Test::More. Test::Simple is 100% forward compatible with Test::More -(ie. you can just use Test::More instead of Test::Simple in your +(i.e. you can just use Test::More instead of Test::Simple in your programs and things will still work). =item L<Test> @@ -480,7 +203,7 @@ Elaborate unit testing. -=item L<Pod::Tests>, L<SelfTest> +=item L<Test::Inline>, L<SelfTest> Embed tests in your code! @@ -489,6 +212,22 @@ Interprets the output of your test program. =back + + +=head1 AUTHORS + +Idea by Tony Bowden and Paul Johnson, code by Michael G Schwern +E<lt>[EMAIL PROTECTED]<gt>, wardrobe by Calvin Klein. + + +=head1 COPYRIGHT + +Copyright 2001 by Michael G Schwern E<lt>[EMAIL PROTECTED]<gt>. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F<http://www.perl.com/perl/misc/Artistic.html> =cut --- t/op/interp.t 2 Jan 2002 04:10:51 -0000 1.3 +++ t/op/interp.t 12 Jan 2002 22:27:12 -0000 @@ -2,7 +2,6 @@ use Parrot::Test tests => 1; -#SKIP: { skip("runinterp not working at the moment", 1); output_is(<<'CODE', <<'OUTPUT', "runinterp"); newinterp P0, 1 print "calling\n" --- t/op/macro.t 10 Jan 2002 17:12:50 -0000 1.3 +++ t/op/macro.t 12 Jan 2002 22:27:12 -0000 @@ -1,6 +1,7 @@ #! perl -w use Parrot::Test tests => 9; +use Test::More; output_is( <<'CODE', <<OUTPUT, "macro, zero parameters" ); answer macro --- t/op/pmc.t 9 Jan 2002 21:19:12 -0000 1.20 +++ t/op/pmc.t 12 Jan 2002 22:27:12 -0000 @@ -1,6 +1,7 @@ #! perl -w use Parrot::Test tests => 57; +use Test::More; my $fp_equality_macro = <<'ENDOFMACRO'; fp_eq macro J,K,L --- t/op/rx.t 9 Jan 2002 22:35:19 -0000 1.1 +++ t/op/rx.t 12 Jan 2002 22:27:12 -0000 @@ -1,4 +1,5 @@ use Parrot::Test tests => 20; +use Test::More; sub gentest($$;$$) { $_[2] ||= ""; --- t/op/stacks.t 22 Dec 2001 16:02:43 -0000 1.10 +++ t/op/stacks.t 12 Jan 2002 22:27:12 -0000 @@ -1,6 +1,7 @@ #! perl -w use Parrot::Test tests => 19; +use Test::More; # Tests for stack operations, currently push*, push_*_c and pop* # where * != p. --- Test/Utils.pm Sat Jan 12 17:26:57 2002 +++ /dev/null Sat Dec 1 17:56:11 2001 @@ -1,26 +0,0 @@ -package Test::Utils; - -use 5.004; - -use strict; -require Exporter; -use vars qw($VERSION @EXPORT @EXPORT_TAGS @ISA); - -$VERSION = '0.02'; - -@ISA = qw(Exporter); -@EXPORT = qw( my_print print ); - - - -# Special print function to guard against $\ and -l munging. -sub my_print (*@) { - my($fh, @args) = @_; - - local $\; - print $fh @args; -} - -sub print { die "DON'T USE PRINT! Use _print instead" } - -1; -- Michael G. Schwern <[EMAIL PROTECTED]> http://www.pobox.com/~schwern/ Perl Quality Assurance <[EMAIL PROTECTED]> Kwalitee Is Job One Let's leave my ass out of this, shall we?