File Coverage

inc/Test/Base/Filter.pm
Criterion Covered Total %
statement 53 247 21.4
branch 3 60 5.0
condition 2 11 18.1
subroutine 15 51 29.4
pod 29 39 74.3
total 102 408 25.0


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 4     4   17 package Test::Base::Filter;
  4         4  
  4         26  
9 4     4   25 use Spiffy -Base;
  4     4   7  
  4     4   130  
  4         16  
  4         4  
  4         112  
  4         12  
  4         5  
  4         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 140     140 0 130  
23 140 50       262 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             sub _split_array {
44 0         0 map {
  0         0  
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 13     13 1 15  
77 13         33 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 26     26 1 23  
93 26         44 sub chomp {
  30         32  
  30         63  
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 4     4   20 sub dumper {
  4         5  
  4         886  
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 0     0 1 0  
117 0         0 sub eval {
118 0         0 $self->assert_scalar(@_);
119 0 0       0 my @return = CORE::eval(shift);
120 0         0 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 4     4   26 my $return = CORE::eval(shift);
  4         3  
  4         339  
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 4     4   15 CORE::eval(shift);
  4         5  
  4         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 4     4   13 CORE::eval(shift);
  4         4  
  4         5089  
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             if (ref($ref) eq 'HASH') {
174 0         0 return map {
  0         0  
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 26     26 1 22  
207 26         38 sub lines {
208 26         23 $self->assert_scalar(@_);
209 26 100       60 my $text = shift;
210 18         75 return () unless length $text;
211 18         50 my @lines = ($text =~ /^(.*\n?)/gm);
212             return @lines;
213             }
214 89     89 1 88  
215 89         214 sub norm {
216 89   100     183 $self->assert_scalar(@_);
217 89         128 my $text = shift || '';
218 89         96 $text =~ s/\015\012/\n/g;
219 89         346 $text =~ s/\r/\n/g;
220             return $text;
221             }
222 0     0 0 0  
223 0         0 sub prepend {
224 0         0 my $prefix = $self->current_arguments;
  0         0  
225             map { $prefix . $_ } @_;
226             }
227 0     0 1 0  
228 0         0 sub read_file {
229 0         0 $self->assert_scalar(@_);
230 0         0 my $file = shift;
231 0 0       0 CORE::chomp $file;
232             open my $fh, $file
233 0         0 or die "Can't open '$file' for input:\n$!";
234             CORE::join '', <$fh>;
235             }
236 0     0 0 0  
237 0         0 sub regexp {
238 0         0 $self->assert_scalar(@_);
239 0         0 my $text = shift;
240 0 0       0 my $flags = $self->current_arguments;
241 0 0       0 if ($text =~ /\n.*?\n/s) {
242             $flags = 'xism'
243             unless defined $flags;
244             }
245 0         0 else {
246             CORE::chomp($text);
247 0   0     0 }
248 0         0 $flags ||= '';
249 0 0       0 my $regexp = eval "qr{$text}$flags";
250 0         0 die $@ if $@;
251             return $regexp;
252             }
253 0     0 1 0  
254 0         0 sub reverse {
255             CORE::reverse(@_);
256             }
257 0     0 0 0  
258 0 0       0 sub slice {
259             die "Invalid args for slice"
260 0         0 unless $self->current_arguments =~ /^(\d+)(?:,(\d))?$/;
261 0 0       0 my ($x, $y) = ($1, $2);
262 0 0       0 $y = $x if not defined $y;
263             die "Invalid args for slice"
264 0         0 if $x > $y;
265             return splice(@_, $x, 1 + $y - $x);
266             }
267 0     0 1 0  
268 0         0 sub sort {
269             CORE::sort(@_);
270             }
271 0     0 0 0  
272 0         0 sub split {
273 0         0 $self->assert_scalar(@_);
274 0 0 0     0 my $separator = $self->current_arguments;
275 0         0 if (defined $separator and $separator =~ s{^/(.*)/$}{$1}) {
276 0         0 my $regexp = $1;
277             $separator = qr{$regexp};
278 0 0       0 }
279 0         0 $separator = qr/\s+/ unless $separator;
280             CORE::split $separator, shift;
281             }
282 0     0 1 0  
283 0         0 sub strict {
284 0         0 $self->assert_scalar(@_);
285             <<'...' . shift;
286             use strict;
287             use warnings;
288             ...
289             }
290 0     0 0 0  
291 0   0     0 sub tail {
292 0         0 my $size = $self->current_arguments || 1;
293             return splice(@_, @_ - $size, $size);
294             }
295 89     89 1 94  
296             sub trim {
297 89         138 map {
  89         196  
298 89         357 s/\A([ \t]*\n)+//;
299 89         368 s/(?<=\n)\s*\z//g;
300             $_;
301             } @_;
302             }
303 0     0 1 0  
304 0         0 sub unchomp {
  0         0  
305             map { $_ . "\n" } @_;
306             }
307 0     0 0 0  
308 0 0       0 sub write_file {
309             my $file = $self->current_arguments
310 0 0       0 or die "No file specified for write_file filter";
311 0         0 if ($file =~ /(.*)[\\\/]/) {
312 0 0       0 my $dir = $1;
313 0         0 if (not -e $dir) {
314 0 0       0 require File::Path;
315             File::Path::mkpath($dir)
316             or die "Can't create $dir";
317             }
318 0 0       0 }
319             open my $fh, ">$file"
320 0         0 or die "Can't open '$file' for output\n:$!";
321 0         0 print $fh @_;
322 0         0 close $fh;
323             return $file;
324             }
325 25     25 1 36  
326 25         57 sub yaml {
327 25         134 $self->assert_scalar(@_);
328 25         113 require YAML;
329             return YAML::Load(shift);
330             }
331 0     0      
332 0           sub _write_to {
333 0 0         my $filename = shift;
334             open my $script, ">$filename"
335 0           or die "Couldn't open $filename: $!\n";
336 0 0         print $script @_;
337             close $script
338             or die "Couldn't close $filename: $!\n";
339             }
340              
341             __DATA__