File Coverage

inc/Test/Base/Filter.pm
Criterion Covered Total %
statement 43 248 17.3
branch 3 62 4.8
condition 0 9 0.0
subroutine 12 51 23.5
pod 29 39 74.3
total 87 409 21.2


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