1#!./perl -w 2 3# Tests for the source filters in coderef-in-@INC 4 5BEGIN { 6 chdir 't' if -d 't'; 7 require './test.pl'; 8 set_up_inc( qw(. ../lib) ); 9 skip_all_if_miniperl( 10 'no dynamic loading on miniperl, no Filter::Util::Call' 11 ); 12} 13 14skip_all_without_perlio(); 15 16use strict; 17use Config; 18use Filter::Util::Call; 19 20plan(tests => 153); 21 22unshift @INC, sub { 23 no warnings 'uninitialized'; 24 ref $_[1] eq 'ARRAY' ? @{$_[1]} : $_[1]; 25}; 26 27my $fh; 28 29open $fh, "<", \'pass("Can return file handles from \@INC");'; 30do $fh or die; 31 32my @origlines = ("# This is a blank line\n", 33 "pass('Can return generators from \@INC');\n", 34 "pass('Which return multiple lines');\n", 35 "1", 36 ); 37my @lines = @origlines; 38sub generator { 39 $_ = shift @lines; 40 # Return of 0 marks EOF 41 return defined $_ ? 1 : 0; 42}; 43 44do \&generator or die; 45 46@lines = @origlines; 47# Check that the array dereferencing works ready for the more complex tests: 48do [\&generator] or die; 49 50sub generator_with_state { 51 my $param = $_[1]; 52 is (ref $param, 'ARRAY', "Got our parameter"); 53 $_ = shift @$param; 54 return defined $_ ? 1 : 0; 55} 56 57do [\&generator_with_state, 58 ["pass('Can return generators which take state');\n", 59 "pass('And return multiple lines');\n", 60 ]] or die; 61 62 63open $fh, "<", \'fail("File handles and filters work from \@INC");'; 64 65do [$fh, sub {s/fail/pass/; return;}] or die; 66 67open $fh, "<", \'fail("File handles and filters with state work from \@INC");'; 68 69do [$fh, sub {s/$_[1]/pass/; return;}, 'fail'] or die; 70 71print "# 2 tests with pipes from subprocesses.\n"; 72 73my ($echo_command, $pass_arg, $fail_arg); 74 75if ($^O eq 'VMS') { 76 $echo_command = 'write sys$output'; 77 $pass_arg = '"pass"'; 78 $fail_arg = '"fail"'; 79} 80else { 81 if ($^O =~ /android/) { 82 $echo_command = q{sh -c 'echo $@' -- }; 83 } 84 else { 85 $echo_command = 'echo'; 86 } 87 $pass_arg = 'pass'; 88 $fail_arg = 'fail'; 89} 90 91open $fh, "$echo_command $pass_arg|" or die $!; 92 93do $fh or die; 94 95open $fh, "$echo_command $fail_arg|" or die $!; 96 97do [$fh, sub {s/$_[1]/pass/; return;}, 'fail'] or die; 98 99sub rot13_filter { 100 filter_add(sub { 101 my $status = filter_read(); 102 tr/A-Za-z/N-ZA-Mn-za-m/; 103 $status; 104 }) 105} 106 107open $fh, "<", \<<'EOC'; 108BEGIN {rot13_filter}; 109cnff("This will rot13'ed prepend"); 110EOC 111 112do $fh or die; 113 114open $fh, "<", \<<'EOC'; 115ORTVA {ebg13_svygre}; 116pass("This will rot13'ed twice"); 117EOC 118 119do [$fh, sub {tr/A-Za-z/N-ZA-Mn-za-m/; return;}] or die; 120 121my $count = 32; 122sub prepend_rot13_filter { 123 filter_add(sub { 124 my $previous = $_; 125 # Filters should append to any existing data in $_ 126 # But (logically) shouldn't filter it twice. 127 my $test = "fzrt!"; 128 $_ = $test; 129 my $status = filter_read(); 130 my $got = substr $_, 0, length $test, ''; 131 is $got, $test, "Upstream didn't alter existing data"; 132 tr/A-Za-z/N-ZA-Mn-za-m/; 133 $_ = $previous . $_; 134 die "Looping infinitely" unless $count--; 135 $status; 136 }) 137} 138 139open $fh, "<", \<<'EOC'; 140ORTVA {cercraq_ebg13_svygre}; 141pass("This will rot13'ed twice"); 142EOC 143 144do [$fh, sub {tr/A-Za-z/N-ZA-Mn-za-m/; return;}] or die; 145 146# This generates a heck of a lot of oks, but I think it's necessary. 147my $amount = 1; 148sub prepend_block_counting_filter { 149 filter_add(sub { 150 my $output = $_; 151 my $count = 256; 152 while (--$count) { 153 $_ = ''; 154 my $status = filter_read($amount); 155 cmp_ok (length $_, '<=', $amount, "block mode works?"); 156 $output .= $_; 157 if ($status <= 0 or /\n/s) { 158 $_ = $output; 159 return $status; 160 } 161 } 162 die "Looping infinitely"; 163 164 }) 165} 166 167open $fh, "<", \<<'EOC'; 168BEGIN {prepend_block_counting_filter}; 169pass("one by one"); 170pass("and again"); 171EOC 172 173do [$fh, sub {return;}] or die; 174 175open $fh, "<", \<<'EOC'; 176BEGIN {prepend_block_counting_filter}; 177pas("SSS make s fast SSS"); 178EOC 179 180do [$fh, sub {s/s/ss/gs; s/([\nS])/$1$1$1/gs; return;}] or die; 181 182sub prepend_line_counting_filter { 183 filter_add(sub { 184 my $output = $_; 185 $_ = ''; 186 my $status = filter_read(); 187 my $newlines = tr/\n//; 188 cmp_ok ($newlines, '<=', 1, "1 line at most?"); 189 $_ = $output . $_ if defined $output; 190 return $status; 191 }) 192} 193 194open $fh, "<", \<<'EOC'; 195BEGIN {prepend_line_counting_filter}; 196pass("You should see this line thrice"); 197EOC 198 199do [$fh, sub {$_ .= $_ . $_; return;}] or die; 200 201do \"pass\n(\n'Scalar references are treated as initial file contents'\n)\n" 202or die; 203 204use constant scalarreffee => 205 "pass\n(\n'Scalar references are treated as initial file contents'\n)\n"; 206do \scalarreffee or die; 207is scalarreffee, 208 "pass\n(\n'Scalar references are treated as initial file contents'\n)\n", 209 'and are not gobbled up when read-only'; 210 211{ 212 local $SIG{__WARN__} = sub {}; # ignore deprecation warning from ?...? 213 do qr/a?, 1/; 214 pass "No crash (perhaps) when regexp ref is returned from inc filter"; 215 # Even if that outputs "ok", it may not have passed, as the crash 216 # occurs during globular destruction. But the crash will result in 217 # this script failing. 218} 219 220open $fh, "<", \"ss('The file is concatenated');"; 221 222do [\'pa', $fh] or die; 223 224open $fh, "<", \"ff('Gur svygre vf bayl eha ba gur svyr');"; 225 226do [\'pa', $fh, sub {tr/A-Za-z/N-ZA-Mn-za-m/; return;}] or die; 227 228open $fh, "<", \"SS('State also works');"; 229 230do [\'pa', $fh, sub {s/($_[1])/lc $1/ge; return;}, "S"] or die; 231 232@lines = ('ss', '(', "'you can use a generator'", ')'); 233 234do [\'pa', \&generator] or die; 235 236do [\'pa', \&generator_with_state, 237 ["ss('And generators which take state');\n", 238 "pass('And return multiple lines');\n", 239 ]] or die; 240 241@origlines = keys %{{ "1\n+\n2\n" => 1 }}; 242@lines = @origlines; 243do \&generator or die; 244is $origlines[0], "1\n+\n2\n", 'ink filters do not mangle cow buffers'; 245 246@lines = ('$::the_array = "', [], '"'); 247do \&generator or die; 248like ${$::{the_array}}, qr/^ARRAY\(0x.*\)\z/, 249 'setting $_ to ref in inc filter'; 250@lines = ('$::the_array = "', do { no warnings 'once'; *foo}, '"'); 251do \&generator or die; 252is ${$::{the_array}}, "*main::foo", 'setting $_ to glob in inc filter'; 253@lines = ( 254 '$::the_array = "', 255 do { no strict; no warnings; *{"foo\nbar"}}, 256 '"'); 257do \&generator or die; 258is ${$::{the_array}}, "*main::foo\nbar", 259 'setting $_ to multiline glob in inc filter'; 260 261sub TIESCALAR { bless \(my $thing = pop), shift } 262sub FETCH {${$_[0]}} 263my $done; 264do sub { 265 return 0 if $done; 266 tie $_, "main", '$::the_scalar = 98732'; 267 return $done = 1; 268} or die; 269is ${$::{the_scalar}}, 98732, 'tying $_ in inc filter'; 270@lines = ('$::the_scalar', '= "12345"'); 271tie my $ret, "main", 1; 272do sub :lvalue { 273 return 0 unless @lines; 274 $_ = shift @lines; 275 return $ret; 276} or die; 277is ${$::{the_scalar}}, 12345, 'returning tied val from inc filter'; 278 279 280# d8723a6a74b2c12e wasn't perfect, as the char * returned by SvPV*() can be 281# a temporary, freed at the next FREETMPS. And there is a FREETMPS in 282# pp_require 283 284for (0 .. 1) { 285 # Need both alternatives on the regexp, because currently the logic in 286 # pp_require for what is written to %INC is somewhat confused 287 open $fh, "<", 288 \'like(__FILE__, qr/(?:GLOB|CODE)\(0x[0-9a-f]+\)/, "__FILE__ is valid");'; 289 do $fh or die; 290} 291 292# [perl #91880] $_ having the wrong refcount inside a 293{ # filter sub 294 local @INC; local $|; 295 unshift @INC, sub { sub { undef *_; --$| }}; 296 do "dah"; 297 pass '$_ has the right refcount inside a filter sub'; 298} 299