File Coverage

inc/Test/Base/Filter.pm
Criterion Covered Total %
statement 38 248 15.3
branch 2 62 3.2
condition 0 9 0.0
subroutine 11 51 21.5
pod 0 39 0.0
total 51 409 12.4


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