File Coverage

inc/Test/Base/Filter.pm
Criterion Covered Total %
statement 70 269 26.0
branch 5 64 7.8
condition 0 9 0.0
subroutine 22 60 36.6
pod 0 39 0.0
total 97 441 22.0


line stmt bran cond sub pod time code
1             #===============================================================================
2             # This is the default class for handling Test::Base data filtering.
3             #===============================================================================
4             package Test::Base::Filter;
5 8     8   47 use Spiffy -Base;
  8         11  
  8         51  
6 8     8   56 use Spiffy ':XXX';
  8     8   11  
  8     8   258  
  8         32  
  8         9  
  8         216  
  8         29  
  8         10  
  8         32  
7              
8             field 'current_block';
9              
10             our $arguments;
11 0     0 0 0 sub current_arguments {
12 0 0       0 return undef unless defined $arguments;
13 0         0 my $args = $arguments;
14 0         0 $args =~ s/(\\s)/ /g;
15 0         0 $args =~ s/(\\[a-z])/'"' . $1 . '"'/gee;
  0         0  
16 0         0 return $args;
17             }
18              
19 29     29 0 37 sub assert_scalar {
20 29 50       108 return if @_ == 1;
21 0         0 require Carp;
22 0         0 my $filter = (caller(1))[3];
23 0         0 $filter =~ s/.*:://;
24 0         0 Carp::croak "Input to the '$filter' filter must be a scalar, not a list";
25             }
26              
27 0     0   0 sub _apply_deepest {
28 0         0 my $method = shift;
29 0 0       0 return () unless @_;
30 0 0       0 if (ref $_[0] eq 'ARRAY') {
31 0         0 for my $aref (@_) {
32 0         0 @$aref = $self->_apply_deepest($method, @$aref);
33             }
34 0         0 return @_;
35             }
36 0         0 $self->$method(@_);
37             }
38              
39 0     0   0 sub _split_array {
40 0         0 map {
41 0         0 [$self->split($_)];
42             } @_;
43             }
44              
45 0     0   0 sub _peel_deepest {
46 0 0       0 return () unless @_;
47 0 0       0 if (ref $_[0] eq 'ARRAY') {
48 0 0       0 if (ref $_[0]->[0] eq 'ARRAY') {
49 0         0 for my $aref (@_) {
50 0         0 @$aref = $self->_peel_deepest(@$aref);
51             }
52 0         0 return @_;
53             }
54 0         0 return map { $_->[0] } @_;
  0         0  
55             }
56 0         0 return @_;
57             }
58              
59             #===============================================================================
60             # these filters work on the leaves of nested arrays
61             #===============================================================================
62 0     0 0 0 sub Join { $self->_peel_deepest($self->_apply_deepest(join => @_)) }
  0         0  
63 0     0 0 0 sub Reverse { $self->_apply_deepest(reverse => @_) }
  0         0  
64 0     0 0 0 sub Split { $self->_apply_deepest(_split_array => @_) }
  0         0  
65 0     0 0 0 sub Sort { $self->_apply_deepest(sort => @_) }
  0         0  
66              
67              
68 0     0 0 0 sub append {
69 0         0 my $suffix = $self->current_arguments;
70 0         0 map { $_ . $suffix } @_;
  0         0  
71             }
72              
73 0     0 0 0 sub array {
74 0         0 return [@_];
75             }
76              
77 0     0 0 0 sub base64_decode {
78 0         0 $self->assert_scalar(@_);
79 0         0 require MIME::Base64;
80 0         0 MIME::Base64::decode_base64(shift);
81             }
82              
83 0     0 0 0 sub base64_encode {
84 0         0 $self->assert_scalar(@_);
85 0         0 require MIME::Base64;
86 0         0 MIME::Base64::encode_base64(shift);
87             }
88              
89 0     0 0 0 sub chomp {
90 0         0 map { CORE::chomp; $_ } @_;
  0         0  
  0         0  
91             }
92              
93 0     0 0 0 sub chop {
94 0         0 map { CORE::chop; $_ } @_;
  0         0  
  0         0  
95             }
96              
97 0     0 0 0 sub dumper {
98 8     8   52 no warnings 'once';
  8         11  
  8         2009  
99 0         0 require Data::Dumper;
100 0         0 local $Data::Dumper::Sortkeys = 1;
101 0         0 local $Data::Dumper::Indent = 1;
102 0         0 local $Data::Dumper::Terse = 1;
103 0         0 Data::Dumper::Dumper(@_);
104             }
105              
106 0     0 0 0 sub escape {
107 0         0 $self->assert_scalar(@_);
108 0         0 my $text = shift;
109 0         0 $text =~ s/(\\.)/eval "qq{$1}"/ge;
  0         0  
110 0         0 return $text;
111             }
112              
113 2     2 0 5 sub eval {
114 2         6 $self->assert_scalar(@_);
115 1 50   1   8 my @return = CORE::eval(shift);
  1     1   1  
  1     1   65  
  1     1   6  
  1     1   2  
  1     1   13  
  1     1   10  
  1     2   2  
  1     2   17  
  1         7  
  1         2  
  1         6  
  2         240  
  1         6  
  1         9  
  1         18  
  1         7  
  2         5  
  2         9  
  2         5  
  2         8  
  2         9  
116 2 50       10 return $@ if $@;
117 2         12 return @return;
118             }
119              
120 0     0 0 0 sub eval_all {
121 0         0 $self->assert_scalar(@_);
122 0         0 my $out = '';
123 0         0 my $err = '';
124 0         0 Test::Base::tie_output(*STDOUT, $out);
125 0         0 Test::Base::tie_output(*STDERR, $err);
126 0         0 my $return = CORE::eval(shift);
127 8     8   42 no warnings;
  8         10  
  8         797  
128 0         0 untie *STDOUT;
129 0         0 untie *STDERR;
130 0         0 return $return, $@, $out, $err;
131             }
132              
133 0     0 0 0 sub eval_stderr {
134 0         0 $self->assert_scalar(@_);
135 0         0 my $output = '';
136 0         0 Test::Base::tie_output(*STDERR, $output);
137 0         0 CORE::eval(shift);
138 8     8   35 no warnings;
  8         13  
  8         710  
139 0         0 untie *STDERR;
140 0         0 return $output;
141             }
142              
143 0     0 0 0 sub eval_stdout {
144 0         0 $self->assert_scalar(@_);
145 0         0 my $output = '';
146 0         0 Test::Base::tie_output(*STDOUT, $output);
147 0         0 CORE::eval(shift);
148 8     8   35 no warnings;
  8         12  
  8         11460  
149 0         0 untie *STDOUT;
150 0         0 return $output;
151             }
152              
153 0     0 0 0 sub exec_perl_stdout {
154 0         0 my $tmpfile = "/tmp/test-blocks-$$";
155 0         0 $self->_write_to($tmpfile, @_);
156 0 0       0 open my $execution, "$^X $tmpfile 2>&1 |"
157             or die "Couldn't open subprocess: $!\n";
158 0         0 local $/;
159 0         0 my $output = <$execution>;
160 0         0 close $execution;
161 0 0       0 unlink($tmpfile)
162             or die "Couldn't unlink $tmpfile: $!\n";
163 0         0 return $output;
164             }
165              
166 0     0 0 0 sub flatten {
167 0         0 $self->assert_scalar(@_);
168 0         0 my $ref = shift;
169 0 0       0 if (ref($ref) eq 'HASH') {
170 0         0 return map {
171 0         0 ($_, $ref->{$_});
172             } sort keys %$ref;
173             }
174 0 0       0 if (ref($ref) eq 'ARRAY') {
175 0         0 return @$ref;
176             }
177 0         0 die "Can only flatten a hash or array ref";
178             }
179              
180 0     0 0 0 sub get_url {
181 0         0 $self->assert_scalar(@_);
182 0         0 my $url = shift;
183 0         0 CORE::chomp($url);
184 0         0 require LWP::Simple;
185 0         0 LWP::Simple::get($url);
186             }
187              
188 0     0 0 0 sub hash {
189 0         0 return +{ @_ };
190             }
191              
192 0     0 0 0 sub head {
193 0   0     0 my $size = $self->current_arguments || 1;
194 0         0 return splice(@_, 0, $size);
195             }
196              
197 0     0 0 0 sub join {
198 0         0 my $string = $self->current_arguments;
199 0 0       0 $string = '' unless defined $string;
200 0         0 CORE::join $string, @_;
201             }
202              
203 0     0 0 0 sub lines {
204 0         0 $self->assert_scalar(@_);
205 0         0 my $text = shift;
206 0 0       0 return () unless length $text;
207 0         0 my @lines = ($text =~ /^(.*\n?)/gm);
208 0         0 return @lines;
209             }
210              
211 26     26 0 40 sub norm {
212 26         76 $self->assert_scalar(@_);
213 26         32 my $text = shift;
214 26 50       60 $text = '' unless defined $text;
215 26         50 $text =~ s/\015\012/\n/g;
216 26         41 $text =~ s/\r/\n/g;
217 26         126 return $text;
218             }
219              
220 0     0 0 0 sub prepend {
221 0         0 my $prefix = $self->current_arguments;
222 0         0 map { $prefix . $_ } @_;
  0         0  
223             }
224              
225 1     1 0 2 sub read_file {
226 1         3 $self->assert_scalar(@_);
227 1         2 my $file = shift;
228 1         2 CORE::chomp $file;
229 1 50       38 open my $fh, $file
230             or die "Can't open '$file' for input:\n$!";
231 1         41 CORE::join '', <$fh>;
232             }
233              
234 0     0 0 0 sub regexp {
235 0         0 $self->assert_scalar(@_);
236 0         0 my $text = shift;
237 0         0 my $flags = $self->current_arguments;
238 0 0       0 if ($text =~ /\n.*?\n/s) {
239 0 0       0 $flags = 'xism'
240             unless defined $flags;
241             }
242             else {
243 0         0 CORE::chomp($text);
244             }
245 0   0     0 $flags ||= '';
246 0         0 my $regexp = eval "qr{$text}$flags";
247 0 0       0 die $@ if $@;
248 0         0 return $regexp;
249             }
250              
251 0     0 0 0 sub reverse {
252 0         0 CORE::reverse(@_);
253             }
254              
255 0     0 0 0 sub slice {
256 0 0       0 die "Invalid args for slice"
257             unless $self->current_arguments =~ /^(\d+)(?:,(\d))?$/;
258 0         0 my ($x, $y) = ($1, $2);
259 0 0       0 $y = $x if not defined $y;
260 0 0       0 die "Invalid args for slice"
261             if $x > $y;
262 0         0 return splice(@_, $x, 1 + $y - $x);
263             }
264              
265 0     0 0 0 sub sort {
266 0         0 CORE::sort(@_);
267             }
268              
269 0     0 0 0 sub split {
270 0         0 $self->assert_scalar(@_);
271 0         0 my $separator = $self->current_arguments;
272 0 0 0     0 if (defined $separator and $separator =~ s{^/(.*)/$}{$1}) {
273 0         0 my $regexp = $1;
274 0         0 $separator = qr{$regexp};
275             }
276 0 0       0 $separator = qr/\s+/ unless $separator;
277 0         0 CORE::split $separator, shift;
278             }
279              
280 0     0 0 0 sub strict {
281 0         0 $self->assert_scalar(@_);
282 0         0 <<'...' . shift;
283             use strict;
284             use warnings;
285             ...
286             }
287              
288 0     0 0 0 sub tail {
289 0   0     0 my $size = $self->current_arguments || 1;
290 0         0 return splice(@_, @_ - $size, $size);
291             }
292              
293 25     25 0 38 sub trim {
294 25         97 map {
295 25         44 s/\A([ \t]*\n)+//;
296 25         572 s/(?<=\n)\s*\z//g;
297 25         140 $_;
298             } @_;
299             }
300              
301 0     0 0   sub unchomp {
302 0           map { $_ . "\n" } @_;
  0            
303             }
304              
305 0     0 0   sub write_file {
306 0 0         my $file = $self->current_arguments
307             or die "No file specified for write_file filter";
308 0 0         if ($file =~ /(.*)[\\\/]/) {
309 0           my $dir = $1;
310 0 0         if (not -e $dir) {
311 0           require File::Path;
312 0 0         File::Path::mkpath($dir)
313             or die "Can't create $dir";
314             }
315             }
316 0 0         open my $fh, ">$file"
317             or die "Can't open '$file' for output\n:$!";
318 0           print $fh @_;
319 0           close $fh;
320 0           return $file;
321             }
322              
323 0     0 0   sub yaml {
324 0           $self->assert_scalar(@_);
325 0           require YAML;
326 0           return YAML::Load(shift);
327             }
328              
329 0     0     sub _write_to {
330 0           my $filename = shift;
331 0 0         open my $script, ">$filename"
332             or die "Couldn't open $filename: $!\n";
333 0           print $script @_;
334 0 0         close $script
335             or die "Couldn't close $filename: $!\n";
336             }
337              
338             1;