File Coverage

blib/lib/Test/DataDriven/Plugin.pm
Criterion Covered Total %
statement 96 97 98.9
branch 17 22 77.2
condition 13 26 50.0
subroutine 18 18 100.0
pod 5 6 83.3
total 149 169 88.1


line stmt bran cond sub pod time code
1             package Test::DataDriven::Plugin;
2              
3             =head1 NAME
4              
5             Test::DataDriven::Plugin - when Test::Base is not enough
6              
7             =head1 SYNOPSIS
8              
9             See C
10              
11             =cut
12              
13 8     8   84467 use strict;
  8         25  
  8         313  
14 8     8   41 use warnings;
  8         15  
  8         284  
15              
16 8     8   10006 use Class::Spiffy -base;
  8         63089  
  8         78  
17 8     8   22550 use Test::DataDriven ();
  8         35  
  8         4962  
18              
19             our @EXPORT = qw(test_name);
20              
21             my %attributes;
22             my %dispatch;
23              
24             =head1 METHODS
25              
26             =cut
27              
28             sub MODIFY_CODE_ATTRIBUTES {
29 77     77   530776 my( $class, $code, @attrs ) = @_;
30 77         111 my( @known, @unknown );
31              
32 77         163 foreach ( @attrs ) {
33 98 50       587 /^(?:Begin|Run|End|Endc|Filter)\s*(?:$|\()/ ?
34             push @known, $_ : push @unknown, $_;
35             }
36              
37 77         7686 $attributes{$class}{$code} = [ $code, \@known ];
38              
39 77         672 return @unknown;
40             }
41              
42             our $test_name;
43              
44             =head2 test_name
45              
46             my $test_name = test_name();
47              
48             This function is exported by default. The test name is
49             "$block - $action - $section".b
50              
51             =cut
52              
53 7     7 1 709 sub test_name() { $test_name }
54              
55             sub _parse {
56 77     77   140 my( @attributes ) = @_;
57              
58 77 50       100 return map { m/^(\w+)\(\s*(\w+)\s*\)/ or die $_;
  98         422  
59 98         448 [ lc( $1 ), $2 ]
60             }
61             @attributes;
62             }
63              
64             =head2 register
65              
66             __PACKAGE__->register;
67              
68             This method must be called by every C
69             subclass in order to register the section handlers with
70             C.
71              
72             =cut
73              
74             sub _apply_filter {
75 3     3   8 my( $self, $filter, @value ) = @_;
76 3         3 local $_;
77             # cut'n'pasted from Test::Base (this sucks)
78 3 50       9 $Test::Base::Filter::arguments =
79             $filter =~ s/=(.*)$// ? $1 : undef;
80 3         6 my $function = "main::$filter";
81 8     8   200 no strict 'refs';
  8         23  
  8         2862  
82 3 100       14 if (defined &$function) {
83 1         2 $_ = join '', @value;
84 1         4 @value = &$function(@value);
85 1 50 33     16 if (not(@value) or
      33        
86             @value == 1 and $value[0] =~ /\A(\d+|)\z/
87             ) {
88 0         0 @value = ($_);
89             }
90             }
91             else {
92 2         43 my $filter_object = $self->blocks_object->filter_class->new;
93 2 50       60 die "Can't find a function or method for '$filter' filter\n"
94             unless $filter_object->can($filter);
95 2         44 $filter_object->current_block($self);
96 2         13 @value = $filter_object->$filter(@value);
97             }
98              
99 3         34 return @value;
100             }
101              
102             sub register {
103 7     7 1 1189 my( $self, $pluggable ) = @_;
104 7   33     65 my $class = ref( $self ) || $self;
105 7         15 my @attributes = values %{$attributes{$class}};
  7         44  
106 7         17 my %keys;
107              
108 7         18 foreach my $attr ( @attributes ) {
109 77         134 my( $sub, $attrs ) = @$attr;
110 77         237 my @parsed = _parse @$attrs;
111             # filter subroutines
112 77 100 100     535 if( @parsed == 1 && $parsed[0][0] eq 'filter' ) {
113 8     8   49 no strict 'refs';
  8         16  
  8         8231  
114 14         23 *{'main::' . $parsed[0][1]} = $sub;
  14         86  
115 14         42 next;
116             }
117             # handle per-subroutine filters
118 63         261 foreach my $h ( grep $_->[0] eq 'filter', reverse @parsed ) {
119 21         46 my( $oldsub, $filter ) = ( $sub, $h->[1] );
120             $sub = sub {
121 3     3   7 my( $block, $section, @a ) = @_;
122 3         9 @a = _apply_filter( $block, $filter, @a );
123 3         8 &$oldsub( $block, $section, @a );
124 21         113 };
125             }
126             # handle begin/run/end
127 63         161 foreach my $h ( grep $_->[0] ne 'filter', @parsed ) {
128 63         35133 $keys{$h->[1]} = 1;
129 63         75 push @{$dispatch{$class}{$h->[0]}{$h->[1]}}, $sub;
  63         517  
130             }
131             }
132              
133 7   50     44 $pluggable ||= 'Test::DataDriven';
134 7         33 foreach my $key ( keys %keys ) {
135 49         397 $pluggable->register( plugin => $self,
136             tag => $key,
137             );
138             }
139             }
140              
141             sub _dispatch {
142 87     87   186 my( $act, $self, $block, $section, @a ) = @_;
143 87   33     993 my $class = ref( $self ) || $self;
144              
145 87 100 33     1077 return unless exists $dispatch{$class}
      66        
146             && exists $dispatch{$class}{$act}
147             && exists $dispatch{$class}{$act}{$section};
148              
149 34         48 local $Test::Builder::Level = 1;
150 34         111 local $test_name = join ' - ', $block->name, $act, $section;
151              
152 34         379 my $run_one = 0;
153 34         40 foreach my $sub ( @{$dispatch{$class}{$act}{$section}} ) {
  34         96  
154 34         126 &$sub( $block, $section, @a );
155 34         16326 $run_one = 1;
156             }
157              
158 34         213 return $run_one;
159             }
160              
161             =head2 begin, run, end
162              
163             Dispatch to the subroutines registered with attributes
164             C, C, C, passing as parameters
165             the block object, section name and the section data.
166              
167             =cut
168              
169 29     29 1 76 sub begin { _dispatch( 'begin', @_ ); }
170 29     29 1 69 sub run { _dispatch( 'run', @_ ); }
171 24     24 1 52 sub end { _dispatch( 'end', @_ ); }
172              
173             sub endc {
174 5     5 0 14 my( $self, $block, $section, @v ) = @_;
175              
176 5         9 _dispatch( 'endc', @_ );
177 5         16 _serialize_back( @_ );
178             }
179              
180             my %started;
181              
182             sub _serialize_back {
183 5     5   12 my( $self, $block, $section, @v ) = @_;
184 5         22 my $create_fh = Test::DataDriven->_create_fh;
185              
186 5 100       27 print $create_fh "=== ", $block->name, "\n" unless $started{$block};
187 5 100 66     44 if( defined $block->description && $block->description ne $block->name ) {
188 1         33 print $create_fh $block->description , "\n" ;
189             }
190 5         108 print $create_fh "--- ", $section;
191 5         14 my $filters = $block->_section_map->{$section}{filters};
192 5 100       46 if( $filters ) {
193 4         6 print $create_fh ' ', $filters;
194             }
195 5         8 print $create_fh "\n";
196 5         142 print $create_fh $block->original_values->{$section};
197              
198 5         59 $started{$block} = 1;
199             }
200              
201             =head1 BUGS
202              
203             Needs more documentation and examples.
204              
205             =head1 AUTHOR
206              
207             Mattia Barbon
208              
209             =head1 LICENSE
210              
211             This program is free software; you can redistribute it and/or
212             modify it under the same terms as Perl itself.
213              
214             =cut
215              
216             1;