File Coverage

inc/Test/Base/Filter.pm
Criterion Covered Total %
statement 50 251 19.9
branch 3 62 4.8
condition 0 9 0.0
subroutine 14 52 26.9
pod 29 39 74.3
total 96 413 23.2


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 3     3   26 package Test::Base::Filter;
  3         4  
  3         26  
6 3     3   22 use Spiffy -Base;
  3     3   5  
  3     3   64  
  3         12  
  3         4  
  3         75  
  3         18  
  3         3  
  3         10  
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 56     56 0 62  
20 56 50       108 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             sub _split_array {
41 0         0 map {
  0         0  
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 1 0 #===============================================================================
  0         0  
63 0     0 1 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 1 0 sub Split { $self->_apply_deepest(_split_array => @_) }
  0         0  
66             sub Sort { $self->_apply_deepest(sort => @_) }
67              
68 0     0 1 0  
69 0         0 sub append {
70 0         0 my $suffix = $self->current_arguments;
  0         0  
71             map { $_ . $suffix } @_;
72             }
73 0     0 1 0  
74 0         0 sub array {
75             return [@_];
76             }
77 0     0 1 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 1 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 1 0  
90 0         0 sub chomp {
  0         0  
  0         0  
91             map { CORE::chomp; $_ } @_;
92             }
93 3     3 1 4  
94 3         5 sub chop {
  3         7  
  3         9  
95             map { CORE::chop; $_ } @_;
96             }
97 0     0 1 0  
98 3     3   25 sub dumper {
  3         4  
  3         952  
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 1 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 24     24 1 35  
114 24         45 sub eval {
115 24     1   951 $self->assert_scalar(@_);
  1         7  
  1         16  
  1         69  
116 24 50       136 my @return = CORE::eval(shift);
117 24         82 return $@ if $@;
118             return @return;
119             }
120 0     0 1 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 3     3   21 my $return = CORE::eval(shift);
  3         6  
  3         368  
128 0         0 no warnings;
129 0         0 untie *STDOUT;
130 0         0 untie *STDERR;
131             return $return, $@, $out, $err;
132             }
133 0     0 1 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 3     3   20 CORE::eval(shift);
  3         13  
  3         291  
139 0         0 no warnings;
140 0         0 untie *STDERR;
141             return $output;
142             }
143 0     0 1 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 3     3   20 CORE::eval(shift);
  3         3  
  3         4912  
149 0         0 no warnings;
150 0         0 untie *STDOUT;
151             return $output;
152             }
153 0     0 1 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 1 0  
167 0         0 sub flatten {
168 0         0 $self->assert_scalar(@_);
169 0 0       0 my $ref = shift;
170             if (ref($ref) eq 'HASH') {
171 0         0 return map {
  0         0  
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 1 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 1 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 1 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 1 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 32     32 1 42  
212 32         65 sub norm {
213 32         37 $self->assert_scalar(@_);
214 32 50       88 my $text = shift;
215 32         90 $text = '' unless defined $text;
216 32         41 $text =~ s/\015\012/\n/g;
217 32         113 $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 1 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 1 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 1 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 1 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 32     32 1 38  
294             sub trim {
295 32         51 map {
  32         99  
296 32         233 s/\A([ \t]*\n)+//;
297 32         130 s/(?<=\n)\s*\z//g;
298             $_;
299             } @_;
300             }
301 0     0 1 0  
302 0         0 sub unchomp {
  0         0  
303             map { $_ . "\n" } @_;
304             }
305 0     0 0 0  
306 0 0       0 sub write_file {
307             my $file = $self->current_arguments
308 0 0       0 or die "No file specified for write_file filter";
309 0         0 if ($file =~ /(.*)[\\\/]/) {
310 0 0       0 my $dir = $1;
311 0         0 if (not -e $dir) {
312 0 0       0 require File::Path;
313             File::Path::mkpath($dir)
314             or die "Can't create $dir";
315             }
316 0 0       0 }
317             open my $fh, ">$file"
318 0         0 or die "Can't open '$file' for output\n:$!";
319 0         0 print $fh @_;
320 0         0 close $fh;
321             return $file;
322             }
323 0     0 1 0  
324 0         0 sub yaml {
325 0         0 $self->assert_scalar(@_);
326 0         0 require YAML;
327             return YAML::Load(shift);
328             }
329 0     0   0  
330 0         0 sub _write_to {
331 0 0       0 my $filename = shift;
332             open my $script, ">$filename"
333 0         0 or die "Couldn't open $filename: $!\n";
334 0 0       0 print $script @_;
335             close $script
336             or die "Couldn't close $filename: $!\n";
337             }
338              
339             1;