This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Test::Simple/More/Builder/Tutorial 0.41
authorMichael G. Schwern <schwern@pobox.com>
Thu, 10 Jan 2002 19:56:23 +0000 (14:56 -0500)
committerJarkko Hietaniemi <jhi@iki.fi>
Fri, 11 Jan 2002 13:21:59 +0000 (13:21 +0000)
Message-ID: <20020111005623.GA13192@blackrider>

p4raw-id: //depot/perl@14178

34 files changed:
MANIFEST
lib/Test/Builder.pm
lib/Test/More.pm
lib/Test/Simple.pm
lib/Test/Simple/Changes
lib/Test/Simple/t/Builder.t
lib/Test/Simple/t/More.t
lib/Test/Simple/t/buffer.t [new file with mode: 0644]
lib/Test/Simple/t/diag.t [new file with mode: 0644]
lib/Test/Simple/t/exit.t
lib/Test/Simple/t/extra.t
lib/Test/Simple/t/fail-like.t
lib/Test/Simple/t/fail-more.t
lib/Test/Simple/t/fail.t
lib/Test/Simple/t/filehandles.t
lib/Test/Simple/t/import.t
lib/Test/Simple/t/is_deeply.t
lib/Test/Simple/t/missing.t
lib/Test/Simple/t/no_ending.t
lib/Test/Simple/t/no_header.t
lib/Test/Simple/t/no_plan.t
lib/Test/Simple/t/output.t
lib/Test/Simple/t/plan.t
lib/Test/Simple/t/plan_is_noplan.t
lib/Test/Simple/t/plan_no_plan.t
lib/Test/Simple/t/plan_skip_all.t
lib/Test/Simple/t/simple.t
lib/Test/Simple/t/skip.t
lib/Test/Simple/t/skipall.t
lib/Test/Simple/t/todo.t
lib/Test/Simple/t/undef.t
lib/Test/Simple/t/use_ok.t
lib/Test/Simple/t/useing.t
lib/Test/Tutorial.pod

index b07674b..f50585c 100644 (file)
--- a/MANIFEST
+++ b/MANIFEST
@@ -1278,6 +1278,8 @@ lib/Test/Simple.pm              Basic utility for writing tests
 lib/Test/Simple/Changes                Test::Simple changes
 lib/Test/Simple/README         Test::Simple README
 lib/Test/Simple/t/Builder.t     Test::Builder tests
+lib/Test/Simple/t/buffer.t      Test::Builder buffering test
+lib/Test/Simple/t/diag.t        Test::More diag() test
 lib/Test/Simple/t/exit.t        Test::Simple test, exit codes
 lib/Test/Simple/t/extra.t       Test::Simple test
 lib/Test/Simple/t/fail-like.t   Test::More test, like() failures
index 1378242..2d8eddd 100644 (file)
@@ -8,7 +8,7 @@ $^C ||= 0;
 
 use strict;
 use vars qw($VERSION $CLASS);
-$VERSION = 0.05;
+$VERSION = '0.11';
 $CLASS = __PACKAGE__;
 
 my $IsVMS = $^O eq 'VMS';
@@ -55,11 +55,13 @@ Test::Builder - Backend for building test libraries
 
 =head1 DESCRIPTION
 
-I<THIS IS ALPHA GRADE SOFTWARE>  The interface will change.
+I<THIS IS ALPHA GRADE SOFTWARE>  Meaning the underlying code is well
+tested, yet the interface is subject to change.
 
 Test::Simple and Test::More have proven to be popular testing modules,
-but they're not always flexible enough.  Test::Builder provides the
-a building block upon which to write your own test libraries.
+but they're not always flexible enough.  Test::Builder provides the a
+building block upon which to write your own test libraries I<which can
+work together>.
 
 =head2 Construction
 
@@ -243,8 +245,8 @@ sub ok {
     $Curr_Test++;
     
     $self->diag(<<ERR) if defined $name and $name =~ /^[\d\s]+$/;
-You named your test '$name'.  You shouldn't use numbers for your test names.
-Very confusing.
+    You named your test '$name'.  You shouldn't use numbers for your test names.
+    Very confusing.
 ERR
 
     my($pack, $file, $line) = $self->caller;
@@ -279,7 +281,7 @@ ERR
 
     unless( $test ) {
         my $msg = $todo ? "Failed (TODO)" : "Failed";
-        $self->diag("$msg test ($file at line $line)\n");
+        $self->diag("    $msg test ($file at line $line)\n");
     } 
 
     return $test ? 1 : 0;
@@ -294,7 +296,7 @@ string version.
 
 =item B<is_num>
 
-  $Test->is_num($get, $expected, $name);
+  $Test->is_num($got, $expected, $name);
 
 Like Test::More's is().  Checks if $got == $expected.  This is the
 numeric version.
@@ -302,41 +304,112 @@ numeric version.
 =cut
 
 sub is_eq {
-    my $self = shift;
+    my($self, $got, $expect, $name) = @_;
     local $Level = $Level + 1;
-    return $self->_is('eq', @_);
+
+    if( !defined $got || !defined $expect ) {
+        # undef only matches undef and nothing else
+        my $test = !defined $got && !defined $expect;
+
+        $self->ok($test, $name);
+        $self->_is_diag($got, 'eq', $expect) unless $test;
+        return $test;
+    }
+
+    return $self->cmp_ok($got, 'eq', $expect, $name);
 }
 
 sub is_num {
-    my $self = shift;
+    my($self, $got, $expect, $name) = @_;
     local $Level = $Level + 1;
-    return $self->_is('==', @_);
+
+    if( !defined $got || !defined $expect ) {
+        # undef only matches undef and nothing else
+        my $test = !defined $got && !defined $expect;
+
+        $self->ok($test, $name);
+        $self->_is_diag($got, '==', $expect) unless $test;
+        return $test;
+    }
+
+    return $self->cmp_ok($got, '==', $expect, $name);
 }
 
-sub _is {
-    my($self, $type, $got, $expect, $name) = @_;
+sub _is_diag {
+    my($self, $got, $type, $expect) = @_;
+
+    foreach my $val (\$got, \$expect) {
+        if( defined $$val ) {
+            if( $type eq 'eq' ) {
+                # quote and force string context
+                $$val = "'$$val'"
+            }
+            else {
+                # force numeric context
+                $$val = $$val+0;
+            }
+        }
+        else {
+            $$val = 'undef';
+        }
+    }
 
-    my $test;
-    {
-        local $^W = 0;      # so we can compare undef quietly
-        $test = $type eq 'eq' ? $got eq $expect
-                              : $got == $expect;
+    $self->diag(sprintf <<DIAGNOSTIC, $got, $expect);
+         got: %s
+    expected: %s
+DIAGNOSTIC
+
+}    
+
+=item B<isnt_eq>
+
+  $Test->isnt_eq($got, $dont_expect, $name);
+
+Like Test::More's isnt().  Checks if $got ne $dont_expect.  This is
+the string version.
+
+=item B<isnt_num>
+
+  $Test->is_num($got, $dont_expect, $name);
+
+Like Test::More's isnt().  Checks if $got ne $dont_expect.  This is
+the numeric version.
+
+=cut
+
+sub isnt_eq {
+    my($self, $got, $dont_expect, $name) = @_;
+    local $Level = $Level + 1;
+
+    if( !defined $got || !defined $dont_expect ) {
+        # undef only matches undef and nothing else
+        my $test = defined $got || defined $dont_expect;
+
+        $self->ok($test, $name);
+        $self->_cmp_diag('ne', $got, $dont_expect) unless $test;
+        return $test;
     }
+
+    return $self->cmp_ok($got, 'ne', $dont_expect, $name);
+}
+
+sub isnt_num {
+    my($self, $got, $dont_expect, $name) = @_;
     local $Level = $Level + 1;
-    my $ok = $self->ok($test, $name);
 
-    unless( $ok ) {
-        $got    = defined $got    ? "'$got'"    : 'undef';
-        $expect = defined $expect ? "'$expect'" : 'undef';
-        $self->diag(sprintf <<DIAGNOSTIC, $got, $expect);
-     got: %s
-expected: %s
-DIAGNOSTIC
-    }        
+    if( !defined $got || !defined $dont_expect ) {
+        # undef only matches undef and nothing else
+        my $test = defined $got || defined $dont_expect;
 
-    return $ok;
+        $self->ok($test, $name);
+        $self->_cmp_diag('!=', $got, $dont_expect) unless $test;
+        return $test;
+    }
+
+    return $self->cmp_ok($got, '!=', $dont_expect, $name);
 }
 
+
 =item B<like>
 
   $Test->like($this, qr/$regex/, $name);
@@ -346,36 +419,65 @@ Like Test::More's like().  Checks if $this matches the given $regex.
 
 You'll want to avoid qr// if you want your tests to work before 5.005.
 
+=item B<unlike>
+
+  $Test->unlike($this, qr/$regex/, $name);
+  $Test->unlike($this, '/$regex/', $name);
+
+Like Test::More's unlike().  Checks if $this B<does not match> the
+given $regex.
+
 =cut
 
 sub like {
     my($self, $this, $regex, $name) = @_;
 
     local $Level = $Level + 1;
+    $self->_regex_ok($this, $regex, '=~', $name);
+}
+
+sub unlike {
+    my($self, $this, $regex, $name) = @_;
+
+    local $Level = $Level + 1;
+    $self->_regex_ok($this, $regex, '!~', $name);
+}
+
+sub _regex_ok {
+    my($self, $this, $regex, $cmp, $name) = @_;
+
+    local $Level = $Level + 1;
 
     my $ok = 0;
+    my $usable_regex;
     if( ref $regex eq 'Regexp' ) {
-        local $^W = 0;
-        $ok = $self->ok( $this =~ $regex ? 1 : 0, $name );
+        $usable_regex = $regex;
     }
     # Check if it looks like '/foo/'
     elsif( my($re, $opts) = $regex =~ m{^ /(.*)/ (\w*) $ }sx ) {
-        local $^W = 0;
-        $ok = $self->ok( $this =~ /(?$opts)$re/ ? 1 : 0, $name );
+        $usable_regex = "(?$opts)$re";
     }
     else {
         $ok = $self->ok( 0, $name );
 
-        $self->diag("'$regex' doesn't look much like a regex to me.");
+        $self->diag("    '$regex' doesn't look much like a regex to me.");
 
         return $ok;
     }
 
+    {
+        local $^W = 0;
+        my $test = $this =~ /$usable_regex/ ? 1 : 0;
+        $test = !$test if $cmp eq '!~';
+        $ok = $self->ok( $test, $name );
+    }
+
     unless( $ok ) {
         $this = defined $this ? "'$this'" : 'undef';
-        $self->diag(sprintf <<DIAGNOSTIC, $this);
-              %s
-doesn't match '$regex'
+        my $match = $cmp eq '=~' ? "doesn't match" : "matches";
+        $self->diag(sprintf <<DIAGNOSTIC, $this, $match, $regex);
+                  %s
+    %13s '%s'
 DIAGNOSTIC
 
     }
@@ -383,6 +485,71 @@ DIAGNOSTIC
     return $ok;
 }
 
+=item B<cmp_ok>
+
+  $Test->cmp_ok($this, $type, $that, $name);
+
+Works just like Test::More's cmp_ok().
+
+    $Test->cmp_ok($big_num, '!=', $other_big_num);
+
+=cut
+
+sub cmp_ok {
+    my($self, $got, $type, $expect, $name) = @_;
+
+    my $test;
+    {
+        local $^W = 0;
+        local($@,$!);   # don't interfere with $@
+                        # eval() sometimes resets $!
+        $test = eval "\$got $type \$expect";
+    }
+    local $Level = $Level + 1;
+    my $ok = $self->ok($test, $name);
+
+    unless( $ok ) {
+        if( $type =~ /^(eq|==)$/ ) {
+            $self->_is_diag($got, $type, $expect);
+        }
+        else {
+            $self->_cmp_diag($got, $type, $expect);
+        }
+    }
+    return $ok;
+}
+
+sub _cmp_diag {
+    my($self, $got, $type, $expect) = @_;
+    
+    $got    = defined $got    ? "'$got'"    : 'undef';
+    $expect = defined $expect ? "'$expect'" : 'undef';
+    $self->diag(sprintf <<DIAGNOSTIC, $got, $type, $expect);
+    %s
+        %s
+    %s
+DIAGNOSTIC
+}
+
+=item B<BAILOUT>
+
+    $Test->BAILOUT($reason);
+
+Indicates to the Test::Harness that things are going so badly all
+testing should terminate.  This includes running any additional test
+scripts.
+
+It will exit with 255.
+
+=cut
+
+sub BAILOUT {
+    my($self, $reason) = @_;
+
+    $self->_print("Bail out!  $reason");
+    exit 255;
+}
+
 =item B<skip>
 
     $Test->skip;
@@ -413,6 +580,41 @@ sub skip {
     return 1;
 }
 
+
+=item B<todo_skip>
+
+  $Test->todo_skip;
+  $Test->todo_skip($why);
+
+Like skip(), only it will declare the test as failing and TODO.  Similar
+to
+
+    print "not ok $tnum # TODO $why\n";
+
+=cut
+
+sub todo_skip {
+    my($self, $why) = @_;
+    $why ||= '';
+
+    unless( $Have_Plan ) {
+        die "You tried to run tests without a plan!  Gotta have a plan.\n";
+    }
+
+    $Curr_Test++;
+
+    $Test_Results[$Curr_Test-1] = 1;
+
+    my $out = "not ok";
+    $out   .= " $Curr_Test" if $self->use_numbers;
+    $out   .= " # TODO $why\n";
+
+    $Test->_print($out);
+
+    return 1;
+}
+
+
 =begin _unimplemented
 
 =item B<skip_rest>
@@ -558,7 +760,8 @@ handle, but if this is for a TODO test, the todo_output() handle is
 used.
 
 Output will be indented and marked with a # so as not to interfere
-with test output.
+with test output.  A newline will be put on the end if there isn't one
+already.
 
 We encourage using this rather than calling print directly.
 
@@ -566,16 +769,18 @@ We encourage using this rather than calling print directly.
 
 sub diag {
     my($self, @msgs) = @_;
+    return unless @msgs;
 
     # Prevent printing headers when compiling (i.e. -c)
     return if $^C;
 
     # Escape each line with a #.
     foreach (@msgs) {
-        s/^([^#])/#     $1/;
-        s/\n([^#])/\n#     $1/g;
+        s/^/# /gms;
     }
 
+    push @msgs, "\n" unless $msgs[-1] =~ /\n\Z/;
+
     local $Level = $Level + 1;
     my $fh = $self->todo ? $self->todo_output : $self->failure_output;
     local($\, $", $,) = (undef, ' ', '');
@@ -685,8 +890,14 @@ unless( $^C ) {
     # test suites while still getting normal test output.
     open(TESTOUT, ">&STDOUT") or die "Can't dup STDOUT:  $!";
     open(TESTERR, ">&STDERR") or die "Can't dup STDERR:  $!";
+
+    # Set everything to unbuffered else plain prints to STDOUT will
+    # come out in the wrong order from our own prints.
     _autoflush(\*TESTOUT);
+    _autoflush(\*STDOUT);
     _autoflush(\*TESTERR);
+    _autoflush(\*STDERR);
+
     $CLASS->output(\*TESTOUT);
     $CLASS->failure_output(\*TESTERR);
     $CLASS->todo_output(\*TESTOUT);
@@ -912,24 +1123,24 @@ sub _ending {
 
         if( $Curr_Test < $Expected_Tests ) {
             $self->diag(<<"FAIL");
-Looks like you planned $Expected_Tests tests but only ran $Curr_Test.
+Looks like you planned $Expected_Tests tests but only ran $Curr_Test.
 FAIL
         }
         elsif( $Curr_Test > $Expected_Tests ) {
             my $num_extra = $Curr_Test - $Expected_Tests;
             $self->diag(<<"FAIL");
-Looks like you planned $Expected_Tests tests but ran $num_extra extra.
+Looks like you planned $Expected_Tests tests but ran $num_extra extra.
 FAIL
         }
         elsif ( $num_failed ) {
             $self->diag(<<"FAIL");
-Looks like you failed $num_failed tests of $Expected_Tests.
+Looks like you failed $num_failed tests of $Expected_Tests.
 FAIL
         }
 
         if( $Test_Died ) {
             $self->diag(<<"FAIL");
-Looks like your test died just after $Curr_Test.
+Looks like your test died just after $Curr_Test.
 FAIL
 
             _my_exit( 255 ) && return;
@@ -941,7 +1152,7 @@ FAIL
         _my_exit( 0 ) && return;
     }
     else {
-        $self->diag("No tests run!\n");
+        $self->diag("No tests run!\n");
         _my_exit( 255 ) && return;
     }
 }
@@ -971,7 +1182,7 @@ Copyright 2001 by chromatic E<lt>chromatic@wgz.orgE<gt>,
 This program is free software; you can redistribute it and/or 
 modify it under the same terms as Perl itself.
 
-See L<http://www.perl.com/perl/misc/Artistic.html>
+See F<http://www.perl.com/perl/misc/Artistic.html>
 
 =cut
 
index 617455f..4b03dff 100644 (file)
@@ -11,23 +11,25 @@ use Test::Builder;
 # actually happened.
 sub _carp {
     my($file, $line) = (caller(1))[1,2];
-    warn @_, sprintf " at $file line $line\n";
+    warn @_, " at $file line $line\n";
 }
 
 
 
 require Exporter;
 use vars qw($VERSION @ISA @EXPORT %EXPORT_TAGS $TODO);
-$VERSION = '0.33';
+$VERSION = '0.41';
 @ISA    = qw(Exporter);
 @EXPORT = qw(ok use_ok require_ok
-             is isnt like is_deeply
-             skip todo
+             is isnt like unlike is_deeply
+             cmp_ok
+             skip todo todo_skip
              pass fail
              eq_array eq_hash eq_set
              $TODO
              plan
              can_ok  isa_ok
+             diag
             );
 
 my $Test = Test::Builder->new;
@@ -38,7 +40,7 @@ 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, @_);
 }
@@ -64,7 +66,14 @@ 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);
 
@@ -102,13 +111,15 @@ Test::More - yet another framework for writing test scripts
 
 =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
@@ -320,27 +331,7 @@ sub is ($$;$) {
 }
 
 sub isnt ($$;$) {
-    my($this, $that, $name) = @_;
-
-    my $test;
-    {
-        local $^W = 0;   # so isnt(undef, undef) works quietly.
-        $test = $this ne $that;
-    }
-
-    my $ok = $Test->ok($test, $name);
-
-    unless( $ok ) {
-        $that = defined $that ? "'$that'" : 'undef';
-
-        $Test->diag(sprintf <<DIAGNOSTIC, $that);
-it should not be %s
-but it is.
-DIAGNOSTIC
-
-    }
-
-    return $ok;
+    $Test->isnt_eq(@_);
 }
 
 *isn't = \&isnt;
@@ -380,6 +371,59 @@ sub like ($$;$) {
     $Test->like(@_);
 }
 
+
+=item B<unlike>
+
+  unlike( $this, qr/that/, $test_name );
+
+Works exactly as like(), only it checks if $this B<does not> match the
+given pattern.
+
+=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);
@@ -400,15 +444,30 @@ 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;
 
+    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')";
+        local($!, $@);  # don't interfere with caller's $@
+                        # eval sometimes resets $!
         eval $test || push @nok, $method;
     }
 
@@ -418,7 +477,7 @@ sub can_ok ($@) {
     
     my $ok = $Test->ok( !@nok, $name );
 
-    $Test->diag(map "$class->can('$_') failed\n", @nok);
+    $Test->diag(map "    $class->can('$_') failed\n", @nok);
 
     return $ok;
 }
@@ -426,6 +485,7 @@ sub can_ok ($@) {
 =item B<isa_ok>
 
   isa_ok($object, $class, $object_name);
+  isa_ok($ref,    $type,  $ref_name);
 
 Checks to see if the given $object->isa($class).  Also checks to make
 sure the object was defined in the first place.  Handy for this sort
@@ -441,6 +501,10 @@ 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').
@@ -459,14 +523,37 @@ sub isa_ok ($$;$) {
     elsif( !ref $object ) {
         $diag = "$obj_name isn't a reference";
     }
-    elsif( !$object->isa($class) ) {
-        $diag = "$obj_name 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 = $Test->ok( 0, $name );
-        $Test->diag("$diag\n");
+        $Test->diag("    $diag\n");
     }
     else {
         $ok = $Test->ok( 1, $name );
@@ -503,6 +590,47 @@ sub fail (;$) {
 
 =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
 
 You usually want to test if the module you're testing loads ok, rather
@@ -538,6 +666,7 @@ sub use_ok ($;@) {
 
     my $pack = caller;
 
+    local($@,$!);   # eval sometimes interferes with $!
     eval <<USE;
 package $pack;
 require $module;
@@ -549,8 +678,8 @@ USE
     unless( $ok ) {
         chomp $@;
         $Test->diag(<<DIAGNOSTIC);
-Tried to use '$module'.
-Error:  $@
+    Tried to use '$module'.
+    Error:  $@
 DIAGNOSTIC
 
     }
@@ -571,6 +700,7 @@ sub require_ok ($) {
 
     my $pack = caller;
 
+    local($!, $@); # eval sometimes interferes with $!
     eval <<REQUIRE;
 package $pack;
 require $module;
@@ -581,8 +711,8 @@ REQUIRE
     unless( $ok ) {
         chomp $@;
         $Test->diag(<<DIAGNOSTIC);
-    Tried to require '$module'.
-    Error:  $@
+    Tried to require '$module'.
+    Error:  $@
 DIAGNOSTIC
 
     }
@@ -594,9 +724,6 @@ DIAGNOSTIC
 
 =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 
@@ -604,7 +731,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<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
@@ -641,10 +769,16 @@ are in the block so the total number of tests comes out right (unless
 you're using C<no_plan>, in which case you can leave $how_many off if
 you like).
 
-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.
+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.
+
 
 =for _Future
 See L</Why are skip and todo so weird?>
@@ -674,7 +808,7 @@ sub skip {
 =item B<TODO: BLOCK>
 
     TODO: {
-        local $TODO = $why;
+        local $TODO = $why if $condition;
 
         ...normal testing code goes here...
     }
@@ -707,6 +841,45 @@ Once a todo test starts succeeding, simply move it outside the block.
 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 Comparison functions
@@ -729,6 +902,9 @@ 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
@@ -793,6 +969,7 @@ sub _format_stack {
     $out .= "$vars[0] = $vals[0]\n";
     $out .= "$vars[1] = $vals[1]\n";
 
+    $out =~ s/^/    /msg;
     return $out;
 }
 
@@ -925,43 +1102,60 @@ sub eq_set  {
     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.
+
+=cut
 
-    my_ok( 2 + 2 == 5, 'Basic addition' );
+sub builder {
+    return Test::Builder->new;
+}
 
-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:
+=back
 
-    sub my_ok {
-        ok( $_[0], $_[1] );
-    }
 
-The other functions act similarly.
+=head1 NOTES
+
+Test::More is B<explicitly> tested all the way back to perl 5.004.
 
-=item The eq_* family have some caveats.
+=head1 BUGS and CAVEATS
+
+=over 4
+
+=item Making your own ok()
+
+If you are trying to extend Test::More, don't.  Use Test::Builder
+instead.
+
+=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.
@@ -990,7 +1184,11 @@ L<Test::Simple> if all this confuses you and you just want to write
 some tests.  You can upgrade to Test::More later (its forward
 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.
@@ -1004,9 +1202,9 @@ L<SelfTest> is another approach to embedded testing.
 
 =head1 AUTHORS
 
-Michael G Schwern E<lt>schwern@pobox.comE<gt> with much inspiration from
-Joshua Pritikin's Test module and lots of discussion with Barrie
-Slaymaker and the perl-qa gang.
+Michael G Schwern E<lt>schwern@pobox.comE<gt> with much inspiration
+from Joshua Pritikin's Test module and lots of help from Barrie
+Slaymaker, Tony Bowden, chromatic and the perl-qa gang.
 
 
 =head1 COPYRIGHT
@@ -1016,7 +1214,7 @@ Copyright 2001 by Michael G Schwern E<lt>schwern@pobox.comE<gt>.
 This program is free software; you can redistribute it and/or 
 modify it under the same terms as Perl itself.
 
-See L<http://www.perl.com/perl/misc/Artistic.html>
+See F<http://www.perl.com/perl/misc/Artistic.html>
 
 =cut
 
index 6d0a0a0..339d085 100644 (file)
@@ -4,7 +4,7 @@ use 5.004;
 
 use strict 'vars';
 use vars qw($VERSION);
-$VERSION = '0.33';
+$VERSION = '0.41';
 
 
 use Test::Builder;
@@ -227,7 +227,7 @@ Copyright 2001 by Michael G Schwern E<lt>schwern@pobox.comE<gt>.
 This program is free software; you can redistribute it and/or 
 modify it under the same terms as Perl itself.
 
-See L<http://www.perl.com/perl/misc/Artistic.html>
+See F<http://www.perl.com/perl/misc/Artistic.html>
 
 =cut
 
index 8aebf59..b13ab46 100644 (file)
@@ -1,5 +1,34 @@
 Revision history for Perl extension Test::Simple
 
+0.41  Mon Dec 17 22:45:20 EST 2001
+    * chromatic added diag()
+    - Internal eval()'s sometimes interfering with $@ and $!.  Fixed.
+
+0.40  Fri Dec 14 15:41:39 EST 2001
+    * isa_ok() now accepts unblessed references gracefully
+    - Nick Clark found a bug with like() and a regex with % in it.
+    - exit.t was hanging on 5.005_03 VMS perl.  Test now skipped.
+    - can_ok() would pass if no methods were given.  Now fails.
+    - isnt() diagnostic output format changed
+    * Added some docs about embedding and extending Test::More
+    * Added Test::More->builder
+    * Added cmp_ok()
+    * Added todo_skip()
+    * Added unlike()
+    - Piers pointed out that sometimes people override isa().
+      isa_ok() now accounts for that.
+
+0.36  Thu Nov 29 14:07:39 EST 2001
+    - Matthias Urlichs found that intermixed prints to STDOUT and test 
+      output came out in the wrong order when piped.
+
+0.35  Tue Nov 27 19:57:03 EST 2001
+    - Little glitch in the test suite.  No actual bug.
+
+0.34  Tue Nov 27 15:43:56 EST 2001
+    * Empty string no longer matches undef in is() and isnt().
+    * Added isnt_eq and isnt_num to Test::Builder.
+
 0.33  Mon Oct 22 21:05:47 EDT 2001
     * It's now officially safe to redirect STDOUT and STDERR without
       affecting test output.
index 64dfbea..0ef079c 100644 (file)
@@ -1,8 +1,10 @@
 #!/usr/bin/perl -w
 
 BEGIN {
-    chdir 't' if -d 't';
-    @INC = '../lib';
+    if( $ENV{PERL_CORE} ) {
+        chdir 't';
+        @INC = '../lib';
+    }
 }
 
 use Test::Builder;
index ee23f6f..bee2fb4 100644 (file)
@@ -1,11 +1,19 @@
 #!perl -w
 
 BEGIN {
-    chdir 't' if -d 't';
-    @INC = '../lib';
+    if( $ENV{PERL_CORE} ) {
+        chdir 't';
+        @INC = '../lib';
+    }
 }
 
-use Test::More tests => 24;
+use Test::More tests => 37;
+
+# Make sure we don't mess with $@ or $!.  Test at bottom.
+my $Err   = "this should not be touched";
+my $Errno = 42;
+$@ = $Err;
+$! = $Errno;
 
 use_ok('Text::Soundex');
 require_ok('Test::More');
@@ -21,12 +29,18 @@ like("fooble", '/^foo/',    'foo is like fooble');
 like("FooBle", '/foo/i',   'foo is like FooBle');
 like("/usr/local/pr0n/", '/^\/usr\/local/',   'regexes with slashes in like' );
 
+unlike("fbar", '/^bar/',    'unlike bar');
+unlike("FooBle", '/foo/',   'foo is unlike FooBle');
+unlike("/var/local/pr0n/", '/^\/usr\/local/','regexes with slashes in unlike' );
+
 can_ok('Test::More', qw(require_ok use_ok ok is isnt like skip can_ok
                         pass fail eq_array eq_hash eq_set));
 can_ok(bless({}, "Test::More"), qw(require_ok use_ok ok is isnt like skip 
                                    can_ok pass fail eq_array eq_hash eq_set));
 
 isa_ok(bless([], "Foo"), "Foo");
+isa_ok([], 'ARRAY');
+isa_ok(\42, 'SCALAR');
 
 
 pass('pass() passed');
@@ -92,3 +106,28 @@ ok( eq_hash(\%hash1, \%hash2),  'eq_hash with complicated hashes');
 
 ok( !eq_hash(\%hash1, \%hash2),
     'eq_hash with slightly different complicated hashes' );
+
+is( Test::Builder->new, Test::More->builder,    'builder()' );
+
+
+cmp_ok(42, '==', 42,        'cmp_ok ==');
+cmp_ok('foo', 'eq', 'foo',  '       eq');
+cmp_ok(42.5, '<', 42.6,     '       <');
+cmp_ok(0, '||', 1,          '       ||');
+
+
+# Piers pointed out sometimes people override isa().
+{
+    package Wibble;
+    sub isa {
+        my($self, $class) = @_;
+        return 1 if $class eq 'Wibblemeister';
+    }
+    sub new { bless {} }
+}
+isa_ok( Wibble->new, 'Wibblemeister' );
+
+
+# These two tests must remain at the end.
+is( $@, $Err,               '$@ untouched' );
+cmp_ok( $!, '==', $Errno,   '$! untouched' );
diff --git a/lib/Test/Simple/t/buffer.t b/lib/Test/Simple/t/buffer.t
new file mode 100644 (file)
index 0000000..7cc64d9
--- /dev/null
@@ -0,0 +1,44 @@
+#!/usr/bin/perl
+
+BEGIN {
+    if( $ENV{PERL_CORE} ) {
+        chdir 't';
+        @INC = '../lib';
+    }
+}
+
+# Ensure that intermixed prints to STDOUT and tests come out in the
+# right order (ie. no buffering problems).
+
+use Test::More tests => 20;
+my $T = Test::Builder->new;
+$T->no_ending(1);
+
+for my $num (1..10) {
+    $tnum = $num * 2;
+    pass("I'm ok");
+    $T->current_test($tnum);
+    print "ok $tnum - You're ok\n";
+}
+#!/usr/bin/perl
+
+BEGIN {
+    if( $ENV{PERL_CORE} ) {
+        chdir 't';
+        @INC = '../lib';
+    }
+}
+
+# Ensure that intermixed prints to STDOUT and tests come out in the
+# right order (ie. no buffering problems).
+
+use Test::More tests => 20;
+my $T = Test::Builder->new;
+$T->no_ending(1);
+
+for my $num (1..10) {
+    $tnum = $num * 2;
+    pass("I'm ok");
+    $T->current_test($tnum);
+    print "ok $tnum - You're ok\n";
+}
diff --git a/lib/Test/Simple/t/diag.t b/lib/Test/Simple/t/diag.t
new file mode 100644 (file)
index 0000000..7954ed0
--- /dev/null
@@ -0,0 +1,114 @@
+#!perl -w
+
+BEGIN {
+    if( $ENV{PERL_CORE} ) {
+        chdir 't';
+        @INC = '../lib';
+    }
+}
+
+use strict;
+
+use Test::More tests => 5;
+
+my $Test = Test::More->builder;
+
+# now make a filehandle where we can send data
+my $output;
+tie *FAKEOUT, 'FakeOut', \$output;
+
+# force diagnostic output to a filehandle, glad I added this to Test::Builder :)
+my @lines;
+{
+    local $TODO = 1;
+    $Test->todo_output(\*FAKEOUT);
+
+    diag("a single line");
+
+    push @lines, $output;
+    $output = '';
+
+    diag("multiple\n", "lines");
+    push @lines, split(/\n/, $output);
+}
+
+is( @lines, 3,              'diag() should send messages to its filehandle' );
+like( $lines[0], '/^#\s+/', '    should add comment mark to all lines' );
+is( $lines[0], "# a single line\n",   '    should send exact message' );
+is( $output, "# multiple\n# lines\n", '    should append multi messages');
+
+{
+    local $TODO = 1;
+    $output = '';
+    diag("# foo");
+}
+is( $output, "# # foo\n",   "diag() adds a # even if there's one already" );
+
+
+package FakeOut;
+
+sub TIEHANDLE {
+       bless( $_[1], $_[0] );
+}
+
+sub PRINT {
+       my $self = shift;
+       $$self .= join('', @_);
+}
+#!perl -w
+
+BEGIN {
+    if( $ENV{PERL_CORE} ) {
+        chdir 't';
+        @INC = '../lib';
+    }
+}
+
+use strict;
+
+use Test::More tests => 5;
+
+my $Test = Test::More->builder;
+
+# now make a filehandle where we can send data
+my $output;
+tie *FAKEOUT, 'FakeOut', \$output;
+
+# force diagnostic output to a filehandle, glad I added this to Test::Builder :)
+my @lines;
+{
+    local $TODO = 1;
+    $Test->todo_output(\*FAKEOUT);
+
+    diag("a single line");
+
+    push @lines, $output;
+    $output = '';
+
+    diag("multiple\n", "lines");
+    push @lines, split(/\n/, $output);
+}
+
+is( @lines, 3,              'diag() should send messages to its filehandle' );
+like( $lines[0], '/^#\s+/', '    should add comment mark to all lines' );
+is( $lines[0], "# a single line\n",   '    should send exact message' );
+is( $output, "# multiple\n# lines\n", '    should append multi messages');
+
+{
+    local $TODO = 1;
+    $output = '';
+    diag("# foo");
+}
+is( $output, "# # foo\n",   "diag() adds a # even if there's one already" );
+
+
+package FakeOut;
+
+sub TIEHANDLE {
+       bless( $_[1], $_[0] );
+}
+
+sub PRINT {
+       my $self = shift;
+       $$self .= join('', @_);
+}
index 439ccf0..dcc4565 100644 (file)
@@ -1,14 +1,21 @@
-BEGIN {
-    chdir 't' if -d 't';
-    @INC = '../lib';
-}
-
 # Can't use Test.pm, that's a 5.005 thing.
 package My::Test;
 
+BEGIN {
+    if( $ENV{PERL_CORE} ) {
+        chdir 't';
+        @INC = '../lib';
+    }
+}
+
 unless( eval { require File::Spec } ) {
     print "1..0 # Skip Need File::Spec to run this test\n";
-    exit(0);
+    exit 0;
+}
+
+if( $^O eq 'VMS' && $] <= 5.00503 ) {
+    print "1..0 # Skip test will hang on older VMS perls\n";
+    exit 0;
 }
 
 my $test_num = 1;
@@ -47,12 +54,24 @@ my %Tests = (
 
 print "1..".keys(%Tests)."\n";
 
+chdir 't';
 my $lib = File::Spec->catdir(qw(lib Test Simple sample_tests));
 while( my($test_name, $exit_codes) = each %Tests ) {
     my($exit_code) = $exit_codes->[$IsVMS ? 1 : 0];
 
+    my $Perl = $^X;
+
+    if( $^O eq 'VMS' ) {
+        # VMS can't use its own $^X in a system call until almost 5.8
+        $Perl = "MCR $^X" if $] < 5.007003;
+
+        # Quiet noisy 'SYS$ABORT'.  'hushed' only exists in 5.6 and up,
+        # but it doesn't do any harm on eariler perls.
+        $Perl .= q{ -"Mvmsish=hushed"};
+    }
+
     my $file = File::Spec->catfile($lib, $test_name);
-    my $wait_stat = system(qq{$^X -"I../lib" -"I../t/lib" $file});
+    my $wait_stat = system(qq{$Perl -"I../blib/lib" -"I../lib" -"I../t/lib" $file});
     my $actual_exit = $wait_stat >> 8;
 
     My::Test::ok( $actual_exit == $exit_code, 
index acb23fd..1ed94ad 100644 (file)
@@ -1,8 +1,10 @@
 #!perl -w
 
 BEGIN {
-    chdir 't' if -d 't';
-    @INC = '../lib';
+    if( $ENV{PERL_CORE} ) {
+        chdir 't';
+        @INC = '../lib';
+    }
 }
 
 # Can't use Test.pm, that's a 5.005 thing.
@@ -28,6 +30,7 @@ package main;
 
 require Test::Simple;
 
+chdir 't';
 push @INC, '../t/lib/';
 require Test::Simple::Catch;
 my($out, $err) = Test::Simple::Catch::caught();
index 0821713..1336763 100644 (file)
@@ -7,17 +7,20 @@ BEGIN {
     }
 }
 
+BEGIN {
+    if( $ENV{PERL_CORE} ) {
+        chdir 't';
+        @INC = ('../lib', 'lib');
+    }
+    else {
+        unshift @INC, 't/lib';
+    }
+}
 
 # There was a bug with like() involving a qr// not failing properly.
 # This tests against that.
 
-BEGIN { 
-    chdir 't' if -d 't';
-    @INC = '../lib';
-}
-
 use strict;
-use lib '../t/lib';
 
 require Test::Simple::Catch;
 my($out, $err) = Test::Simple::Catch::caught();
index 6c61762..6fd88c8 100644 (file)
@@ -1,12 +1,16 @@
 #!perl -w
 
 BEGIN {
-    chdir 't' if -d 't';
-    @INC = '../lib';
+    if( $ENV{PERL_CORE} ) {
+        chdir 't';
+        @INC = ('../lib', 'lib');
+    }
+    else {
+        unshift @INC, 't/lib';
+    }
 }
 
 use strict;
-use lib '../t/lib';
 
 require Test::Simple::Catch;
 my($out, $err) = Test::Simple::Catch::caught();
@@ -36,84 +40,183 @@ sub ok ($;$) {
 package main;
 
 require Test::More;
-Test::More->import(tests => 12);
+my $Total = 28;
+Test::More->import(tests => $Total);
 
 # Preserve the line numbers.
 #line 38
 ok( 0, 'failing' );
-is(  "foo", "bar", 'foo is bar?');
+
+#line 40
+is( "foo", "bar", 'foo is bar?');
+is( undef, '',    'undef is empty string?');
+is( undef, 0,     'undef is 0?');
+is( '',    0,     'empty string is 0?' );
+
 isnt("foo", "foo", 'foo isnt foo?' );
 isn't("foo", "foo",'foo isn\'t foo?' );
 
 like( "foo", '/that/',  'is foo like that' );
+unlike( "foo", '/foo/', 'is foo unlike foo' );
+
+# Nick Clark found this was a bug.  Fixed in 0.40.
+like( "bug", '/(%)/',   'regex with % in it' );
 
 fail('fail()');
 
+#line 52
 can_ok('Mooble::Hooble::Yooble', qw(this that));
+can_ok('Mooble::Hooble::Yooble', ());
+
 isa_ok(bless([], "Foo"), "Wibble");
 isa_ok(42,    "Wibble", "My Wibble");
 isa_ok(undef, "Wibble", "Another Wibble");
-
+isa_ok([],    "HASH");
+
+#line 68
+cmp_ok( 'foo', 'eq', 'bar', 'cmp_ok eq' );
+cmp_ok( 42.1,  '==', 23,  , '       ==' );
+cmp_ok( 42,    '!=', 42   , '       !=' );
+cmp_ok( 1,     '&&', 0    , '       &&' );
+cmp_ok( 42,    '==', "foo", '       == with strings' );
+cmp_ok( 42,    'eq', "foo", '       eq with numbers' );
+cmp_ok( undef, 'eq', 'foo', '       eq with undef' );
+
+# generate a $!, it changes its value by context.
+-e "wibblehibble";
+my $Errno_Number = $!+0;
+my $Errno_String = $!.'';
+cmp_ok( $!,    'eq', '',    '       eq with stringified errno' );
+cmp_ok( $!,    '==', -1,    '       eq with numerified errno' );
+
+#line 84
 use_ok('Hooble::mooble::yooble');
 require_ok('ALL::YOUR::BASE::ARE::BELONG::TO::US::wibble');
 
+#line 88
 END {
     My::Test::ok($$out eq <<OUT, 'failing output');
-1..12
+1..$Total
 not ok 1 - failing
 not ok 2 - foo is bar?
-not ok 3 - foo isnt foo?
-not ok 4 - foo isn't foo?
-not ok 5 - is foo like that
-not ok 6 - fail()
-not ok 7 - Mooble::Hooble::Yooble->can(...)
-not ok 8 - The object isa Wibble
-not ok 9 - My Wibble isa Wibble
-not ok 10 - Another Wibble isa Wibble
-not ok 11 - use Hooble::mooble::yooble;
-not ok 12 - require ALL::YOUR::BASE::ARE::BELONG::TO::US::wibble;
+not ok 3 - undef is empty string?
+not ok 4 - undef is 0?
+not ok 5 - empty string is 0?
+not ok 6 - foo isnt foo?
+not ok 7 - foo isn't foo?
+not ok 8 - is foo like that
+not ok 9 - is foo unlike foo
+not ok 10 - regex with % in it
+not ok 11 - fail()
+not ok 12 - Mooble::Hooble::Yooble->can(...)
+not ok 13 - Mooble::Hooble::Yooble->can(...)
+not ok 14 - The object isa Wibble
+not ok 15 - My Wibble isa Wibble
+not ok 16 - Another Wibble isa Wibble
+not ok 17 - The object isa HASH
+not ok 18 - cmp_ok eq
+not ok 19 -        ==
+not ok 20 -        !=
+not ok 21 -        &&
+not ok 22 -        == with strings
+not ok 23 -        eq with numbers
+not ok 24 -        eq with undef
+not ok 25 -        eq with stringified errno
+not ok 26 -        eq with numerified errno
+not ok 27 - use Hooble::mooble::yooble;
+not ok 28 - require ALL::YOUR::BASE::ARE::BELONG::TO::US::wibble;
 OUT
 
     my $err_re = <<ERR;
 #     Failed test ($0 at line 38)
-#     Failed test ($0 at line 39)
+#     Failed test ($0 at line 40)
 #          got: 'foo'
 #     expected: 'bar'
-#     Failed test ($0 at line 40)
-#     it should not be 'foo'
-#     but it is.
 #     Failed test ($0 at line 41)
-#     it should not be 'foo'
-#     but it is.
+#          got: undef
+#     expected: ''
+#     Failed test ($0 at line 42)
+#          got: undef
+#     expected: '0'
 #     Failed test ($0 at line 43)
+#          got: ''
+#     expected: '0'
+#     Failed test ($0 at line 45)
+#     'foo'
+#         ne
+#     'foo'
+#     Failed test ($0 at line 46)
+#     'foo'
+#         ne
+#     'foo'
+#     Failed test ($0 at line 48)
 #                   'foo'
 #     doesn't match '/that/'
-#     Failed test ($0 at line 45)
-#     Failed test ($0 at line 47)
+#     Failed test ($0 at line 49)
+#                   'foo'
+#           matches '/foo/'
+#     Failed test ($0 at line 52)
+#                   'bug'
+#     doesn't match '/(%)/'
+#     Failed test ($0 at line 54)
+#     Failed test ($0 at line 52)
 #     Mooble::Hooble::Yooble->can('this') failed
 #     Mooble::Hooble::Yooble->can('that') failed
-#     Failed test ($0 at line 48)
-#     The object isn't a 'Wibble'
-#     Failed test ($0 at line 49)
+#     Failed test ($0 at line 53)
+#     can_ok() called with no methods
+#     Failed test ($0 at line 55)
+#     The object isn't a 'Wibble' its a 'Foo'
+#     Failed test ($0 at line 56)
 #     My Wibble isn't a reference
-#     Failed test ($0 at line 50)
+#     Failed test ($0 at line 57)
 #     Another Wibble isn't defined
+#     Failed test ($0 at line 58)
+#     The object isn't a 'HASH' its a 'ARRAY'
+#     Failed test ($0 at line 68)
+#          got: 'foo'
+#     expected: 'bar'
+#     Failed test ($0 at line 69)
+#          got: 42.1
+#     expected: 23
+#     Failed test ($0 at line 70)
+#     '42'
+#         !=
+#     '42'
+#     Failed test ($0 at line 71)
+#     '1'
+#         &&
+#     '0'
+#     Failed test ($0 at line 72)
+#          got: 42
+#     expected: 0
+#     Failed test ($0 at line 73)
+#          got: '42'
+#     expected: 'foo'
+#     Failed test ($0 at line 74)
+#          got: undef
+#     expected: 'foo'
+#     Failed test ($0 at line 80)
+#          got: '$Errno_String'
+#     expected: ''
+#     Failed test ($0 at line 81)
+#          got: $Errno_Number
+#     expected: -1
 ERR
 
    my $filename = quotemeta $0;
    my $more_err_re = <<ERR;
-#     Failed test \\($filename at line 52\\)
+#     Failed test \\($filename at line 84\\)
 #     Tried to use 'Hooble::mooble::yooble'.
 #     Error:  Can't locate Hooble.* in \\\@INC .*
-#     Failed test \\($filename at line 53\\)
+#     Failed test \\($filename at line 85\\)
 #     Tried to require 'ALL::YOUR::BASE::ARE::BELONG::TO::US::wibble'.
 #     Error:  Can't locate ALL.* in \\\@INC .*
-# Looks like you failed 12 tests of 12.
+# Looks like you failed $Total tests of $Total.
 ERR
 
     unless( My::Test::ok($$err =~ /^\Q$err_re\E$more_err_re$/, 
                          'failing errors') ) {
-        print map "# $_", $$err;
+        print $$err;
     }
 
     exit(0);
index 9c8f0bd..a041ab0 100644 (file)
@@ -1,12 +1,16 @@
 #!perl -w
 
 BEGIN {
-    chdir 't' if -d 't';
-    @INC = '../lib';
+    if( $ENV{PERL_CORE} ) {
+        chdir 't';
+        @INC = ('../lib', 'lib');
+    }
+    else {
+        unshift @INC, 't/lib';
+    }
 }
 
 use strict;
-use lib qw(../t/lib);
 
 require Test::Simple::Catch;
 my($out, $err) = Test::Simple::Catch::caught();
index 3b3c553..dfea4ba 100644 (file)
@@ -1,5 +1,12 @@
 #!perl -w
 
+BEGIN {
+    if( $ENV{PERL_CORE} ) {
+        chdir 't';
+        @INC = '../lib';
+    }
+}
+
 use Test::More tests => 1;
 
 tie *STDOUT, "Dev::Null" or die $!;
index bf0b5a9..68a3613 100644 (file)
@@ -1,8 +1,11 @@
 BEGIN {
-    chdir 't' if -d 't';
-    @INC = '../lib';
+    if( $ENV{PERL_CORE} ) {
+        chdir 't';
+        @INC = '../lib';
+    }
 }
 
+
 use Test::More tests => 2, import => [qw(!fail)];
 
 can_ok(__PACKAGE__, qw(ok pass like isa_ok));
index ea0c150..5291fb8 100644 (file)
@@ -1,12 +1,16 @@
-#!perl -w
+#!/usr/bin/perl -w
 
 BEGIN {
-    chdir 't' if -d 't';
-    @INC = '../lib';
+    if( $ENV{PERL_CORE} ) {
+        chdir 't';
+        @INC = ('../lib', 'lib');
+    }
+    else {
+        unshift @INC, 't/lib';
+    }
 }
 
 use strict;
-use lib qw(../t/lib);
 
 use Test::Builder;
 require Test::Simple::Catch;
index 9030329..7f45180 100644 (file)
@@ -1,6 +1,11 @@
 BEGIN {
-    chdir 't' if -d 't';
-    @INC = '../lib';
+    if( $ENV{PERL_CORE} ) {
+        chdir 't';
+        @INC = ('../lib', 'lib');
+    }
+    else {
+        unshift @INC, 't/lib';
+    }
 }
 
 # Can't use Test.pm, that's a 5.005 thing.
@@ -26,7 +31,6 @@ package main;
 
 require Test::Simple;
 
-push @INC, '../t/lib';
 require Test::Simple::Catch;
 my($out, $err) = Test::Simple::Catch::caught();
 
index c8bd396..97e968e 100644 (file)
@@ -1,10 +1,12 @@
+use Test::Builder;
+
 BEGIN {
-    chdir 't' if -d 't';
-    @INC = '../lib';
+    if( $ENV{PERL_CORE} ) {
+        chdir 't';
+        @INC = '../lib';
+    }
 }
 
-use Test::Builder;
-
 BEGIN {
     my $t = Test::Builder->new;
     $t->no_ending(1);
index b788ef5..93e6bec 100644 (file)
@@ -1,12 +1,10 @@
 BEGIN {
-    chdir 't' if -d 't';
-    @INC = '../lib';
+    if( $ENV{PERL_CORE} ) {
+        chdir 't';
+        @INC = '../lib';
+    }
 }
 
-# STDOUT must be unbuffered else our prints might come out after
-# Test::More's.
-$| = 1;
-
 use Test::Builder;
 
 # STDOUT must be unbuffered else our prints might come out after
index beca5a6..c0af2d4 100644 (file)
@@ -1,6 +1,11 @@
 BEGIN {
-    chdir 't' if -d 't';
-    @INC = '../lib';
+    if( $ENV{PERL_CORE} ) {
+        chdir 't';
+        @INC = ('../lib', 'lib');
+    }
+    else {
+        unshift @INC, 't/lib';
+    }
 }
 
 # Can't use Test.pm, that's a 5.005 thing.
@@ -26,7 +31,6 @@ package main;
 
 require Test::Simple;
 
-push @INC, '../t/lib';
 require Test::Simple::Catch;
 my($out, $err) = Test::Simple::Catch::caught();
 
index eca01bc..82dea28 100644 (file)
@@ -1,8 +1,10 @@
 #!perl -w
 
 BEGIN {
-    chdir 't' if -d 't';
-    @INC = '../lib';
+    if( $ENV{PERL_CORE} ) {
+        chdir 't';
+        @INC = '../lib';
+    }
 }
 
 # Can't use Test.pm, that's a 5.005 thing.
index d5d299d..a7b2624 100644 (file)
@@ -1,6 +1,8 @@
 BEGIN {
-    chdir 't' if -d 't';
-    @INC = '../lib';
+    if( $ENV{PERL_CORE} ) {
+        chdir 't';
+        @INC = '../lib';
+    }
 }
 
 use Test::More;
index 6d1ed17..1ab2a0e 100644 (file)
@@ -1,13 +1,23 @@
 BEGIN {
-    chdir 't' if -d 't';
-    @INC = '../lib';
+    if( $ENV{PERL_CORE} ) {
+        chdir 't';
+        @INC = ('../lib', 'lib');
+    }
+    else {
+        unshift @INC, 't/lib';
+    }
 }
 
 # Can't use Test.pm, that's a 5.005 thing.
 package My::Test;
 
-# This feature requires a fairly new version of Test::Harness
 BEGIN {
+    if( !$ENV{HARNESS_ACTIVE} && $ENV{PERL_CORE} ) {
+        print "1..0 # Skipped: Won't work with t/TEST\n";
+        exit 0;
+    }
+
+    # This feature requires a fairly new version of Test::Harness
     require Test::Harness;
     if( $Test::Harness::VERSION < 1.20 ) {
         print "1..0 # Skipped: Need Test::Harness 1.20 or up\n";
@@ -35,7 +45,6 @@ package main;
 
 require Test::Simple;
 
-push @INC, '../t/lib';
 require Test::Simple::Catch;
 my($out, $err) = Test::Simple::Catch::caught();
 
index 0ccc817..b39b101 100644 (file)
@@ -1,56 +1,28 @@
 BEGIN {
-    chdir 't' if -d 't';
-    @INC = '../lib';
+    if( $ENV{PERL_CORE} ) {
+        chdir 't';
+        @INC = '../lib';
+    }
 }
 
-# Can't use Test.pm, that's a 5.005 thing.
-package My::Test;
+use Test::More;
 
-print "1..2\n";
-
-my $test_num = 1;
-# Utility testing functions.
-sub ok ($;$) {
-    my($test, $name) = @_;
-    my $ok = '';
-    $ok .= "not " unless $test;
-    $ok .= "ok $test_num";
-    $ok .= " - $name" if defined $name;
-    $ok .= "\n";
-    print $ok;
-    $test_num++;
+BEGIN {
+    if( !$ENV{HARNESS_ACTIVE} && $ENV{PERL_CORE} ) {
+        plan skip_all => "Won't work with t/TEST";
+    }
 }
 
-
-package main;
-
-require Test::More;
-Test::More->import;
-my($out, $err);
-
 BEGIN {
     require Test::Harness;
 }
 
 if( $Test::Harness::VERSION < 1.20 ) {
-    plan(skip_all => 'Need Test::Harness 1.20 or up');
+    plan skip_all => 'Need Test::Harness 1.20 or up';
 }
 else {
-    push @INC, '../t/lib';
-    require Test::Simple::Catch;
-    ($out, $err) = Test::Simple::Catch::caught();
-    plan('no_plan');
+    plan 'no_plan';
 }
 
 pass('Just testing');
 ok(1, 'Testing again');
-
-END {
-    My::Test::ok($$out eq <<OUT);
-ok 1 - Just testing
-ok 2 - Testing again
-1..2
-OUT
-
-    My::Test::ok($$err eq '');
-}
index 925c04b..528df5f 100644 (file)
@@ -1,6 +1,8 @@
 BEGIN {
-    chdir 't' if -d 't';
-    @INC = '../lib';
+    if( $ENV{PERL_CORE} ) {
+        chdir 't';
+        @INC = '../lib';
+    }
 }
 
 use Test::More;
index de0f9f5..7297e9d 100644 (file)
@@ -1,6 +1,8 @@
 BEGIN {
-    chdir 't' if -d 't';
-    @INC = '../lib';
+    if( $ENV{PERL_CORE} ) {
+        chdir 't';
+        @INC = '../lib';
+    }
 }
 
 use strict;
index fb4daca..526c5ac 100644 (file)
@@ -1,8 +1,10 @@
 #!perl -w
 
 BEGIN {
-    chdir 't' if -d 't';
-    @INC = '../lib';
+    if( $ENV{PERL_CORE} ) {
+        chdir 't';
+        @INC = '../lib';
+    }
 }
 
 use Test::More tests => 15;
index e41dbc7..6f255e2 100644 (file)
@@ -1,7 +1,12 @@
 BEGIN {
-    chdir 't' if -d 't';
-    @INC = '../lib';
-}
+    if( $ENV{PERL_CORE} ) {
+        chdir 't';
+        @INC = ('../lib', 'lib');
+    }
+    else {
+        unshift @INC, 't/lib';
+    }
+}   
 
 use strict;
 
@@ -27,7 +32,6 @@ sub ok ($;$) {
 package main;
 require Test::More;
 
-push @INC, '../t/lib';
 require Test::Simple::Catch;
 my($out, $err) = Test::Simple::Catch::caught();
 
index 499229c..31ceb5f 100644 (file)
@@ -1,19 +1,21 @@
 #!perl -w
 
 BEGIN {
-    chdir 't' if -d 't';
-    @INC = '../lib';
+    if( $ENV{PERL_CORE} ) {
+        chdir 't';
+        @INC = '../lib';
+    }
 }
 
 BEGIN {
     require Test::Harness;
-    require Test::More;
+    use Test::More;
 
     if( $Test::Harness::VERSION < 1.23 ) {
-        Test::More->import(skip_all => 'Need Test::Harness 1.23 or up');
+        plan skip_all => 'Need Test::Harness 1.23 or up';
     }
     else {
-        Test::More->import(tests => 13);
+        plan tests => 15;
     }
 }
 
@@ -53,3 +55,12 @@ TODO: {
     use_ok('Fooble');
     require_ok('Fooble');
 }
+
+
+TODO: {
+    todo_skip "Just testing todo_skip", 2;
+
+    fail("Just testing todo");
+    die "todo_skip should prevent this";
+    pass("Again");
+}
index 97ae307..5251264 100644 (file)
@@ -1,15 +1,17 @@
 BEGIN {
-    chdir 't' if -d 't';
-    @INC = '../lib';
+    if( $ENV{PERL_CORE} ) {
+        chdir 't';
+        @INC = '../lib';
+    }
 }
 
 use strict;
-use Test::More tests => 10;
+use Test::More tests => 12;
 
 BEGIN { $^W = 1; }
 
 my $warnings = '';
-local $SIG{__WARN__} = sub { $warnings = join '', @_ };
+local $SIG{__WARN__} = sub { $warnings .= join '', @_ };
 
 is( undef, undef,           'undef is undef');
 is( $warnings, '',          '  no warnings' );
@@ -17,6 +19,9 @@ is( $warnings, '',          '  no warnings' );
 isnt( undef, 'foo',         'undef isnt foo');
 is( $warnings, '',          '  no warnings' );
 
+isnt( undef, '',            'undef isnt an empty string' );
+isnt( undef, 0,             'undef isnt zero' );
+
 like( undef, '/.*/',        'undef is like anything' );
 is( $warnings, '',          '  no warnings' );
 
index e6e306d..f1d7bed 100644 (file)
@@ -1,6 +1,8 @@
 BEGIN {
-    chdir 't' if -d 't';
-    @INC = '../lib';
+    if( $ENV{PERL_CORE} ) {
+        chdir 't';
+        @INC = '../lib';
+    }
 }
 
 use Test::More tests => 7;
index 5e5420a..c4ce507 100644 (file)
@@ -1,6 +1,8 @@
 BEGIN {
-    chdir 't' if -d 't';
-    @INC = '../lib';
+    if( $ENV{PERL_CORE} ) {
+        chdir 't';
+        @INC = '../lib';
+    }
 }
 
 use Test::More tests => 5;
index bd5b91d..e07ca32 100644 (file)
@@ -137,8 +137,8 @@ So now you'd see...
 =head2 Test the manual
 
 Simplest way to build up a decent testing suite is to just test what
-the manual says it does. [3] Let's pull something out of the
-L<Date::ICal/SYNOPSIS> and test that all it's bits work.
+the manual says it does. [3] Let's pull something out of the 
+L<Date::ICal/SYNOPSIS> and test that all its bits work.
 
     #!/usr/bin/perl -w