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 =~ s/\015\012/\n/g;
219    $text =~ s/\r/\n/g;
220    return $text;
221}
222
223sub prepend {
224    my $prefix = $self->current_arguments;
225    map { $prefix . $_ } @_;
226}
227
228sub read_file {
229    $self->assert_scalar(@_);
230    my $file = shift;
231    CORE::chomp $file;
232    open my $fh, $file
233      or die "Can't open '$file' for input:\n$!";
234    CORE::join '', <$fh>;
235}
236
237sub regexp {
238    $self->assert_scalar(@_);
239    my $text = shift;
240    my $flags = $self->current_arguments;
241    if ($text =~ /\n.*?\n/s) {
242        $flags = 'xism'
243          unless defined $flags;
244    }
245    else {
246        CORE::chomp($text);
247    }
248    $flags ||= '';
249    my $regexp = eval "qr{$text}$flags";
250    die $@ if $@;
251    return $regexp;
252}
253
254sub reverse {
255    CORE::reverse(@_);
256}
257
258sub slice {
259    die "Invalid args for slice"
260      unless $self->current_arguments =~ /^(\d+)(?:,(\d))?$/;
261    my ($x, $y) = ($1, $2);
262    $y = $x if not defined $y;
263    die "Invalid args for slice"
264      if $x > $y;
265    return splice(@_, $x, 1 + $y - $x);
266}
267
268sub sort {
269    CORE::sort(@_);
270}
271
272sub split {
273    $self->assert_scalar(@_);
274    my $separator = $self->current_arguments;
275    if (defined $separator and $separator =~ s{^/(.*)/$}{$1}) {
276        my $regexp = $1;
277        $separator = qr{$regexp};
278    }
279    $separator = qr/\s+/ unless $separator;
280    CORE::split $separator, shift;
281}
282
283sub strict {
284    $self->assert_scalar(@_);
285    <<'...' . shift;
286use strict;
287use warnings;
288...
289}
290
291sub tail {
292    my $size = $self->current_arguments || 1;
293    return splice(@_, @_ - $size, $size);
294}
295
296sub trim {
297    map {
298        s/\A([ \t]*\n)+//;
299        s/(?<=\n)\s*\z//g;
300        $_;
301    } @_;
302}
303
304sub unchomp {
305    map { $_ . "\n" } @_;
306}
307
308sub write_file {
309    my $file = $self->current_arguments
310      or die "No file specified for write_file filter";
311    if ($file =~ /(.*)[\\\/]/) {
312        my $dir = $1;
313        if (not -e $dir) {
314            require File::Path;
315            File::Path::mkpath($dir)
316              or die "Can't create $dir";
317        }
318    }
319    open my $fh, ">$file"
320      or die "Can't open '$file' for output\n:$!";
321    print $fh @_;
322    close $fh;
323    return $file;
324}
325
326sub yaml {
327    $self->assert_scalar(@_);
328    require YAML;
329    return YAML::Load(shift);
330}
331
332sub _write_to {
333    my $filename = shift;
334    open my $script, ">$filename"
335      or die "Couldn't open $filename: $!\n";
336    print $script @_;
337    close $script
338      or die "Couldn't close $filename: $!\n";
339}
340
341__DATA__
342
343#line 638
344