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; |