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