Jakub Wilk is now a Perl author.
[perl.git] / t / op / incfilter.t
1 #!./perl -w
2
3 # Tests for the source filters in coderef-in-@INC
4
5 BEGIN {
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
14 skip_all_without_perlio();
15
16 use strict;
17 use Config;
18 use Filter::Util::Call;
19
20 plan(tests => 153);
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");';
30 do $fh or die;
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
44 do \&generator or die;
45
46 @lines = @origlines;
47 # Check that the array dereferencing works ready for the more complex tests:
48 do [\&generator] or die;
49
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;
61    
62
63 open $fh, "<", \'fail("File handles and filters work from \@INC");';
64
65 do [$fh, sub {s/fail/pass/; return;}] or die;
66
67 open $fh, "<", \'fail("File handles and filters with state work from \@INC");';
68
69 do [$fh, sub {s/$_[1]/pass/; return;}, 'fail'] or die;
70
71 print "# 2 tests with pipes from subprocesses.\n";
72
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 {
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
91 open $fh, "$echo_command $pass_arg|" or die $!;
92
93 do $fh or die;
94
95 open $fh, "$echo_command $fail_arg|" or die $!;
96
97 do [$fh, sub {s/$_[1]/pass/; return;}, 'fail'] or die;
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
119 do [$fh, sub {tr/A-Za-z/N-ZA-Mn-za-m/; return;}] or die;
120
121 my $count = 32;
122 sub 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
139 open $fh, "<", \<<'EOC';
140 ORTVA {cercraq_ebg13_svygre};
141 pass("This will rot13'ed twice");
142 EOC
143
144 do [$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.
147 my $amount = 1;
148 sub 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
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
180 do [$fh, sub {s/s/ss/gs; s/([\nS])/$1$1$1/gs; return;}] or die;
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;
200
201 do \"pass\n(\n'Scalar references are treated as initial file contents'\n)\n"
202 or die;
203
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
220 open $fh, "<", \"ss('The file is concatenated');";
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;
240
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
246 @lines = ('$::the_array = "', [], '"');
247 do \&generator or die;
248 like ${$::{the_array}}, qr/^ARRAY\(0x.*\)\z/,
249    'setting $_ to ref in inc filter';
250 @lines = ('$::the_array = "', do { no warnings 'once'; *foo}, '"');
251 do \&generator or die;
252 is ${$::{the_array}}, "*main::foo", 'setting $_ to glob in inc filter';
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';
260
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';
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';
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
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 }
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 }