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


line stmt bran cond sub pod time code
1             # Copyright (c) 2007 Jonathan Rockway
2              
3             package Test::TableDriven;
4 2     2   1285 use strict;
  2         2  
  2         59  
5 2     2   9 use warnings;
  2         4  
  2         44  
6 2     2   2373 use Test::More;
  2         57310  
  2         19  
7 2     2   2945 use Data::Dumper; # always wanted to intentionally ship this.
  2         31439  
  2         301  
8              
9             our $VERSION = '0.02';
10              
11             my %tests;
12              
13             sub import {
14 2     2   31 my $class = shift;
15 2         8 my ($caller) = caller;
16 2         12 %tests = @_;
17              
18 2     2   18 no strict 'refs'; # strict refs are for losers!
  2         4  
  2         248  
19 2         15 *{"${caller}::runtests"} = \&runtests;
  2         3399  
20             }
21              
22             sub runtests() {
23 2     2 1 22 my ($caller) = caller;
24 2         6 my %code;
25              
26             # verify that the tests are callable
27 2         13 foreach my $sub (keys %tests) {
28 2     2   9 no strict 'refs';
  2         4  
  2         759  
29 3 50       5 $code{$sub} = *{$caller. '::'. $sub}{CODE} or
  3         34  
30             die "cannot find a sub in '$caller' to call for '$sub' tests";
31             }
32            
33             # parse the tests, pushing a closure that runs one test onto @todo
34 2         6 my @todo;
35 2         8 foreach my $test (keys %tests) {
36 3         8 my $cases = $tests{$test};
37             my $t = sub {
38 7     7   16 my @a = @_;
39 7         45 push @todo, sub { _run_test($code{$test}, $test, @a) };
  7         78  
40 3         23 };
41            
42             my $do = { HASH => sub {
43 1     1   2 $t->($_, $cases->{$_}) for keys %{$cases};
  1         6  
44             },
45             ARRAY => sub {
46 2     2   4 $t->($_->[0], $_->[1]) for @{$cases};
  2         15  
47             },
48 3         28 };
49 3         7 eval {
50 3         13 $do->{ref $cases}->();
51             };
52 3 50       38 die "I don't know how to run the tests under key '$test'" if $@;
53             }
54            
55             # now run the tests
56 2         16 plan tests => scalar @todo;
57 2         1434 $_->() for @todo;
58            
59 2         245 return; # returns nothing
60             }
61              
62             sub _run_test {
63 7     7   17 my ($code, $test, $in, $expected) = @_;
64 2     2   13 no warnings 'uninitialized';
  2         5  
  2         662  
65            
66             # run a test
67 7         36 my $got = $code->($in); # call the user's code
68 7 100 66     71 if (ref $expected || ref $got) {
69 3         12 my $i = Dumper($in);
70 3         249 my $g = Dumper($got);
71 3         149 my $e = Dumper($expected);
72 3         153 do { s/\$VAR\d+\s=\s?//; s/\n//g; s/\s+/ /g; s/;//g } for ($i,$g,$e);
  9         40  
  9         33  
  9         46  
  9         30  
73              
74             # compare refs
75 3         18 is_deeply($got, $expected, "$test: $i => $e (is $g)");
76             }
77             else {
78             # compare strings
79 4 50       10 do { $_ = 'undef' unless defined $_ } for ($got, $expected);
  8         24  
80 4         24 is($got, $expected, "$test: $in => $expected (is $got)");
81             }
82            
83 7         4622 return;
84             }
85              
86             1;
87             __END__