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); | |
62e452a4 NC |
8 | require 'test.pl'; |
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 | |
65613fc2 | 16 | plan(tests => 144); |
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 { | |
77 | $echo_command = 'echo'; | |
78 | $pass_arg = 'pass'; | |
79 | $fail_arg = 'fail'; | |
80 | } | |
81 | ||
82 | open $fh, "$echo_command $pass_arg|" or die $!; | |
5675696b NC |
83 | |
84 | do $fh or die; | |
85 | ||
baf93d00 | 86 | open $fh, "$echo_command $fail_arg|" or die $!; |
5675696b | 87 | |
bccf3f3d | 88 | do [$fh, sub {s/$_[1]/pass/; return;}, 'fail'] or die; |
5675696b NC |
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 | ||
bccf3f3d | 110 | do [$fh, sub {tr/A-Za-z/N-ZA-Mn-za-m/; return;}] or die; |
5675696b NC |
111 | |
112 | my $count = 32; | |
113 | sub prepend_rot13_filter { | |
114 | filter_add(sub { | |
8498a518 | 115 | my $previous = $_; |
5675696b NC |
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(); | |
5675696b NC |
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 | ||
bccf3f3d | 135 | do [$fh, sub {tr/A-Za-z/N-ZA-Mn-za-m/; return;}] or die; |
937b367d NC |
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 { | |
8498a518 | 141 | my $output = $_; |
937b367d NC |
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 | ||
16d5c2f8 AT |
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 | } | |
941a98a0 NC |
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; | |
34113e50 NC |
194 | |
195 | do \"pass\n(\n'Scalar references are treated as initial file contents'\n)\n" | |
196 | or die; | |
197 | ||
93f09d7b | 198 | open $fh, "<", \"ss('The file is concatenated');"; |
34113e50 NC |
199 | |
200 | do [\'pa', $fh] or die; | |
201 | ||
202 | open $fh, "<", \"ff('Gur svygre vf bayl eha ba gur svyr');"; | |
203 | ||
204 | do [\'pa', $fh, sub {tr/A-Za-z/N-ZA-Mn-za-m/; return;}] or die; | |
205 | ||
206 | open $fh, "<", \"SS('State also works');"; | |
207 | ||
208 | do [\'pa', $fh, sub {s/($_[1])/lc $1/ge; return;}, "S"] or die; | |
209 | ||
210 | @lines = ('ss', '(', "'you can use a generator'", ')'); | |
211 | ||
212 | do [\'pa', \&generator] or die; | |
213 | ||
214 | do [\'pa', \&generator_with_state, | |
215 | ["ss('And generators which take state');\n", | |
216 | "pass('And return multiple lines');\n", | |
217 | ]] or die; | |
c5f55552 NC |
218 | |
219 | # d8723a6a74b2c12e wasn't perfect, as the char * returned by SvPV*() can be | |
220 | # a temporary, freed at the next FREETMPS. And there is a FREETMPS in | |
221 | # pp_require | |
222 | ||
223 | for (0 .. 1) { | |
224 | # Need both alternatives on the regexp, because currently the logic in | |
225 | # pp_require for what is written to %INC is somewhat confused | |
226 | open $fh, "<", | |
227 | \'like(__FILE__, qr/(?:GLOB|CODE)\(0x[0-9a-f]+\)/, "__FILE__ is valid");'; | |
228 | do $fh or die; | |
229 | } | |
d34a6664 | 230 | |
65613fc2 | 231 | # [perl #91880] $_ having the wrong refcount inside a |
d34a6664 FC |
232 | { # filter sub |
233 | local @INC; local $|; | |
234 | unshift @INC, sub { sub { undef *_; --$| }}; | |
235 | do "dah"; | |
236 | pass '$_ has the right refcount inside a filter sub'; | |
d34a6664 | 237 | } |