Test::Group - Group together related tests in a test suite

    use Test::More no_plan => 1;
    use Test::Group;

    test "hammering the server" => sub {
        ok(I_can_connect);
        for(1..1000) {
           ok(I_can_make_a_request);
        }
    }; # Don't forget the semicolon here!

    use Test::More no_plan => 1;
    use Test::Group;

    test "this test group will fail", sub {
        ok 1, "sub test blah";
        is "foo", "bar", "I so wish they were the same...";
        ok 1;
        like   "blah blah blah", qr/bla/;
    };

    #   Failed test 'I so wish they were the same...'
    #   in test.pl at line 6.
    #          got: 'foo'
    #     expected: 'bar'
    not ok 1 - this test group will fail
    #   Failed test 'this test group will fail'
    #   in test.pl at line 9.
    1..1

    test "this test will fail but the suite will proceed", sub {
        pass;
        die;
    };

    test "a test with TODO in the name is marked TODO" => sub {
          pass("this part is done");
          fail("but I'm not finished with this one yet");
    };

    {
      local $TODO = "Test::More's good old method also works";
      test "this test is not finished yet" => sub {
          pass;
          fail;
      };
    };

    # Don't catch exceptions raised in test groups later on
    Test::Group->dont_catch_exceptions;

    # log caught exceptions in /tmp/log
    Test::Group->logfile("/tmp/log");

    # skip the next group of test
    skip_next_test "network not available" if (! Network->available());
    test "bla", sub {
        my $ftp = Net::FTP->new("some.host.name");
        # ...
    };

    begin_skipping_tests "reason";

    test "this test will not run" => sub {
        # ...
    };

    end_skipping_tests;

    # from now on, skip all tests whose names do not match /bla/
    test_only qr/bla/;

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

    sub foobar_ok {
        my ($text, $name) = @_;
        $name ||= "foobar_ok";
        local $Test::Builder::Level = $Test::Builder::Level + 1;
        test $name => sub {
           local $Test::Group::InPredicate = 1;
           like($text, qr/foo/, "foo ok");
           like($text, qr/bar/, "bar ok");
        };
    }

   test "something" => sub {
       local $TODO = "this test does not work yet";
       pass;                                         # GOTCHA!
       fail;
   };

   test "something" => sub {
       pass;
       {
          local $TODO = "this part does not work yet";
          fail;
       }
   };

    {
      local $TODO = "not quite done yet";
      test "foo" => sub {
          fail;
          pass;              # NOT an unexpected success, as
                             # this is simply a subtest of the whole
                             # test "foo", which will fail.
      };
    }

    skip_next_tests 1;
    skip_next_tests 1, $reason;

    begin_skipping_tests;
    begin_skipping_tests "reason";

    test_only "bla()", "reason";
    test_only qr/^bla/;
    test_only sub { /bla/ };

    test_only;

   Test::Group->foo(@args);

  eval { Test::Group->use_subtest };

#!/usr/bin/perl -w
# -*- coding: utf-8; -*-
#
# (C)-IDEALX

package Test::Group;
use strict;
use warnings;

use vars qw($VERSION);
$VERSION = '0.18';

use 5.004;

use Test::Simple;
use Test::Builder;
BEGIN { die "Need Test::Simple version 0.59 or later, sorry"
            unless Test::Builder->can("create"); }
use IO::File;
use File::Spec;

my $classstate_verbose = $ENV{PERL_TEST_GROUP_VERBOSE};
my $classstate_skipcounter;
my $classstate_skipreason;
my $classstate_testonly_reason;
my $classstate_testonly_criteria = sub { 1 };
my $classstate_catchexceptions = 1;
my $classstate_logfile;
my $classstate_logfd;
my @classstate_plugins;
my $classstate_use_subtest;

our $Level = 0;
# $Test::Group::Level is effectively added to $Test::Builder::Level.
# Do not use it, it is present for backward compatibility only.
# Use $Test::Builder::Level instead.

our $InPredicate;

use Exporter;
use vars qw(@ISA @EXPORT @EXPORT_OK);
@ISA       = qw(Exporter);
@EXPORT    = qw(test skip_next_test skip_next_tests
                begin_skipping_tests end_skipping_tests
                test_only);
@EXPORT_OK = qw(next_test_plugin);

sub test ($&) {
    my ($name, $code) = @_;

    my ($callerpackage) = caller(0);

    my $Test = Test::Builder->new; # This is a singleton actually -
    # it should read "Test::Builder->the()" with permission from
    # Michael Schwern :-)

    my $subTest = Test::Group::_Runner->new($name, $callerpackage, $code);
    $subTest->run();

    if ($subTest->is_skipped) {
        $Test->skip($subTest->skip_reason);
        return;
    }

    if ($subTest->got_exception) {
        my $exn = $subTest->exception();
        my $exntext =
            ( ! defined $exn ? "an undefined exception" :
              eval { $exn->can("stringify") } ? $exn->stringify :
              (ref($exn) && $Data::Dumper::VERSION ) ? do {
                  no warnings "once";
                  local $Data::Dumper::Indent = 1;
                  local $Data::Dumper::Terse = 1;
                  Data::Dumper::Dumper($exn) } :
               "$exn" ? "$exn" : "a blank exception" );
        { local $/ = ""; chomp($exntext); }
        my $message = <<"MESSAGE";
Test ``$name'' died:
$exntext
MESSAGE
        if ($classstate_logfd) {
            print $classstate_logfd $message;
            $Test->diag("test ``$name'' died - "
                    . "see log file: ``$classstate_logfile''");
        } else {
            $Test->diag($message);
        };
        $name = "*died* $name";
    }

    return $subTest->{result} if exists $subTest->{result};

    no warnings "redefine";
    my ($OK, $TODO_string) = $subTest->as_Test_Builder_params;
    # I tried to put a "local $TODO = " here, but that didn't work and
    # I lack the patience to dig up the whole story about
    # Test::Builder->caller not doing The Right Thing here (yet
    # elsewhere it does when it apparently shouldn't, e.g. in
    # L</run>).  So here goes a sleazy local-method trick to get the
    # TODO status across to Test::Builder; the trick has an adherence
    # in L</ok>, which see.
    local *Test::Builder::todo = sub { $TODO_string };
    local $Test::Builder::Level = $Test::Builder::Level + $Level;
    $Test->ok($OK, $name);
    return $OK ? 1 : 0;
}

sub skip_next_tests {
    my ($counter, $reason) = @_;
    $classstate_skipcounter = $counter unless
      ($classstate_skipcounter && $classstate_skipcounter > $counter);
    $classstate_skipreason  = $reason;
    return 1;
}

sub skip_next_test {
    skip_next_tests 1, @_;
}

sub begin_skipping_tests {
    my ($reason) = @_;
    $classstate_skipcounter = -1;
    $classstate_skipreason = $reason;
    return 1;
}

sub end_skipping_tests {
    $classstate_skipcounter = 0;
    return 1;
}

sub test_only (;$$) {
    my ($criteria, $reason) = @_;

    $classstate_testonly_reason = $reason;

    if (!defined $criteria) {
        $classstate_testonly_criteria = sub { 1 };
    } elsif (!ref $criteria) {
        $classstate_testonly_criteria = sub { $_[0] eq $criteria };
    } elsif (ref $criteria eq "Regexp") {
        $classstate_testonly_criteria = sub { $_[0] =~ /$criteria/ };
    } elsif (ref $criteria eq "CODE") {
        $classstate_testonly_criteria = $criteria;
    }
}

sub next_test_plugin (&) {
    my $plugin = shift;

    push @classstate_plugins, $plugin;
}

sub verbose { shift; $classstate_verbose = shift }

sub catch_exceptions { $classstate_catchexceptions = 1; }
sub dont_catch_exceptions { $classstate_catchexceptions = 0; }

sub logfile {
    my $class = shift;
    $classstate_logfile  = shift;
    $classstate_logfd    = new IO::File("> $classstate_logfile") or
        die "Cannot open $classstate_logfile";
}

sub use_subtest {
    Test::Builder->new->can('subtest') or die
                                "Test::Builder too old for use_subtest()\n";
    $classstate_use_subtest = 1;
}
   

sub no_subtest {
    $classstate_use_subtest = 0;
}

package Test::Group::_Runner;

sub new {
    my ($class, $name, $callerpackage, $code) = @_;

    my $self = bless {
                      name          => $name,
                      callerpackage => $callerpackage,
                      code          => $code,
                      subtests      => [],
                     }, $class;
    # Stash the TODO state on behalf of L</as_Test_Builder_params>,
    # coz we're going to muck with $TODO soon.  Warning, ->todo
    # returns 0 instead of undef if there is no TODO block active:
    my $T = Test::Builder->new;
    my $current_todo = $T->todo($callerpackage);
    $self->{in_todo} = $current_todo if $current_todo;

    # For testability: test groups run inside a mute group are mute as
    # well.
    $self->mute(1) if ($class->current &&
                       $class->current->mute);

    return $self;
}

sub run {
    my ($self) = @_;

    if ($classstate_skipcounter) {
        $classstate_skipcounter--;
        $self->_skip($classstate_skipreason);
        undef $classstate_skipreason unless $classstate_skipcounter;
        return $self;
    } elsif (! $classstate_testonly_criteria->($self->{name})) {
        $self->_skip($classstate_testonly_reason);
        return $self;
    }

    Test::Builder->new->diag("Running group of tests - $self->{name}")
        if ($classstate_verbose);

    my $code = $self->{code};
    if (my @plugins = @classstate_plugins) {
        $code = sub { $self->_run_code_via_plugins(@plugins) };
        @classstate_plugins = ();
    }

    if ($classstate_use_subtest) {
        my $level = $Test::Builder::Level + $Level + 1;
        local $Test::Builder::Level = $level;
        $self->{result} = Test::Builder->new->subtest(
            $self->{name} => sub {
                $code->();
                Test::Builder->new->done_testing;

                # Work around a flaw in Test::Builder 0.94, see
                # http://code.google.com/p/test-more/issues/detail?id=58
                $Test::Builder::Level = $level + 2;
            }
        );
    } else {
        # Reset $Test::Builder::Level to the default when running the inner
        # test code. Otherwise, the file/line diagnostics of failing tests
        # within the group would be messed up if test() is called with a
        # non-default $Test::Builder::Level value.
        local $Test::Builder::Level = 1;

        $self->_hijack();    # BEGIN CRITICAL SECTION
        my $exception_raised = !
            $self->_run_with_local_TODO($self->{callerpackage}, $code);
        $self->_unhijack();  # END CRITICAL SECTION

        if ($exception_raised) {
            if ($classstate_catchexceptions) {
                $self->_record_exception();
            } else {
                die $@; # Rethrow
            }
        }
    }

    return; # No useful return value yet
}

{
    my $current;

    sub current {
        if (@_ == 1) {
            return $current;
        } else {
            $current = $_[1];
        }
    }
}

sub orig_blessed {
    my $self = shift;
    return $self->{reblessed_from} if defined $self->{reblessed_from};
    # Calls recursively:
    return $self->{parent}->orig_blessed if defined $self->{parent};
    return; # Object not completely constructed, should not happen
}

sub mute {
    my ($self, @mute) = @_;
    if (@mute) {
        $self->{mute} = $mute[0];
    } else {
        return $self->{mute};
    }
}

# The code was copied over from L<Test::Builder/ok>, and then
# simplified and refactored.
sub ok {
    my ($self, $status, $testname) = @_;

    # Coerce the arguments into being actual scalars (not objects)
    $status = $status ? 1 : 0;
    $testname = substr($testname, 0) if defined $testname; # Stringifies

    # Use the actual Test::Builder->todo to get at the TODO status.
    # This is both elegant and necessary for recursion, because
    # L</test> localizes this same method in order to fool
    # Test::Builder about the TODO state.
    my $T = Test::Builder->new;
    my($pack, $file, $line) = $T->caller;

    my $todo = $T->todo($pack) || undef;
    $todo = substr($todo, 0) if $todo; # Stringifies

    my $result = { status => $status };
    $result->{todo} = $todo if defined($todo);
    push @{$self->{subtests}}, $result;

    if ($classstate_verbose and $classstate_verbose >= 2) {
	my $nums .= $self->_fully_qualified_test_number;
	if ($nums =~ tr/.// < $classstate_verbose) {
	    my $line = ($status ? '' : 'not ') . "ok $nums";
	    $line .= " $testname" if defined $testname;
	    $T->diag($line);
	}
    }

    # Report failures only, as Test::Builder would
    if( ! $status && ! $self->mute ) {
        my $msg = $todo ? "Failed (TODO)" : "Failed";

	if( defined $testname ) {
	    $T->diag(qq[  $msg test '$testname'\n]);
	    unless ($InPredicate) {
		$T->diag(qq[  in $file at line $line.\n]);
	    }
	} else {
	    $T->diag(qq[  $msg test in $file at line $line.\n]);
	}
    }

    return $status;
}


sub skip {
    my ($self, $reason) = @_;
    push @{$self->{subtests}}, { status => 1 };
}

sub diag {
    my ($self, @msgs) = @_;
    return if ($self->{mute});
    my $origdiag = Test::Builder->can("diag");
    $origdiag->(Test::Builder->new, @msgs);
}

sub subtests { @{shift->{subtests}} }

sub unexcused_failure_subtests {
    grep { (! $_->{status}) && ! exists($_->{todo}) }
        (shift->subtests);
}

sub unexpected_success_subtests {
    grep { $_->{status} && exists($_->{todo}) } (shift->subtests);
}

sub todo_subtests {
    grep { exists $_->{todo} } (shift->subtests)
}

sub got_exception { defined shift->{exception} }

sub exception { shift->{exception} }

sub is_skipped { exists shift->{skipreason} }
sub skip_reason { shift->{skipreason} }

sub as_Test_Builder_params {
    my ($self) = @_;

    die <<"MESSAGE" if ! wantarray;
INCORRECT CALL: array context only for this method.
MESSAGE

    my ($OK, $TODO_string);
    if ($self->is_skipped) {
        die <<"MESSAGE";
INCORRECT CALL: this method should not be called for skipped tests
MESSAGE
    } elsif ($self->got_exception ||
             !($self->subtests) ||
             $self->unexcused_failure_subtests) {
        ($OK, $TODO_string) = (0, undef);
    } elsif ($self->unexpected_success_subtests) {
        ($OK, $TODO_string) = (1, $self->_make_todo_string
                               ($self->unexpected_success_subtests));
    } elsif ($self->todo_subtests) {
        ($OK, $TODO_string) =
            (0, $self->_make_todo_string($self->todo_subtests));
    } else {
        ($OK, $TODO_string) = (1, undef); # Hurray!
    }
    if (! defined $TODO_string) {
        $TODO_string = $self->{name} if $self->{name} =~ m/\bTODO\b/;
        $TODO_string = $self->{in_todo} if $self->{in_todo};
    }
    return ($OK, $TODO_string);
}

sub _hijack {
    my ($self) = @_;

    my $class = ref($self);
    if (defined $class->current) {    # Nested hijack
        $self->{parent} = $class->current;
    } else {                          # Top-level hijack
        $self->{orig_testbuilder} = Test::Builder->new;
        $self->{reblessed_from} = ref($self->{orig_testbuilder});
        bless($self->{orig_testbuilder},
              "Test::Builder::_HijackedByTestGroup");
    }

    # The following line of code must be executed immediately after
    # the reblessing above, as the delegating stubs (L</ok>, L</skip>
    # and L</diag> below) need ->current() to be set to work:
    $class->current($self);
}

sub _unhijack {
    my ($self) = @_;
    if (defined($self->{orig_testbuilder})) { # Top-level unhijack
        $self->current(undef);
        bless $self->{orig_testbuilder}, $self->{reblessed_from};
    } else {
        # Nested unhijack
        $self->current($self->{parent});
    }
    1;
}

sub _fully_qualified_test_number {
    my $self = shift;

    my @nums;
    my $runner = $self->current;
    while ($runner) {
	unshift @nums, 1+scalar $runner->subtests;
	$runner = $runner->{parent};
    }
    --$nums[-1] if @nums;
    return join '.', 1+Test::Builder->new->current_test, @nums;
}

sub _run_with_local_TODO {
    my ($self, $callerpackage, $sub) = @_;
    ## Locally sets $TODO to undef, see POD snippet "TODO gotcha 2".
    ## I used to do
    #     no strict 'refs';
    #     local ${$callerpackage . '::TODO' };
    ## but this doesn't work in 5.6 ("Can't localize through a reference")
    my $TODOref = do { no strict "refs"; \${$callerpackage . '::TODO' } };
    my $TODOorig = $$TODOref;
    $$TODOref = undef;

    my $retval = eval { $sub->(); 1; };
    $$TODOref = $TODOorig;
    return $retval;
}

sub _run_code_via_plugins {
    my ($self, $plugin, @more) = @_;

    if ($plugin) {
        my $old_inp = $InPredicate;
        local $InPredicate = 1;
        $plugin->(sub{
            local $InPredicate = $old_inp;
            $self->_run_code_via_plugins(@more);
        });
    } else {
        $self->{code}->();
    }
}

sub _skip {
    my ($self, $reason) = @_;

    $self->{skipreason} = $reason;
}

sub _record_exception {
    my ($self) = @_;
    $self->{exception} =
        (  (ref($@) || (defined($@) && length($@) > 0)) ? $@ :
           # Factor L<Error> in (TODO: add L<Exception::Class> as
           # well):
           defined($Error::THROWN) ? $Error::THROWN :
           undef  );
}

sub _make_todo_string {
    my ($self, @subtests) = @_;
    return join(", ", map { $_->{todo} || "(no TODO explanation)" }
                @subtests);
}

package Test::Builder::_HijackedByTestGroup;
use base "Test::Builder";

foreach my $delegated (qw(ok skip diag)) {
    no strict "refs";
    *{$delegated} = sub {
        my $self = shift;
        unshift(@_, Test::Group::_Runner->current);
        goto &{"Test::Group::_Runner::".$delegated};
    };
}

1;