Test::Simple/More/Builder 0.42 -> 0.44

Message-ID: <20020425053210.GA3334@blackrider>

p4raw-id: //depot/perl@16154

diff --git a/MANIFEST b/MANIFEST
index d15f08b..f48cccf 100644 (file)
--- a/MANIFEST
+++ b/MANIFEST
@@ -1427,6 +1427,7 @@ lib/Test/Simple/Changes           Test::Simple changes
 lib/Test/Simple/README         Test::Simple README
 lib/Test/Simple/t/buffer.t      Test::Builder buffering test
 lib/Test/Simple/t/Builder.t     Test::Builder tests
 lib/Test/Simple/README         Test::Simple README
 lib/Test/Simple/t/buffer.t      Test::Builder buffering test
 lib/Test/Simple/t/Builder.t     Test::Builder tests

+lib/Test/Simple/t/curr_test.t   Test::Builder->curr_test tests

 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/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


@@ -1436,6 +1437,7 @@ lib/Test/Simple/t/fail.t        Test::Simple test, test failures
 lib/Test/Simple/t/filehandles.t Test::Simple test, STDOUT can be played with
 lib/Test/Simple/t/import.t      Test::More test, importing functions
 lib/Test/Simple/t/is_deeply.t   Test::More test, is_deeply()
 lib/Test/Simple/t/filehandles.t Test::Simple test, STDOUT can be played with
 lib/Test/Simple/t/import.t      Test::More test, importing functions
 lib/Test/Simple/t/is_deeply.t   Test::More test, is_deeply()

+lib/Test/Simple/t/maybe_regex.t Test::Builder->maybe_regex() tests

 lib/Test/Simple/t/missing.t     Test::Simple test, missing tests
 lib/Test/Simple/t/More.t        Test::More test, basic stuff
 lib/Test/Simple/t/no_ending.t   Test::Builder test, no_ending()
 lib/Test/Simple/t/missing.t     Test::Simple test, missing tests
 lib/Test/Simple/t/More.t        Test::More test, basic stuff
 lib/Test/Simple/t/no_ending.t   Test::Builder test, no_ending()


@@ -1449,6 +1451,7 @@ lib/Test/Simple/t/plan_skip_all.t       Test::More test, plan() w/skip_all
 lib/Test/Simple/t/simple.t      Test::Simple test, basic stuff
 lib/Test/Simple/t/skip.t        Test::More test, SKIP tests
 lib/Test/Simple/t/skipall.t     Test::More test, skip all tests
 lib/Test/Simple/t/simple.t      Test::Simple test, basic stuff
 lib/Test/Simple/t/skip.t        Test::More test, SKIP tests
 lib/Test/Simple/t/skipall.t     Test::More test, skip all tests

+lib/Test/Simple/t/strays.t      Test::Builder stray newline checks

 lib/Test/Simple/t/todo.t        Test::More test, TODO tests
 lib/Test/Simple/t/undef.t       Test::More test, undefs don't cause warnings
 lib/Test/Simple/t/useing.t      Test::More test, compile test
 lib/Test/Simple/t/todo.t        Test::More test, TODO tests
 lib/Test/Simple/t/undef.t       Test::More test, undefs don't cause warnings
 lib/Test/Simple/t/useing.t      Test::More test, compile test

diff --git a/lib/Test/Builder.pm b/lib/Test/Builder.pm
index da63506..7c710bf 100644 (file)
--- a/lib/Test/Builder.pm
+++ b/lib/Test/Builder.pm
@@ -8,7 +8,7 @@ $^C ||= 0;
 
 use strict;
 use vars qw($VERSION $CLASS);
 
 use strict;
 use vars qw($VERSION $CLASS);

-$VERSION = '0.12';
+$VERSION = '0.14';

 $CLASS = __PACKAGE__;
 
 my $IsVMS = $^O eq 'VMS';
 $CLASS = __PACKAGE__;
 
 my $IsVMS = $^O eq 'VMS';


@@ -55,9 +55,6 @@ Test::Builder - Backend for building test libraries
 
 =head1 DESCRIPTION
 
 
 =head1 DESCRIPTION
 

-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 I<which can
 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 I<which can


@@ -152,6 +149,12 @@ sub plan {
             die "You said to run 0 tests!  You've got to run something.\n";
         }
     }
             die "You said to run 0 tests!  You've got to run something.\n";
         }
     }

+    else {
+        require Carp;
+        my @args = grep { defined } ($cmd, $arg);
+        Carp::croak("plan() doesn't understand @args");
+    }
+        

 }
 
 =item B<expected_tests>
 }
 
 =item B<expected_tests>


@@ -239,7 +242,8 @@ sub ok {
     my($self, $test, $name) = @_;
 
     unless( $Have_Plan ) {
     my($self, $test, $name) = @_;
 
     unless( $Have_Plan ) {

-        die "You tried to run a test without a plan!  Gotta have a plan.\n";
+        require Carp;
+        Carp::croak("You tried to run a test without a plan!  Gotta have a plan.");

     }
 
     $Curr_Test++;
     }
 
     $Curr_Test++;


@@ -354,7 +358,7 @@ sub _is_diag {
         }
     }
 
         }
     }
 

-    $self->diag(sprintf <<DIAGNOSTIC, $got, $expect);
+    return $self->diag(sprintf <<DIAGNOSTIC, $got, $expect);

          got: %s
     expected: %s
 DIAGNOSTIC
          got: %s
     expected: %s
 DIAGNOSTIC


@@ -443,25 +447,57 @@ sub unlike {
     $self->_regex_ok($this, $regex, '!~', $name);
 }
 
     $self->_regex_ok($this, $regex, '!~', $name);
 }
 

-sub _regex_ok {
-    my($self, $this, $regex, $cmp, $name) = @_;
+=item B<maybe_regex>

 
 

-    local $Level = $Level + 1;
+  $Test->maybe_regex(qr/$regex/);
+  $Test->maybe_regex('/$regex/');

 
 

-    my $ok = 0;
-    my $usable_regex;
+Convenience method for building testing functions that take regular
+expressions as arguments, but need to work before perl 5.005.
+
+Takes a quoted regular expression produced by qr//, or a string
+representing a regular expression.
+
+Returns a Perl value which may be used instead of the corresponding
+regular expression, or undef if it's argument is not recognised.
+
+For example, a version of like(), sans the useful diagnostic messages,
+could be written as:
+
+  sub laconic_like {
+      my ($self, $this, $regex, $name) = @_;
+      my $usable_regex = $self->maybe_regex($regex);
+      die "expecting regex, found '$regex'\n"
+          unless $usable_regex;
+      $self->ok($this =~ m/$usable_regex/, $name);
+  }
+
+=cut
+
+
+sub maybe_regex {
+       my ($self, $regex) = @_;
+    my $usable_regex = undef;

     if( ref $regex eq 'Regexp' ) {
         $usable_regex = $regex;
     }
     # Check if it looks like '/foo/'
     elsif( my($re, $opts) = $regex =~ m{^ /(.*)/ (\w*) $ }sx ) {
     if( ref $regex eq 'Regexp' ) {
         $usable_regex = $regex;
     }
     # Check if it looks like '/foo/'
     elsif( my($re, $opts) = $regex =~ m{^ /(.*)/ (\w*) $ }sx ) {

-        $usable_regex = "(?$opts)$re";
-    }
-    else {
-        $ok = $self->ok( 0, $name );
+        $usable_regex = length $opts ? "(?$opts)$re" : $re;
+    };
+    return($usable_regex)
+};

 
 

-        $self->diag("    '$regex' doesn't look much like a regex to me.");
+sub _regex_ok {
+    my($self, $this, $regex, $cmp, $name) = @_;

 
 

+    local $Level = $Level + 1;
+
+    my $ok = 0;
+    my $usable_regex = $self->maybe_regex($regex);
+    unless (defined $usable_regex) {
+        $ok = $self->ok( 0, $name );
+        $self->diag("    '$regex' doesn't look much like a regex to me.");

         return $ok;
     }
 
         return $ok;
     }
 


@@ -524,7 +560,7 @@ sub _cmp_diag {
     
     $got    = defined $got    ? "'$got'"    : 'undef';
     $expect = defined $expect ? "'$expect'" : 'undef';
     
     $got    = defined $got    ? "'$got'"    : 'undef';
     $expect = defined $expect ? "'$expect'" : 'undef';

-    $self->diag(sprintf <<DIAGNOSTIC, $got, $type, $expect);
+    return $self->diag(sprintf <<DIAGNOSTIC, $got, $type, $expect);

     %s
         %s
     %s
     %s
         %s
     %s


@@ -564,7 +600,8 @@ sub skip {
     $why ||= '';
 
     unless( $Have_Plan ) {
     $why ||= '';
 
     unless( $Have_Plan ) {

-        die "You tried to run tests without a plan!  Gotta have a plan.\n";
+        require Carp;
+        Carp::croak("You tried to run tests without a plan!  Gotta have a plan.");

     }
 
     $Curr_Test++;
     }
 
     $Curr_Test++;


@@ -598,7 +635,8 @@ sub todo_skip {
     $why ||= '';
 
     unless( $Have_Plan ) {
     $why ||= '';
 
     unless( $Have_Plan ) {

-        die "You tried to run tests without a plan!  Gotta have a plan.\n";
+        require Carp;
+        Carp::croak("You tried to run tests without a plan!  Gotta have a plan.");

     }
 
     $Curr_Test++;
     }
 
     $Curr_Test++;


@@ -607,7 +645,7 @@ sub todo_skip {
 
     my $out = "not ok";
     $out   .= " $Curr_Test" if $self->use_numbers;
 
     my $out = "not ok";
     $out   .= " $Curr_Test" if $self->use_numbers;

-    $out   .= " # TODO $why\n";
+    $out   .= " # TODO & SKIP $why\n";

 
     $Test->_print($out);
 
 
     $Test->_print($out);
 


@@ -765,6 +803,14 @@ already.
 
 We encourage using this rather than calling print directly.
 
 
 We encourage using this rather than calling print directly.
 

+Returns false.  Why?  Because diag() is often used in conjunction with
+a failing test (C<ok() || diag()>) it "passes through" the failure.
+
+    return ok(...) || diag(...);
+
+=for blame transfer
+Mark Fowler <mark@twoshortplanks.com>
+

 =cut
 
 sub diag {
 =cut
 
 sub diag {


@@ -776,6 +822,7 @@ sub diag {
 
     # Escape each line with a #.
     foreach (@msgs) {
 
     # Escape each line with a #.
     foreach (@msgs) {

+        $_ = 'undef' unless defined;

         s/^/# /gms;
     }
 
         s/^/# /gms;
     }
 


@@ -785,6 +832,8 @@ sub diag {
     my $fh = $self->todo ? $self->todo_output : $self->failure_output;
     local($\, $", $,) = (undef, ' ', '');
     print $fh @msgs;
     my $fh = $self->todo ? $self->todo_output : $self->failure_output;
     local($\, $", $,) = (undef, ' ', '');
     print $fh @msgs;

+
+    return 0;

 }
 
 =begin _private
 }
 
 =begin _private


@@ -808,6 +857,15 @@ sub _print {
 
     local($\, $", $,) = (undef, ' ', '');
     my $fh = $self->output;
 
     local($\, $", $,) = (undef, ' ', '');
     my $fh = $self->output;

+
+    # Escape each line after the first with a # so we don't
+    # confuse Test::Harness.
+    foreach (@msgs) {
+        s/\n(.)/\n# $1/sg;
+    }
+
+    push @msgs, "\n" unless $msgs[-1] =~ /\n\Z/;
+

     print $fh @msgs;
 }
 
     print $fh @msgs;
 }
 


@@ -933,9 +991,16 @@ sub current_test {
     my($self, $num) = @_;
 
     if( defined $num ) {
     my($self, $num) = @_;
 
     if( defined $num ) {

+
+        unless( $Have_Plan ) {
+            require Carp;
+            Carp::croak("Can't change the current test number without a plan!");
+        }
+

         $Curr_Test = $num;
         if( $num > @Test_Results ) {
         $Curr_Test = $num;
         if( $num > @Test_Results ) {

-            for ($#Test_Results..$num-1) {
+            my $start = @Test_Results ? $#Test_Results : 0;
+            for ($start..$num-1) {

                 $Test_Results[$_] = 1;
             }
         }
                 $Test_Results[$_] = 1;
             }
         }

diff --git a/lib/Test/More.pm b/lib/Test/More.pm
index c335187..b97f967 100644 (file)
--- a/lib/Test/More.pm
+++ b/lib/Test/More.pm
@@ -18,7 +18,7 @@ sub _carp {
 
 require Exporter;
 use vars qw($VERSION @ISA @EXPORT %EXPORT_TAGS $TODO);
 
 require Exporter;
 use vars qw($VERSION @ISA @EXPORT %EXPORT_TAGS $TODO);

-$VERSION = '0.42';
+$VERSION = '0.44';

 @ISA    = qw(Exporter);
 @EXPORT = qw(ok use_ok require_ok
              is isnt like unlike is_deeply
 @ISA    = qw(Exporter);
 @EXPORT = qw(ok use_ok require_ok
              is isnt like unlike is_deeply


@@ -176,16 +176,18 @@ sub plan {
     my $caller = caller;
 
     $Test->exported_to($caller);
     my $caller = caller;
 
     $Test->exported_to($caller);

-    $Test->plan(@plan);

 
     my @imports = ();
     foreach my $idx (0..$#plan) {
         if( $plan[$idx] eq 'import' ) {
 
     my @imports = ();
     foreach my $idx (0..$#plan) {
         if( $plan[$idx] eq 'import' ) {

-            @imports = @{$plan[$idx+1]};
+            my($tag, $imports) = splice @plan, $idx, 2;
+            @imports = @$imports;

             last;
         }
     }
 
             last;
         }
     }
 

+    $Test->plan(@plan);
+

     __PACKAGE__->_export_to_level(1, __PACKAGE__, @imports);
 }
 
     __PACKAGE__->_export_to_level(1, __PACKAGE__, @imports);
 }
 


@@ -455,7 +457,7 @@ as one test.  If you desire otherwise, use:
 
 sub can_ok ($@) {
     my($proto, @methods) = @_;
 
 sub can_ok ($@) {
     my($proto, @methods) = @_;

-    my $class= ref $proto || $proto;
+    my $class = ref $proto || $proto;

 
     unless( @methods ) {
         my $ok = $Test->ok( 0, "$class->can(...)" );
 
     unless( @methods ) {
         my $ok = $Test->ok( 0, "$class->can(...)" );


@@ -465,10 +467,9 @@ sub can_ok ($@) {
 
     my @nok = ();
     foreach my $method (@methods) {
 
     my @nok = ();
     foreach my $method (@methods) {

-        my $test = "'$class'->can('$method')";

         local($!, $@);  # don't interfere with caller's $@
                         # eval sometimes resets $!
         local($!, $@);  # don't interfere with caller's $@
                         # eval sometimes resets $!

-        eval $test || push @nok, $method;
+        eval { $proto->can($method) } || push @nok, $method;

     }
 
     my $name;
     }
 
     my $name;


@@ -645,7 +646,7 @@ C<use_ok> and C<require_ok>.
    BEGIN { use_ok($module, @imports); }
 
 These simply use the given $module and test to make sure the load
    BEGIN { use_ok($module, @imports); }
 
 These simply use the given $module and test to make sure the load

-happened ok.  It is recommended that you run use_ok() inside a BEGIN
+happened ok.  It's recommended that you run use_ok() inside a BEGIN

 block so its functions are exported at compile-time and prototypes are
 properly honored.
 
 block so its functions are exported at compile-time and prototypes are
 properly honored.
 


@@ -670,7 +671,7 @@ sub use_ok ($;@) {
     eval <<USE;
 package $pack;
 require $module;
     eval <<USE;
 package $pack;
 require $module;

-$module->import(\@imports);
+'$module'->import(\@imports);

 USE
 
     my $ok = $Test->ok( !$@, "use $module;" );
 USE
 
     my $ok = $Test->ok( !$@, "use $module;" );


@@ -764,12 +765,12 @@ easiest way to illustrate:
 
 If pigs cannot fly, the whole block of tests will be skipped
 completely.  Test::More will output special ok's which Test::Harness
 
 If pigs cannot fly, the whole block of tests will be skipped
 completely.  Test::More will output special ok's which Test::Harness

-interprets as skipped tests.  It is important to include $how_many tests
+interprets as skipped tests.  It's 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>, in which case you can leave $how_many off if
 you like).
 
 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).
 

-It is perfectly safe to nest SKIP blocks.
+It's 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
 
 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


@@ -849,7 +850,7 @@ When the block is empty, delete it.
         ...normal testing code...
     }
 
         ...normal testing code...
     }
 

-With todo tests, it is best to have the tests actually run.  That way
+With todo tests, it's best to have the tests actually run.  That way

 you'll know when they start passing.  Sometimes this isn't possible.
 Often a failing test will cause the whole program to die or hang, even
 inside an C<eval BLOCK> with and using C<alarm>.  In these extreme
 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


@@ -1181,7 +1182,7 @@ magic side-effects are kept to a minimum.  WYSIWYG.
 =head1 SEE ALSO
 
 L<Test::Simple> if all this confuses you and you just want to write
 =head1 SEE ALSO
 
 L<Test::Simple> if all this confuses you and you just want to write

-some tests.  You can upgrade to Test::More later (it is forward
+some tests.  You can upgrade to Test::More later (it's forward

 compatible).
 
 L<Test::Differences> for more ways to test complex data structures.
 compatible).
 
 L<Test::Differences> for more ways to test complex data structures.

diff --git a/lib/Test/Simple.pm b/lib/Test/Simple.pm
index 1f50036..ee59bd3 100644 (file)
--- a/lib/Test/Simple.pm
+++ b/lib/Test/Simple.pm
@@ -4,7 +4,7 @@ use 5.004;
 
 use strict 'vars';
 use vars qw($VERSION);
 
 use strict 'vars';
 use vars qw($VERSION);

-$VERSION = '0.42';
+$VERSION = '0.44';

 
 
 use Test::Builder;
 
 
 use Test::Builder;


@@ -61,8 +61,8 @@ You must have a plan.
   ok( $foo eq $bar, $name );
   ok( $foo eq $bar );
 
   ok( $foo eq $bar, $name );
   ok( $foo eq $bar );
 

-ok() is given an expression (in this case C<$foo eq $bar>).  If it is
-true, the test passed.  If it is false, it didn't.  That's about it.
+ok() is given an expression (in this case C<$foo eq $bar>).  If it's
+true, the test passed.  If it's false, it didn't.  That's about it.

 
 ok() prints out either "ok" or "not ok" along with a test number (it
 keeps track of that for you).
 
 ok() prints out either "ok" or "not ok" along with a test number (it
 keeps track of that for you).


@@ -73,7 +73,7 @@ keeps track of that for you).
 If you provide a $name, that will be printed along with the "ok/not
 ok" to make it easier to find your test when if fails (just search for
 the name).  It also makes it easier for the next guy to understand
 If you provide a $name, that will be printed along with the "ok/not
 ok" to make it easier to find your test when if fails (just search for
 the name).  It also makes it easier for the next guy to understand

-what your test is for.  It is highly recommended you use test names.
+what your test is for.  It's highly recommended you use test names.

 
 All tests are run in scalar context.  So this:
 
 
 All tests are run in scalar context.  So this:
 


@@ -112,7 +112,7 @@ So the exit codes are...
 If you fail more than 254 tests, it will be reported as 254.
 
 This module is by no means trying to be a complete testing system.
 If you fail more than 254 tests, it will be reported as 254.
 
 This module is by no means trying to be a complete testing system.

-It's just to get you started.  Once you're off the ground it is
+It's just to get you started.  Once you're off the ground its

 recommended you look at L<Test::More>.
 
 
 recommended you look at L<Test::More>.
 
 

diff --git a/lib/Test/Simple/Changes b/lib/Test/Simple/Changes
index 2de6efc..38cbb48 100644 (file)
--- a/lib/Test/Simple/Changes
+++ b/lib/Test/Simple/Changes
@@ -1,5 +1,22 @@
 Revision history for Perl extension Test::Simple
 
 Revision history for Perl extension Test::Simple
 

+0.44  Thu Apr 25 00:27:27 EDT 2002
+    - names containing newlines no longer produce confusing output
+      (from chromatic)
+    - chromatic provided a fix so can_ok() honors can() overrides.
+    - Nick Ing-Simmons suggested todo_skip() be a bit clearer about
+      the skipping part.
+    - Making plan() vomit if it gets something it doesn't understand.
+    - Tatsuhiko Miyagawa fixed use_ok() with pragmata on older perls.
+    - quieting diag(undef)
+
+0.43  Thu Apr 11 22:55:23 EDT 2002
+    - Adrian Howard added TB->maybe_regex()
+    - Adding Mark Fowler's suggestion to make diag() return
+      false.
+    - TB->current_test() still not working when no tests were run via
+      TB itself.  Fixed by Dave Rolsky.
+

 0.42  Wed Mar  6 15:00:24 EST 2002
     - Setting Test::Builder->current_test() now works (see what happens
       when you forget to test things?)
 0.42  Wed Mar  6 15:00:24 EST 2002
     - Setting Test::Builder->current_test() now works (see what happens
       when you forget to test things?)

diff --git a/lib/Test/Simple/t/Builder.t b/lib/Test/Simple/t/Builder.t
index a5bfd15..e10252e 100644 (file)
--- a/lib/Test/Simple/t/Builder.t
+++ b/lib/Test/Simple/t/Builder.t
@@ -10,7 +10,7 @@ BEGIN {
 use Test::Builder;
 my $Test = Test::Builder->new;
 
 use Test::Builder;
 my $Test = Test::Builder->new;
 

-$Test->plan( tests => 7 );
+$Test->plan( tests => 9 );

 
 my $default_lvl = $Test->level;
 $Test->level(0);
 
 my $default_lvl = $Test->level;
 $Test->level(0);


@@ -28,3 +28,9 @@ $Test->current_test( $test_num );
 print "ok $test_num - current_test() set\n";
 
 $Test->ok( 1, 'counter still good' );
 print "ok $test_num - current_test() set\n";
 
 $Test->ok( 1, 'counter still good' );

+
+eval { $Test->plan(7); };
+$Test->like( $@, q{/^plan\(\) doesn't understand 7/}, 'bad plan()' );
+
+eval { $Test->plan(wibble => 7); };
+$Test->like( $@, q{/^plan\(\) doesn't understand wibble 7/}, 'bad plan()' );

diff --git a/lib/Test/Simple/t/More.t b/lib/Test/Simple/t/More.t
index bee2fb4..df8c5fe 100644 (file)
--- a/lib/Test/Simple/t/More.t
+++ b/lib/Test/Simple/t/More.t
@@ -7,7 +7,7 @@ BEGIN {
     }
 }
 
     }
 }
 

-use Test::More tests => 37;
+use Test::More tests => 41;

 
 # Make sure we don't mess with $@ or $!.  Test at bottom.
 my $Err   = "this should not be touched";
 
 # Make sure we don't mess with $@ or $!.  Test at bottom.
 my $Err   = "this should not be touched";


@@ -38,11 +38,28 @@ can_ok('Test::More', qw(require_ok use_ok ok is isnt like skip can_ok
 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));
 
 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');
 
 
 isa_ok(bless([], "Foo"), "Foo");
 isa_ok([], 'ARRAY');
 isa_ok(\42, 'SCALAR');
 
 

+# can_ok() & isa_ok should call can() & isa() on the given object, not 
+# just class, in case of custom can()
+{
+       local *Foo::can;
+       local *Foo::isa;
+       *Foo::can = sub { $_[0]->[0] };
+       *Foo::isa = sub { $_[0]->[0] };
+       my $foo = bless([0], 'Foo');
+       ok( ! $foo->can('bar') );
+       ok( ! $foo->isa('bar') );
+       $foo->[0] = 1;
+       can_ok( $foo, 'blah');
+       isa_ok( $foo, 'blah');
+}
+
+

 pass('pass() passed');
 
 ok( eq_array([qw(this that whatever)], [qw(this that whatever)]),
 pass('pass() passed');
 
 ok( eq_array([qw(this that whatever)], [qw(this that whatever)]),

diff --git a/lib/Test/Simple/t/curr_test.t b/lib/Test/Simple/t/curr_test.t
new file mode 100644 (file)
index 0000000..edd201c
--- /dev/null
+++ b/lib/Test/Simple/t/curr_test.t
@@ -0,0 +1,11 @@
+#!/usr/bin/perl -w
+
+# Dave Rolsky found a bug where if current_test() is used and no
+# tests are run via Test::Builder it will blow up.
+
+use Test::Builder;
+$TB = Test::Builder->new;
+$TB->plan(tests => 2);
+print "ok 1\n";
+print "ok 2\n";
+$TB->current_test(2);

diff --git a/lib/Test/Simple/t/diag.t b/lib/Test/Simple/t/diag.t
index 0d6769b..453984b 100644 (file)
--- a/lib/Test/Simple/t/diag.t
+++ b/lib/Test/Simple/t/diag.t
@@ -9,7 +9,7 @@ BEGIN {
 
 use strict;
 
 
 use strict;
 

-use Test::More tests => 5;
+use Test::More tests => 7;

 
 my $Test = Test::More->builder;
 
 
 my $Test = Test::More->builder;
 


@@ -17,8 +17,10 @@ my $Test = Test::More->builder;
 my $output;
 tie *FAKEOUT, 'FakeOut', \$output;
 
 my $output;
 tie *FAKEOUT, 'FakeOut', \$output;
 

-# force diagnostic output to a filehandle, glad I added this to Test::Builder :)
+# force diagnostic output to a filehandle, glad I added this to
+# Test::Builder :)

 my @lines;
 my @lines;

+my $ret;

 {
     local $TODO = 1;
     $Test->todo_output(\*FAKEOUT);
 {
     local $TODO = 1;
     $Test->todo_output(\*FAKEOUT);


@@ -28,7 +30,7 @@ my @lines;
     push @lines, $output;
     $output = '';
 
     push @lines, $output;
     $output = '';
 

-    diag("multiple\n", "lines");
+    $ret = diag("multiple\n", "lines");

     push @lines, split(/\n/, $output);
 }
 
     push @lines, split(/\n/, $output);
 }
 


@@ -36,14 +38,16 @@ 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');
 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');

+ok( !$ret, 'diag returns false' );

 
 {
 
 {

-    local $TODO = 1;
+    $Test->failure_output(\*FAKEOUT);

     $output = '';
     $output = '';

-    diag("# foo");
+    $ret = diag("# foo");

 }
 }

+$Test->failure_output(\*STDERR);

 is( $output, "# # foo\n",   "diag() adds a # even if there's one already" );
 is( $output, "# # foo\n",   "diag() adds a # even if there's one already" );

-
+ok( !$ret,  'diag returns false' );

 
 package FakeOut;
 
 
 package FakeOut;
 

diff --git a/lib/Test/Simple/t/exit.t b/lib/Test/Simple/t/exit.t
index dcc4565..25e6259 100644 (file)
--- a/lib/Test/Simple/t/exit.t
+++ b/lib/Test/Simple/t/exit.t
@@ -54,6 +54,14 @@ my %Tests = (
 
 print "1..".keys(%Tests)."\n";
 
 
 print "1..".keys(%Tests)."\n";
 

+eval { require POSIX; &POSIX::WEXITSTATUS(0) };
+if( $@ ) {
+    *exitstatus = sub { $_[0] >> 8 };
+}
+else {
+    *exitstatus = sub { POSIX::WEXITSTATUS($_[0]) }
+}
+

 chdir 't';
 my $lib = File::Spec->catdir(qw(lib Test Simple sample_tests));
 while( my($test_name, $exit_codes) = each %Tests ) {
 chdir 't';
 my $lib = File::Spec->catdir(qw(lib Test Simple sample_tests));
 while( my($test_name, $exit_codes) = each %Tests ) {


@@ -72,7 +80,7 @@ while( my($test_name, $exit_codes) = each %Tests ) {
 
     my $file = File::Spec->catfile($lib, $test_name);
     my $wait_stat = system(qq{$Perl -"I../blib/lib" -"I../lib" -"I../t/lib" $file});
 
     my $file = File::Spec->catfile($lib, $test_name);
     my $wait_stat = system(qq{$Perl -"I../blib/lib" -"I../lib" -"I../t/lib" $file});

-    my $actual_exit = $wait_stat >> 8;
+    my $actual_exit = exitstatus($wait_stat);

 
     My::Test::ok( $actual_exit == $exit_code, 
                   "$test_name exited with $actual_exit (expected $exit_code)");
 
     My::Test::ok( $actual_exit == $exit_code, 
                   "$test_name exited with $actual_exit (expected $exit_code)");

diff --git a/lib/Test/Simple/t/maybe_regex.t b/lib/Test/Simple/t/maybe_regex.t
new file mode 100644 (file)
index 0000000..dcc84f4
--- /dev/null
+++ b/lib/Test/Simple/t/maybe_regex.t
@@ -0,0 +1,50 @@
+#!/usr/bin/perl -w
+
+BEGIN {
+    if( $ENV{PERL_CORE} ) {
+        chdir 't';
+        @INC = ('../lib', 'lib');
+    }
+    else {
+        unshift @INC, 't/lib';
+    }
+}
+
+use strict;
+use Test::More tests => 10;
+
+use Test::Builder;
+my $Test = Test::Builder->new;
+
+SKIP: {
+    skip "qr// added in 5.005", 3 if $] < 5.005;
+
+    # 5.004 can't even see qr// or it pukes in compile.
+    eval q{
+           my $r = $Test->maybe_regex(qr/^FOO$/i);
+           ok(defined $r, 'qr// detected');
+           ok(('foo' =~ /$r/), 'qr// good match');
+           ok(('bar' !~ /$r/), 'qr// bad match');
+          };
+    die $@ if $@;
+}
+
+{
+       my $r = $Test->maybe_regex('/^BAR$/i');
+       ok(defined $r, '"//" detected');
+       ok(('bar' =~ m/$r/), '"//" good match');
+       ok(('foo' !~ m/$r/), '"//" bad match');
+};
+
+{
+       my $r = $Test->maybe_regex('not a regex');
+       ok(!defined $r, 'non-regex detected');
+};
+
+
+{
+       my $r = $Test->maybe_regex('/0/');
+       ok(defined $r, 'non-regex detected');
+       ok(('f00' =~ m/$r/), '"//" good match');
+       ok(('b4r' !~ m/$r/), '"//" bad match');
+};

diff --git a/lib/Test/Simple/t/output.t b/lib/Test/Simple/t/output.t
index 82dea28..dd051c1 100644 (file)
--- a/lib/Test/Simple/t/output.t
+++ b/lib/Test/Simple/t/output.t
@@ -3,12 +3,15 @@
 BEGIN {
     if( $ENV{PERL_CORE} ) {
         chdir 't';
 BEGIN {
     if( $ENV{PERL_CORE} ) {
         chdir 't';

-        @INC = '../lib';
+        @INC = ('../lib', 'lib');
+    }
+    else {
+        unshift @INC, 't/lib';

     }
 }
 
 # Can't use Test.pm, that's a 5.005 thing.
     }
 }
 
 # Can't use Test.pm, that's a 5.005 thing.

-print "1..3\n";
+print "1..4\n";

 
 my $test_num = 1;
 # Utility testing functions.
 
 my $test_num = 1;
 # Utility testing functions.


@@ -21,8 +24,11 @@ sub ok ($;$) {
     $ok .= "\n";
     print $ok;
     $test_num++;
     $ok .= "\n";
     print $ok;
     $test_num++;

+
+    return $test;

 }
 
 }
 

+use TieOut;

 use Test::Builder;
 my $Test = Test::Builder->new();
 
 use Test::Builder;
 my $Test = Test::Builder->new();
 


@@ -55,3 +61,32 @@ close IN;
 ok($lines[1] =~ /Hello!/);
 
 unlink('foo');
 ok($lines[1] =~ /Hello!/);
 
 unlink('foo');

+
+
+# Ensure stray newline in name escaping works.
+$out = tie *FAKEOUT, 'TieOut';
+$Test->output(\*FAKEOUT);
+$Test->exported_to(__PACKAGE__);
+$Test->no_ending(1);
+$Test->plan(tests => 5);
+
+$Test->ok(1, "ok");
+$Test->ok(1, "ok\n");
+$Test->ok(1, "ok, like\nok");
+$Test->skip("wibble\nmoof");
+$Test->todo_skip("todo\nskip\n");
+
+my $output = $out->read;
+ok( $output eq <<OUTPUT ) || print STDERR $output;
+1..5
+ok 1 - ok
+ok 2 - ok
+# 
+ok 3 - ok, like
+# ok
+ok 4 # skip wibble
+# moof
+not ok 5 # TODO & SKIP todo
+# skip
+# 
+OUTPUT

diff --git a/lib/Test/Simple/t/strays.t b/lib/Test/Simple/t/strays.t
new file mode 100644 (file)
index 0000000..8d5ceca
--- /dev/null
+++ b/lib/Test/Simple/t/strays.t
@@ -0,0 +1,41 @@
+#!/usr/bin/perl -w 
+
+# Check that stray newlines in test output are probably handed.
+
+BEGIN {
+    print "1..0 # Skip not completed\n";
+    exit 0;
+}
+
+BEGIN {
+    if( $ENV{PERL_CORE} ) {
+        chdir 't';
+        @INC = ('../lib', 'lib');
+    }
+    else {
+        unshift @INC, 't/lib';
+    }
+}
+chdir 't';
+
+use TieOut;
+local *FAKEOUT;
+my $out = tie *FAKEOUT, 'TieOut';
+
+
+use Test::Builder;
+my $Test = Test::Builder->new;
+my $orig_out  = $Test->output;
+my $orig_err  = $Test->failure_output;
+my $orig_todo = $Test->todo_output;
+
+$Test->output(\*FAKEOUT);
+$Test->failure_output(\*FAKEOUT);
+$Test->todo_output(\*FAKEOUT);
+$Test->no_plan();
+
+$Test->ok(1, "name\n");
+$Test->ok(0, "foo\nbar\nbaz");
+$Test->skip("\nmoofer");
+$Test->todo_skip("foo\n\n");
+

diff --git a/lib/Test/Simple/t/undef.t b/lib/Test/Simple/t/undef.t
index 5251264..00ce8b1 100644 (file)
--- a/lib/Test/Simple/t/undef.t
+++ b/lib/Test/Simple/t/undef.t
@@ -1,12 +1,18 @@
+#!/usr/bin/perl -w
+

 BEGIN {
     if( $ENV{PERL_CORE} ) {
         chdir 't';
 BEGIN {
     if( $ENV{PERL_CORE} ) {
         chdir 't';

-        @INC = '../lib';
+        @INC = ('../lib', 'lib');
+    }
+    else {
+        unshift @INC, 't/lib';

     }
 }
 
 use strict;
     }
 }
 
 use strict;

-use Test::More tests => 12;
+use Test::More tests => 14;
+use TieOut;

 
 BEGIN { $^W = 1; }
 
 
 BEGIN { $^W = 1; }
 


@@ -41,3 +47,14 @@ eq_hash ( { foo => undef, bar => { baz => undef, moo => 23 } },
 is( $warnings, '',          'eq_hash()   no warnings' );
 
 
 is( $warnings, '',          'eq_hash()   no warnings' );
 
 

+my $tb = Test::More->builder;
+
+use TieOut;
+my $caught = tie *CATCH, 'TieOut';
+my $old_fail = $tb->failure_output;
+$tb->failure_output(\*CATCH);
+diag(undef);
+$tb->failure_output($old_fail);
+
+is( $caught->read, "# undef\n" );
+is( $warnings, '',          'diag(undef)  no warnings' );

diff --git a/lib/Test/Simple/t/use_ok.t b/lib/Test/Simple/t/use_ok.t
index f1d7bed..e944628 100644 (file)
--- a/lib/Test/Simple/t/use_ok.t
+++ b/lib/Test/Simple/t/use_ok.t
@@ -1,3 +1,5 @@
+#!/usr/bin/perl -w
+

 BEGIN {
     if( $ENV{PERL_CORE} ) {
         chdir 't';
 BEGIN {
     if( $ENV{PERL_CORE} ) {
         chdir 't';


@@ -5,7 +7,7 @@ BEGIN {
     }
 }
 
     }
 }
 

-use Test::More tests => 7;
+use Test::More tests => 10;

 
 # Using Symbol because it's core and exports lots of stuff.
 {
 
 # Using Symbol because it's core and exports lots of stuff.
 {


@@ -26,3 +28,11 @@ use Test::More tests => 7;
     ::use_ok("Symbol", qw(gensym ungensym));
     ::ok( defined &gensym && defined &ungensym,   '  multiple args' );
 }
     ::use_ok("Symbol", qw(gensym ungensym));
     ::ok( defined &gensym && defined &ungensym,   '  multiple args' );
 }

+
+{
+    package Foo::four;
+    my $warn; local $SIG{__WARN__} = sub { $warn .= shift; };
+    ::use_ok("constant", qw(foo bar));
+    ::ok( defined &foo, 'constant' );
+    ::is( $warn, undef, 'no warning');
+}