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'; | |
1ae3d757 | 7 | require './test.pl'; |
624c42e2 | 8 | set_up_inc( qw(. ../lib) ); |
8d2d13e6 FC |
9 | skip_all_if_miniperl( |
10 | 'no dynamic loading on miniperl, no Filter::Util::Call' | |
11 | ); | |
bde61959 | 12 | } |
624c42e2 | 13 | |
624c42e2 N |
14 | skip_all_without_perlio(); |
15 | ||
bde61959 | 16 | use strict; |
16d5c2f8 | 17 | use Config; |
5675696b | 18 | use Filter::Util::Call; |
bde61959 | 19 | |
2e8409ad | 20 | plan(tests => 153); |
bde61959 NC |
21 | |
22 | unshift @INC, sub { | |
23 | no warnings 'uninitialized'; | |
24 | ref $_[1] eq 'ARRAY' ? @{$_[1]} : $_[1]; | |
25 | }; | |
26 | ||
27 | my $fh; | |
28 | ||
29 | open $fh, "<", \'pass("Can return file handles from \@INC");'; | |
5675696b | 30 | do $fh or die; |
bde61959 NC |
31 | |
32 | my @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 | ); | |
37 | my @lines = @origlines; | |
38 | sub generator { | |
39 | $_ = shift @lines; | |
40 | # Return of 0 marks EOF | |
41 | return defined $_ ? 1 : 0; | |
42 | }; | |
43 | ||
5675696b | 44 | do \&generator or die; |
bde61959 NC |
45 | |
46 | @lines = @origlines; | |
47 | # Check that the array dereferencing works ready for the more complex tests: | |
5675696b | 48 | do [\&generator] or die; |
bde61959 | 49 | |
34113e50 NC |
50 | sub 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 | ||
57 | do [\&generator_with_state, | |
58 | ["pass('Can return generators which take state');\n", | |
59 | "pass('And return multiple lines');\n", | |
60 | ]] or die; | |
bde61959 NC |
61 | |
62 | ||
63 | open $fh, "<", \'fail("File handles and filters work from \@INC");'; | |
64 | ||
bccf3f3d | 65 | do [$fh, sub {s/fail/pass/; return;}] or die; |
bde61959 NC |
66 | |
67 | open $fh, "<", \'fail("File handles and filters with state work from \@INC");'; | |
68 | ||
bccf3f3d | 69 | do [$fh, sub {s/$_[1]/pass/; return;}, 'fail'] or die; |
5675696b NC |
70 | |
71 | print "# 2 tests with pipes from subprocesses.\n"; | |
72 | ||
baf93d00 CB |
73 | my ($echo_command, $pass_arg, $fail_arg); |
74 | ||
75 | if ($^O eq 'VMS') { | |
76 | $echo_command = 'write sys$output'; | |
77 | $pass_arg = '"pass"'; | |
78 | $fail_arg = '"fail"'; | |
79 | } | |
80 | else { | |
d7046a2a BF |
81 | if ($^O =~ /android/) { |
82 | $echo_command = q{sh -c 'echo $@' -- }; | |
83 | } | |
84 | else { | |
85 | $echo_command = 'echo'; | |
86 | } | |
baf93d00 CB |
87 | $pass_arg = 'pass'; |
88 | $fail_arg = 'fail'; | |
89 | } | |
90 | ||
91 | open $fh, "$echo_command $pass_arg|" or die $!; | |
5675696b NC |
92 | |
93 | do $fh or die; | |
94 | ||
baf93d00 | 95 | open $fh, "$echo_command $fail_arg|" or die $!; |
5675696b | 96 | |
bccf3f3d | 97 | do [$fh, sub {s/$_[1]/pass/; return;}, 'fail'] or die; |
5675696b NC |
98 | |
99 | sub 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 | ||
107 | open $fh, "<", \<<'EOC'; | |
108 | BEGIN {rot13_filter}; | |
109 | cnff("This will rot13'ed prepend"); | |
110 | EOC | |
111 | ||
112 | do $fh or die; | |
113 | ||
114 | open $fh, "<", \<<'EOC'; | |
115 | ORTVA {ebg13_svygre}; | |
116 | pass("This will rot13'ed twice"); | |
117 | EOC | |
118 | ||
bccf3f3d | 119 | do [$fh, sub {tr/A-Za-z/N-ZA-Mn-za-m/; return;}] or die; |
5675696b NC |
120 | |
121 | my $count = 32; | |
122 | sub prepend_rot13_filter { | |
123 | filter_add(sub { | |
8498a518 | 124 | my $previous = $_; |
5675696b NC |
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(); | |
5675696b NC |
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 | ||
139 | open $fh, "<", \<<'EOC'; | |
140 | ORTVA {cercraq_ebg13_svygre}; | |
141 | pass("This will rot13'ed twice"); | |
142 | EOC | |
143 | ||
bccf3f3d | 144 | do [$fh, sub {tr/A-Za-z/N-ZA-Mn-za-m/; return;}] or die; |
937b367d NC |
145 | |
146 | # This generates a heck of a lot of oks, but I think it's necessary. | |
147 | my $amount = 1; | |
148 | sub prepend_block_counting_filter { | |
149 | filter_add(sub { | |
8498a518 | 150 | my $output = $_; |
937b367d NC |
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 | ||
167 | open $fh, "<", \<<'EOC'; | |
168 | BEGIN {prepend_block_counting_filter}; | |
169 | pass("one by one"); | |
170 | pass("and again"); | |
171 | EOC | |
172 | ||
173 | do [$fh, sub {return;}] or die; | |
174 | ||
175 | open $fh, "<", \<<'EOC'; | |
176 | BEGIN {prepend_block_counting_filter}; | |
177 | pas("SSS make s fast SSS"); | |
178 | EOC | |
179 | ||
1b54b9b1 | 180 | do [$fh, sub {s/s/ss/gs; s/([\nS])/$1$1$1/gs; return;}] or die; |
941a98a0 NC |
181 | |
182 | sub 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 | ||
194 | open $fh, "<", \<<'EOC'; | |
195 | BEGIN {prepend_line_counting_filter}; | |
196 | pass("You should see this line thrice"); | |
197 | EOC | |
198 | ||
199 | do [$fh, sub {$_ .= $_ . $_; return;}] or die; | |
34113e50 NC |
200 | |
201 | do \"pass\n(\n'Scalar references are treated as initial file contents'\n)\n" | |
202 | or die; | |
203 | ||
9b7d7782 FC |
204 | use constant scalarreffee => |
205 | "pass\n(\n'Scalar references are treated as initial file contents'\n)\n"; | |
206 | do \scalarreffee or die; | |
207 | is 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 | ||
93f09d7b | 220 | open $fh, "<", \"ss('The file is concatenated');"; |
34113e50 NC |
221 | |
222 | do [\'pa', $fh] or die; | |
223 | ||
224 | open $fh, "<", \"ff('Gur svygre vf bayl eha ba gur svyr');"; | |
225 | ||
226 | do [\'pa', $fh, sub {tr/A-Za-z/N-ZA-Mn-za-m/; return;}] or die; | |
227 | ||
228 | open $fh, "<", \"SS('State also works');"; | |
229 | ||
230 | do [\'pa', $fh, sub {s/($_[1])/lc $1/ge; return;}, "S"] or die; | |
231 | ||
232 | @lines = ('ss', '(', "'you can use a generator'", ')'); | |
233 | ||
234 | do [\'pa', \&generator] or die; | |
235 | ||
236 | do [\'pa', \&generator_with_state, | |
237 | ["ss('And generators which take state');\n", | |
238 | "pass('And return multiple lines');\n", | |
239 | ]] or die; | |
c5f55552 | 240 | |
b68108d9 FC |
241 | @origlines = keys %{{ "1\n+\n2\n" => 1 }}; |
242 | @lines = @origlines; | |
243 | do \&generator or die; | |
244 | is $origlines[0], "1\n+\n2\n", 'ink filters do not mangle cow buffers'; | |
245 | ||
ae2c96ed FC |
246 | @lines = ('$::the_array = "', [], '"'); |
247 | do \&generator or die; | |
248 | like ${$::{the_array}}, qr/^ARRAY\(0x.*\)\z/, | |
249 | 'setting $_ to ref in inc filter'; | |
bc0fad74 | 250 | @lines = ('$::the_array = "', do { no warnings 'once'; *foo}, '"'); |
ae2c96ed FC |
251 | do \&generator or die; |
252 | is ${$::{the_array}}, "*main::foo", 'setting $_ to glob in inc filter'; | |
00752fe1 FC |
253 | @lines = ( |
254 | '$::the_array = "', | |
255 | do { no strict; no warnings; *{"foo\nbar"}}, | |
256 | '"'); | |
257 | do \&generator or die; | |
258 | is ${$::{the_array}}, "*main::foo\nbar", | |
259 | 'setting $_ to multiline glob in inc filter'; | |
ae2c96ed | 260 | |
536ac391 FC |
261 | sub TIESCALAR { bless \(my $thing = pop), shift } |
262 | sub FETCH {${$_[0]}} | |
263 | my $done; | |
264 | do sub { | |
265 | return 0 if $done; | |
266 | tie $_, "main", '$::the_scalar = 98732'; | |
267 | return $done = 1; | |
268 | } or die; | |
269 | is ${$::{the_scalar}}, 98732, 'tying $_ in inc filter'; | |
2e8409ad FC |
270 | @lines = ('$::the_scalar', '= "12345"'); |
271 | tie my $ret, "main", 1; | |
272 | do sub :lvalue { | |
273 | return 0 unless @lines; | |
274 | $_ = shift @lines; | |
275 | return $ret; | |
276 | } or die; | |
277 | is ${$::{the_scalar}}, 12345, 'returning tied val from inc filter'; | |
536ac391 FC |
278 | |
279 | ||
c5f55552 NC |
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 | ||
284 | for (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 | } | |
d34a6664 | 291 | |
65613fc2 | 292 | # [perl #91880] $_ having the wrong refcount inside a |
d34a6664 FC |
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'; | |
d34a6664 | 298 | } |