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?

Reply via email to