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