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