root/Encode-DoubleEncodedUTF8/trunk/inc/Test/Base/Filter.pm

Revision 2162 (checked in by miyagawa, 13 years ago)

import

Line 
1 #line 1
2 #. TODO:
3 #.
4
5 #===============================================================================
6 # This is the default class for handling Test::Base data filtering.
7 #===============================================================================
8 package Test::Base::Filter;
9 use Spiffy -Base;
10 use Spiffy ':XXX';
11
12 field 'current_block';
13
14 our $arguments;
15 sub 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
23 sub 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
31 sub _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
43 sub _split_array {
44     map {
45         [$self->split($_)];
46     } @_;
47 }
48
49 sub _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 #===============================================================================
66 sub Join { $self->_peel_deepest($self->_apply_deepest(join => @_)) }
67 sub Reverse { $self->_apply_deepest(reverse => @_) }
68 sub Split { $self->_apply_deepest(_split_array => @_) }
69 sub Sort { $self->_apply_deepest(sort => @_) }
70
71
72 sub append {
73     my $suffix = $self->current_arguments;
74     map { $_ . $suffix } @_;
75 }
76
77 sub array {
78     return [@_];
79 }
80
81 sub base64_decode {
82     $self->assert_scalar(@_);
83     require MIME::Base64;
84     MIME::Base64::decode_base64(shift);
85 }
86
87 sub base64_encode {
88     $self->assert_scalar(@_);
89     require MIME::Base64;
90     MIME::Base64::encode_base64(shift);
91 }
92
93 sub chomp {
94     map { CORE::chomp; $_ } @_;
95 }
96
97 sub chop {
98     map { CORE::chop; $_ } @_;
99 }
100
101 sub 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
110 sub escape {
111     $self->assert_scalar(@_);
112     my $text = shift;
113     $text =~ s/(\\.)/eval "qq{$1}"/ge;
114     return $text;
115 }
116
117 sub eval {
118     $self->assert_scalar(@_);
119     my @return = CORE::eval(shift);
120     return $@ if $@;
121     return @return;
122 }
123
124 sub 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
137 sub 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
147 sub 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
157 sub 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
170 sub 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
184 sub 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
192 sub hash {
193     return +{ @_ };
194 }
195
196 sub head {
197     my $size = $self->current_arguments || 1;
198     return splice(@_, 0, $size);
199 }
200
201 sub join {
202     my $string = $self->current_arguments;
203     $string = '' unless defined $string;
204     CORE::join $string, @_;
205 }
206
207 sub 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
215 sub 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
223 sub prepend {
224     my $prefix = $self->current_arguments;
225     map { $prefix . $_ } @_;
226 }
227
228 sub 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
237 sub 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
254 sub reverse {
255     CORE::reverse(@_);
256 }
257
258 sub 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
268 sub sort {
269     CORE::sort(@_);
270 }
271
272 sub 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
283 sub strict {
284     $self->assert_scalar(@_);
285     <<'...' . shift;
286 use strict;
287 use warnings;
288 ...
289 }
290
291 sub tail {
292     my $size = $self->current_arguments || 1;
293     return splice(@_, @_ - $size, $size);
294 }
295
296 sub trim {
297     map {
298         s/\A([ \t]*\n)+//;
299         s/(?<=\n)\s*\z//g;
300         $_;
301     } @_;
302 }
303
304 sub unchomp {
305     map { $_ . "\n" } @_;
306 }
307
308 sub 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
326 sub yaml {
327     $self->assert_scalar(@_);
328     require YAML;
329     return YAML::Load(shift);
330 }
331
332 sub _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
Note: See TracBrowser for help on using the browser.