File Coverage

lib/Test/Easy/DataDriven.pm
Criterion Covered Total %
statement 19 21 90.4
branch n/a
condition n/a
subroutine 7 7 100.0
pod n/a
total 26 28 92.8


line stmt bran cond sub pod time code
1             package Test::Easy::DataDriven;
2 7     7   66396 use base qw(Exporter);
  7         14  
  7         640  
3              
4 7     7   36 use strict;
  7         11  
  7         213  
5 7     7   29 use warnings;
  7         16  
  7         223  
6              
7 7     7   31 use Carp qw(confess);
  7         8  
  7         466  
8 7     7   2374 use Test::Easy::DeepEqual qw(deep_equal);
  7         16  
  7         489  
9 7     7   37 use Scalar::Util qw(blessed);
  7         9  
  7         602  
10 7     7   7309 use Hash::MostUtils qw(lkeys);
  0            
  0            
11             use Functional::Utility qw(hook_run y_combinator);
12              
13             our @EXPORT = qw(run_where each_ok);
14              
15             sub assert(&;$) {
16             require Carp;
17             Carp::confess pop() if ! shift->();
18             }
19              
20             sub run_where {
21             my $code = pop;
22             my (@where) = @_;
23              
24             return y_combinator {
25             my ($recurse) = @_;
26             return sub {
27             my $where = shift @where;
28             my $to_run = scalar @where ? $recurse : $code;
29             return run_then_restore(@$where, $to_run);
30             };
31             }->();
32             }
33              
34             sub run_then_restore {
35             my $code = pop;
36             my (@args) = @_;
37              
38             assert { ! grep { ! ref($_) } lkeys @args } "error: you gave me a bare scalar - give me a scalar reference instead";
39              
40             my @restore;
41              
42             my %sg = (
43             SCALAR => [
44             sub {
45             my ($r, $v) = @_;
46             $$r = $v;
47             },
48             sub {
49             my ($r, $v) = @_;
50             return $$r;
51             },
52             ],
53             ARRAY => [
54             sub {
55             my ($r, $v) = @_;
56             $r = $$r if ref($r) eq 'REF';
57             @$r = @$v;
58             },
59             sub {
60             my ($r, $v) = @_;
61             return [@$r];
62             },
63             ],
64             HASH => [
65             sub {
66             my ($r, $v) = @_;
67             $r = $$r if ref($r) eq 'REF';
68             %$r = %$v;
69             },
70             sub {
71             my ($r, $v) = @_;
72             return +{%$r};
73             },
74             ],
75             );
76              
77             return hook_run(
78             before => sub {
79             while (my ($r, $v) = splice @args, 0, 2) {
80             my ($setter, $getter) = @{$sg{ref $r} || $sg{SCALAR}};
81             push @restore, {ref => $r, value => $getter->($r, $v)};
82             $setter->($r, $v);
83             }
84             },
85             run => $code,
86             after => sub {
87             foreach (@restore) {
88             my ($setter) = @{$sg{ref $_->{value}} || $sg{SCALAR}};
89             $setter->($_->{ref}, $_->{value});
90             }
91             },
92             );
93             }
94              
95             sub each_ok (&@) {
96             my $code = shift;
97              
98             local $_;
99              
100             my $index = 0;
101              
102             my @bad;
103             foreach (@_) {
104             my $orig = $_;
105             my (@got) = $code->();
106              
107             my $ok = 1;
108             my $expected;
109              
110             if (@got == 1) {
111             $ok = !! $got[0];
112             $expected = 'something true';
113             } elsif (! _match($got[0], $got[1])) {
114             $ok = 0;
115             $expected = $got[1];
116             }
117              
118             push @bad, {
119             raw => $_,
120             index => $index,
121             got => $got[0],
122             expected => $expected,
123             } if ! $ok;
124              
125             $index++;
126             }
127              
128             local $Test::Builder::Level = $Test::Builder::Level + 1;
129             return Test::Easy::deep_ok( \@bad, [] );
130             }
131              
132             sub _match {
133             my ($got, $expected) = @_;
134             if (ref($expected) eq 'Regexp') {
135             return $got =~ $expected;
136             } elsif (! scalar grep { ref } ($got, $expected)) {
137             return $got eq $expected;
138             } elsif (ref($got) eq ref($expected)) {
139             return deep_equal($got, $expected);
140             } else {
141             confess "I don't know how to compare a '${\ref($got)}' to a '${\ref($expected)}'";
142             }
143             }
144              
145             1;
146              
147             __END__