File Coverage

blib/lib/Test/Unit/TestCase.pm

Criterion	Covered	Total	%
statement	85	92	92.3
branch	8	12	66.6
condition	6	16	37.5
subroutine	27	29	93.1
pod	6	16	37.5
total	132	165	80.0

package Test::Unit::TestCase;
BEGIN {
  $Test::Unit::TestCase::VERSION = '0.25_1325'; # added by dist-tools/SetVersion.pl
}
use strict;

use base qw(Test::Unit::Test);

use Test::Unit::Debug qw(debug);
use Test::Unit::Failure;
use Test::Unit::Error;
use Test::Unit::Result;

use Devel::Symdump;
use Class::Inner;
use Error qw/:try/;

sub new {
    my $class = shift;
    my ($name) = @_;
    bless {
        __PACKAGE__ . '_name'        => $name,
        __PACKAGE__ . '_annotations' => '',
    }, $class;
}

sub annotate {
    my $self = shift;
    $self->{__PACKAGE__ . '_annotations'} .= join '', @_;
}

sub annotations { $_[0]->{__PACKAGE__ . '_annotations'} }

sub count_test_cases {
    my $self = shift;
    return 1;
}

sub create_result {
    my $self = shift;
    return Test::Unit::Result->new();
}

sub name {
    my $self = shift;
    return $self->{__PACKAGE__ . '_name'};
}

sub run {
    my $self = shift;
    debug(ref($self), "::run() called on ", $self->name, "\n");
    my ($result, $runner) = @_;
    $result ||= create_result();
    $result->run($self);
    return $result;
}

sub run_bare {
    my $self = shift;
    debug("  ", ref($self), "::run_bare() called on ", $self->name, "\n");
    $self->set_up();
    # Make sure tear_down happens if and only if set_up() succeeds.
    try {
        $self->run_test();
        1;
    }
    finally {
        $self->tear_down;
    };
}

sub run_test {
    my $self = shift;
    debug("    ", ref($self) . "::run_test() called on ", $self->name, "\n");
    my $method = $self->name();
    if ($self->can($method)) {
        debug("      running `$method'\n");
        $self->$method();
    } else {
        $self->fail("      Method `$method' not found");
    }
}

sub set_up    { 1 }

sub tear_down { 1 }

sub to_string {
    my $self = shift;
    my $class = ref($self);
    return ($self->name() || "ANON") . "(" . $class . ")";
}

sub make_test_from_coderef {
    my ($self, $coderef, @args) = @_;
    die "Need a coderef argument" unless $coderef;
    return Class::Inner->new(parent  => ($self || ref $self),
                             methods => {run_test => $coderef},
                             args    => [ @args ]);
}


# Returns a list of the tests run by this class and its superclasses.
# DO NOT OVERRIDE THIS UNLESS YOU KNOW WHAT YOU ARE DOING!
sub list_tests {
    my $class = ref($_[0]) || $_[0];
    my @tests = ();
    no strict 'refs';
    if (defined(@{"$class\::TESTS"})) {
        push @tests, @{"$class\::TESTS"};
    }
    else {
        push @tests, $class->get_matching_methods(qr/::(test[^:]*)$/);
    }
    push @tests, map {$_->can('list_tests') ? $_->list_tests : () } @{"$class\::ISA"};
    my %tests = map {$_ => ''} @tests;
    return keys %tests;
}

sub get_matching_methods {
    my $class = ref($_[0]) || $_[0];
    my $re = $_[1];
    my $st = Devel::Symdump->new($class);
    return map { /$re/ ? $1 : () } $st->functions();
}

sub list {
    my $self = shift;
    my $show_testcases = shift;
    return $show_testcases ?
             [ ($self->name() || 'anonymous testcase') . "\n" ]
           : [];
}

1;
__END__