File Coverage

blib/lib/Test/TableDriven.pm

Criterion	Covered	Total	%
statement	65	65	100.0
branch	5	8	62.5
condition	2	3	66.6
subroutine	13	13	100.0
pod	1	1	100.0
total	86	90	95.5

# Copyright (c) 2007 Jonathan Rockway

package Test::TableDriven;
use strict;
use warnings;
use Test::More;
use Data::Dumper; # always wanted to intentionally ship this.

our $VERSION = '0.02';

my %tests;

sub import {
    my $class = shift;
    my ($caller) = caller;
    %tests = @_;

    no strict 'refs'; # strict refs are for losers!
    *{"${caller}::runtests"} = \&runtests;
}

sub runtests() {
    my ($caller) = caller;
    my %code;

    # verify that the tests are callable
    foreach my $sub (keys %tests) {
        no strict 'refs';
        $code{$sub} = *{$caller. '::'. $sub}{CODE} or
          die "cannot find a sub in '$caller' to call for '$sub' tests";
    }

    # parse the tests, pushing a closure that runs one test onto @todo
    my @todo;
    foreach my $test (keys %tests) {
        my $cases = $tests{$test};
        my $t     = sub {
            my @a = @_;
            push @todo, sub { _run_test($code{$test}, $test, @a) };
        };

        my $do = { HASH  => sub {
                       $t->($_, $cases->{$_}) for keys %{$cases};
                   },
                   ARRAY => sub {
                       $t->($_->[0], $_->[1]) for @{$cases};
                   },
                 };
        eval {
            $do->{ref $cases}->();
        };
        die "I don't know how to run the tests under key '$test'" if $@;
    }

    # now run the tests
    plan tests => scalar @todo;
    $_->() for @todo;

    return; # returns nothing
}

sub _run_test {
    my ($code, $test, $in, $expected) = @_;
    no warnings 'uninitialized';

    # run a test
    my $got = $code->($in);  # call the user's code
    if (ref $expected || ref $got)  {
        my $i = Dumper($in);
        my $g = Dumper($got);
        my $e = Dumper($expected);
        do { s/\$VAR\d+\s=\s?//; s/\n//g; s/\s+/ /g; s/;//g } for ($i,$g,$e);

        # compare refs
        is_deeply($got, $expected, "$test: $i => $e (is $g)");
    }
    else {
        # compare strings
        do { $_ = 'undef' unless defined $_ } for ($got, $expected);
        is($got, $expected, "$test: $in => $expected (is $got)");
    }

    return;
}

1;
__END__