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