Commit | Line | Data |
69026470 |
1 | #!./perl -w |
e5d18500 |
2 | |
3 | # Tests for the coderef-in-@INC feature |
4 | |
240b6766 |
5 | use Config; |
6 | |
7 | my $can_fork = 0; |
8 | my $minitest = $ENV{PERL_CORE_MINITEST}; |
9 | my $has_perlio = $Config{useperlio}; |
ab742322 |
10 | |
e5d18500 |
11 | BEGIN { |
f8973f08 |
12 | chdir 't' if -d 't'; |
69026470 |
13 | @INC = qw(. ../lib); |
e5d18500 |
14 | } |
ab742322 |
15 | |
16 | if (!$minitest) { |
240b6766 |
17 | if ($Config{d_fork} && eval 'require POSIX; 1') { |
6b75eab3 |
18 | $can_fork = 1; |
19 | } |
20 | } |
f8973f08 |
21 | |
6b75eab3 |
22 | use strict; |
47de4e93 |
23 | use File::Spec; |
69026470 |
24 | |
25 | require "test.pl"; |
6e592b3a |
26 | plan(tests => 49 + !$minitest * (3 + 14 * $can_fork)); |
47de4e93 |
27 | |
22e2837f |
28 | my @tempfiles = (); |
29 | |
47de4e93 |
30 | sub get_temp_fh { |
22e2837f |
31 | my $f = "DummyModule0000"; |
32 | 1 while -e ++$f; |
33 | push @tempfiles, $f; |
34 | open my $fh, ">$f" or die "Can't create $f: $!"; |
3a5db825 |
35 | print $fh "package ".substr($_[0],0,-3).";\n1;\n"; |
36 | print $fh $_[1] if @_ > 1; |
d1e4d418 |
37 | close $fh or die "Couldn't close: $!"; |
47de4e93 |
38 | open $fh, $f or die "Can't open $f: $!"; |
39 | return $fh; |
40 | } |
f8973f08 |
41 | |
22e2837f |
42 | END { 1 while unlink @tempfiles } |
43 | |
e5d18500 |
44 | sub fooinc { |
45 | my ($self, $filename) = @_; |
46 | if (substr($filename,0,3) eq 'Foo') { |
47de4e93 |
47 | return get_temp_fh($filename); |
e5d18500 |
48 | } |
49 | else { |
f8973f08 |
50 | return undef; |
e5d18500 |
51 | } |
52 | } |
53 | |
54 | push @INC, \&fooinc; |
55 | |
d1e4d418 |
56 | my $evalret = eval { require Bar; 1 }; |
57 | ok( !$evalret, 'Trying non-magic package' ); |
58 | |
59 | $evalret = eval { require Foo; 1 }; |
60 | die $@ if $@; |
61 | ok( $evalret, 'require Foo; magic via code ref' ); |
62 | ok( exists $INC{'Foo.pm'}, ' %INC sees Foo.pm' ); |
63 | is( ref $INC{'Foo.pm'}, 'CODE', ' val Foo.pm is a coderef in %INC' ); |
64 | is( $INC{'Foo.pm'}, \&fooinc, ' val Foo.pm is correct in %INC' ); |
65 | |
66 | $evalret = eval "use Foo1; 1;"; |
67 | die $@ if $@; |
68 | ok( $evalret, 'use Foo1' ); |
69 | ok( exists $INC{'Foo1.pm'}, ' %INC sees Foo1.pm' ); |
70 | is( ref $INC{'Foo1.pm'}, 'CODE', ' val Foo1.pm is a coderef in %INC' ); |
71 | is( $INC{'Foo1.pm'}, \&fooinc, ' val Foo1.pm is correct in %INC' ); |
72 | |
73 | $evalret = eval { do 'Foo2.pl'; 1 }; |
74 | die $@ if $@; |
75 | ok( $evalret, 'do "Foo2.pl"' ); |
76 | ok( exists $INC{'Foo2.pl'}, ' %INC sees Foo2.pl' ); |
77 | is( ref $INC{'Foo2.pl'}, 'CODE', ' val Foo2.pl is a coderef in %INC' ); |
78 | is( $INC{'Foo2.pl'}, \&fooinc, ' val Foo2.pl is correct in %INC' ); |
e5d18500 |
79 | |
80 | pop @INC; |
81 | |
f8973f08 |
82 | |
e5d18500 |
83 | sub fooinc2 { |
84 | my ($self, $filename) = @_; |
85 | if (substr($filename, 0, length($self->[1])) eq $self->[1]) { |
47de4e93 |
86 | return get_temp_fh($filename); |
e5d18500 |
87 | } |
88 | else { |
f8973f08 |
89 | return undef; |
e5d18500 |
90 | } |
91 | } |
92 | |
47de4e93 |
93 | my $arrayref = [ \&fooinc2, 'Bar' ]; |
94 | push @INC, $arrayref; |
e5d18500 |
95 | |
d1e4d418 |
96 | $evalret = eval { require Foo; 1; }; |
97 | die $@ if $@; |
98 | ok( $evalret, 'Originally loaded packages preserved' ); |
99 | $evalret = eval { require Foo3; 1; }; |
100 | ok( !$evalret, 'Original magic INC purged' ); |
101 | |
102 | $evalret = eval { require Bar; 1 }; |
103 | die $@ if $@; |
104 | ok( $evalret, 'require Bar; magic via array ref' ); |
105 | ok( exists $INC{'Bar.pm'}, ' %INC sees Bar.pm' ); |
106 | is( ref $INC{'Bar.pm'}, 'ARRAY', ' val Bar.pm is an arrayref in %INC' ); |
107 | is( $INC{'Bar.pm'}, $arrayref, ' val Bar.pm is correct in %INC' ); |
108 | |
109 | ok( eval "use Bar1; 1;", 'use Bar1' ); |
110 | ok( exists $INC{'Bar1.pm'}, ' %INC sees Bar1.pm' ); |
111 | is( ref $INC{'Bar1.pm'}, 'ARRAY', ' val Bar1.pm is an arrayref in %INC' ); |
112 | is( $INC{'Bar1.pm'}, $arrayref, ' val Bar1.pm is correct in %INC' ); |
113 | |
114 | ok( eval { do 'Bar2.pl'; 1 }, 'do "Bar2.pl"' ); |
115 | ok( exists $INC{'Bar2.pl'}, ' %INC sees Bar2.pl' ); |
116 | is( ref $INC{'Bar2.pl'}, 'ARRAY', ' val Bar2.pl is an arrayref in %INC' ); |
117 | is( $INC{'Bar2.pl'}, $arrayref, ' val Bar2.pl is correct in %INC' ); |
e5d18500 |
118 | |
119 | pop @INC; |
120 | |
121 | sub FooLoader::INC { |
122 | my ($self, $filename) = @_; |
123 | if (substr($filename,0,4) eq 'Quux') { |
47de4e93 |
124 | return get_temp_fh($filename); |
e5d18500 |
125 | } |
126 | else { |
f8973f08 |
127 | return undef; |
e5d18500 |
128 | } |
129 | } |
130 | |
47de4e93 |
131 | my $href = bless( {}, 'FooLoader' ); |
132 | push @INC, $href; |
e5d18500 |
133 | |
d1e4d418 |
134 | $evalret = eval { require Quux; 1 }; |
135 | die $@ if $@; |
136 | ok( $evalret, 'require Quux; magic via hash object' ); |
137 | ok( exists $INC{'Quux.pm'}, ' %INC sees Quux.pm' ); |
6ece0f6b |
138 | is( ref $INC{'Quux.pm'}, 'FooLoader', |
d1e4d418 |
139 | ' val Quux.pm is an object in %INC' ); |
140 | is( $INC{'Quux.pm'}, $href, ' val Quux.pm is correct in %INC' ); |
e5d18500 |
141 | |
142 | pop @INC; |
143 | |
47de4e93 |
144 | my $aref = bless( [], 'FooLoader' ); |
145 | push @INC, $aref; |
e5d18500 |
146 | |
d1e4d418 |
147 | $evalret = eval { require Quux1; 1 }; |
148 | die $@ if $@; |
149 | ok( $evalret, 'require Quux1; magic via array object' ); |
150 | ok( exists $INC{'Quux1.pm'}, ' %INC sees Quux1.pm' ); |
6ece0f6b |
151 | is( ref $INC{'Quux1.pm'}, 'FooLoader', |
d1e4d418 |
152 | ' val Quux1.pm is an object in %INC' ); |
153 | is( $INC{'Quux1.pm'}, $aref, ' val Quux1.pm is correct in %INC' ); |
e5d18500 |
154 | |
155 | pop @INC; |
156 | |
47de4e93 |
157 | my $sref = bless( \(my $x = 1), 'FooLoader' ); |
158 | push @INC, $sref; |
e5d18500 |
159 | |
d1e4d418 |
160 | $evalret = eval { require Quux2; 1 }; |
161 | die $@ if $@; |
162 | ok( $evalret, 'require Quux2; magic via scalar object' ); |
163 | ok( exists $INC{'Quux2.pm'}, ' %INC sees Quux2.pm' ); |
6ece0f6b |
164 | is( ref $INC{'Quux2.pm'}, 'FooLoader', |
d1e4d418 |
165 | ' val Quux2.pm is an object in %INC' ); |
166 | is( $INC{'Quux2.pm'}, $sref, ' val Quux2.pm is correct in %INC' ); |
f8973f08 |
167 | |
168 | pop @INC; |
9ae8cd5b |
169 | |
170 | push @INC, sub { |
171 | my ($self, $filename) = @_; |
172 | if (substr($filename,0,4) eq 'Toto') { |
173 | $INC{$filename} = 'xyz'; |
174 | return get_temp_fh($filename); |
175 | } |
176 | else { |
177 | return undef; |
178 | } |
179 | }; |
180 | |
d1e4d418 |
181 | $evalret = eval { require Toto; 1 }; |
182 | die $@ if $@; |
183 | ok( $evalret, 'require Toto; magic via anonymous code ref' ); |
184 | ok( exists $INC{'Toto.pm'}, ' %INC sees Toto.pm' ); |
185 | ok( ! ref $INC{'Toto.pm'}, q/ val Toto.pm isn't a ref in %INC/ ); |
186 | is( $INC{'Toto.pm'}, 'xyz', ' val Toto.pm is correct in %INC' ); |
9ae8cd5b |
187 | |
188 | pop @INC; |
d820be44 |
189 | |
3a5db825 |
190 | push @INC, sub { |
191 | my ($self, $filename) = @_; |
192 | if ($filename eq 'abc.pl') { |
193 | return get_temp_fh($filename, qq(return "abc";\n)); |
194 | } |
195 | else { |
196 | return undef; |
197 | } |
198 | }; |
199 | |
6b75eab3 |
200 | my $ret = ""; |
3a5db825 |
201 | $ret ||= do 'abc.pl'; |
202 | is( $ret, 'abc', 'do "abc.pl" sees return value' ); |
203 | |
ab742322 |
204 | { |
205 | my $filename = $^O eq 'MacOS' ? ':Foo:Foo.pm' : './Foo.pm'; |
c38a6530 |
206 | #local @INC; # local fails on tied @INC |
207 | my @old_INC = @INC; # because local doesn't work on tied arrays |
ab742322 |
208 | @INC = sub { $filename = 'seen'; return undef; }; |
209 | eval { require $filename; }; |
210 | is( $filename, 'seen', 'the coderef sees fully-qualified pathnames' ); |
c38a6530 |
211 | @INC = @old_INC; |
ab742322 |
212 | } |
213 | |
6e592b3a |
214 | # this will segfault if it fails |
215 | |
216 | sub PVBM () { 'foo' } |
217 | { my $dummy = index 'foo', PVBM } |
218 | |
219 | # I don't know whether these requires should succeed or fail. 5.8 failed |
220 | # all of them; 5.10 with an ordinary constant in place of PVBM lets the |
221 | # latter two succeed. For now I don't care, as long as they don't |
222 | # segfault :). |
223 | |
224 | unshift @INC, sub { PVBM }; |
225 | eval 'require foo'; |
226 | ok( 1, 'returning PVBM doesn\'t segfault require' ); |
227 | eval 'use foo'; |
228 | ok( 1, 'returning PVBM doesn\'t segfault use' ); |
229 | shift @INC; |
230 | unshift @INC, sub { \PVBM }; |
231 | eval 'require foo'; |
232 | ok( 1, 'returning PVBM ref doesn\'t segfault require' ); |
233 | eval 'use foo'; |
234 | ok( 1, 'returning PVBM ref doesn\'t segfault use' ); |
235 | shift @INC; |
236 | |
ab742322 |
237 | exit if $minitest; |
238 | |
240b6766 |
239 | SKIP: { |
240 | skip( "No PerlIO available", 3 ) unless $has_perlio; |
241 | pop @INC; |
242 | |
243 | push @INC, sub { |
244 | my ($cr, $filename) = @_; |
245 | my $module = $filename; $module =~ s,/,::,g; $module =~ s/\.pm$//; |
246 | open my $fh, '<', |
247 | \"package $module; sub complain { warn q() }; \$::file = __FILE__;" |
248 | or die $!; |
249 | $INC{$filename} = "/custom/path/to/$filename"; |
250 | return $fh; |
251 | }; |
252 | |
253 | require Publius::Vergilius::Maro; |
254 | is( $INC{'Publius/Vergilius/Maro.pm'}, |
255 | '/custom/path/to/Publius/Vergilius/Maro.pm', '%INC set correctly'); |
256 | is( our $file, '/custom/path/to/Publius/Vergilius/Maro.pm', |
257 | '__FILE__ set correctly' ); |
258 | { |
259 | my $warning; |
260 | local $SIG{__WARN__} = sub { $warning = shift }; |
261 | Publius::Vergilius::Maro::complain(); |
262 | like( $warning, qr{something's wrong at /custom/path/to/Publius/Vergilius/Maro.pm}, 'warn() reports correct file source' ); |
263 | } |
a3b58a99 |
264 | } |
a3b58a99 |
265 | pop @INC; |
266 | |
6b75eab3 |
267 | if ($can_fork) { |
268 | require PerlIO::scalar; |
269 | # This little bundle of joy generates n more recursive use statements, |
270 | # with each module chaining the next one down to 0. If it works, then we |
271 | # can safely nest subprocesses |
272 | my $use_filter_too; |
273 | push @INC, sub { |
274 | return unless $_[1] =~ /^BBBLPLAST(\d+)\.pm/; |
275 | my $pid = open my $fh, "-|"; |
276 | if ($pid) { |
277 | # Parent |
278 | return $fh unless $use_filter_too; |
279 | # Try filters and state in addition. |
280 | return ($fh, sub {s/$_[1]/pass/; return}, "die") |
281 | } |
282 | die "Can't fork self: $!" unless defined $pid; |
283 | |
284 | # Child |
285 | my $count = $1; |
286 | # Lets force some fun with odd sized reads. |
287 | $| = 1; |
288 | print 'push @main::bbblplast, '; |
289 | print "$count;\n"; |
290 | if ($count--) { |
291 | print "use BBBLPLAST$count;\n"; |
292 | } |
293 | if ($use_filter_too) { |
294 | print "die('In $_[1]');"; |
295 | } else { |
296 | print "pass('In $_[1]');"; |
297 | } |
298 | print '"Truth"'; |
299 | POSIX::_exit(0); |
300 | die "Can't get here: $!"; |
301 | }; |
302 | |
303 | @::bbblplast = (); |
304 | require BBBLPLAST5; |
305 | is ("@::bbblplast", "0 1 2 3 4 5", "All ran"); |
306 | |
307 | foreach (keys %INC) { |
308 | delete $INC{$_} if /^BBBLPLAST/; |
309 | } |
310 | |
311 | @::bbblplast = (); |
312 | $use_filter_too = 1; |
313 | |
314 | require BBBLPLAST5; |
315 | |
316 | is ("@::bbblplast", "0 1 2 3 4 5", "All ran with a filter"); |
317 | } |