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