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