1#!./perl -w 2 3# Tests for the coderef-in-@INC feature 4 5BEGIN { 6 chdir 't' if -d 't'; 7 require './test.pl'; 8 set_up_inc('../lib'); 9} 10 11use Config; 12 13my $can_fork = 0; 14my $has_perlio = $Config{useperlio}; 15 16unless (is_miniperl()) { 17 if ($Config{d_fork} && eval 'require POSIX; 1') { 18 $can_fork = 1; 19 } 20} 21 22use strict; 23 24plan(tests => 71 + !is_miniperl() * (4 + 14 * $can_fork)); 25 26sub get_temp_fh { 27 my $f = tempfile(); 28 open my $fh, ">$f" or die "Can't create $f: $!"; 29 print $fh "package ".substr($_[0],0,-3).";\n1;\n"; 30 print $fh $_[1] if @_ > 1; 31 close $fh or die "Couldn't close: $!"; 32 open $fh, $f or die "Can't open $f: $!"; 33 return $fh; 34} 35 36sub fooinc { 37 my ($self, $filename) = @_; 38 if (substr($filename,0,3) eq 'Foo') { 39 return get_temp_fh($filename); 40 } 41 else { 42 return undef; 43 } 44} 45 46push @INC, \&fooinc; 47 48my $evalret = eval { require Bar; 1 }; 49ok( !$evalret, 'Trying non-magic package' ); 50 51$evalret = eval { require Foo; 1 }; 52die $@ if $@; 53ok( $evalret, 'require Foo; magic via code ref' ); 54ok( exists $INC{'Foo.pm'}, ' %INC sees Foo.pm' ); 55is( ref $INC{'Foo.pm'}, 'CODE', ' val Foo.pm is a coderef in %INC' ); 56is( $INC{'Foo.pm'}, \&fooinc, ' val Foo.pm is correct in %INC' ); 57 58$evalret = eval "use Foo1; 1;"; 59die $@ if $@; 60ok( $evalret, 'use Foo1' ); 61ok( exists $INC{'Foo1.pm'}, ' %INC sees Foo1.pm' ); 62is( ref $INC{'Foo1.pm'}, 'CODE', ' val Foo1.pm is a coderef in %INC' ); 63is( $INC{'Foo1.pm'}, \&fooinc, ' val Foo1.pm is correct in %INC' ); 64 65$evalret = eval { do 'Foo2.pl'; 1 }; 66die $@ if $@; 67ok( $evalret, 'do "Foo2.pl"' ); 68ok( exists $INC{'Foo2.pl'}, ' %INC sees Foo2.pl' ); 69is( ref $INC{'Foo2.pl'}, 'CODE', ' val Foo2.pl is a coderef in %INC' ); 70is( $INC{'Foo2.pl'}, \&fooinc, ' val Foo2.pl is correct in %INC' ); 71 72pop @INC; 73 74 75sub fooinc2 { 76 my ($self, $filename) = @_; 77 if (substr($filename, 0, length($self->[1])) eq $self->[1]) { 78 return get_temp_fh($filename); 79 } 80 else { 81 return undef; 82 } 83} 84 85my $arrayref = [ \&fooinc2, 'Bar' ]; 86push @INC, $arrayref; 87 88$evalret = eval { require Foo; 1; }; 89die $@ if $@; 90ok( $evalret, 'Originally loaded packages preserved' ); 91$evalret = eval { require Foo3; 1; }; 92ok( !$evalret, 'Original magic INC purged' ); 93 94$evalret = eval { require Bar; 1 }; 95die $@ if $@; 96ok( $evalret, 'require Bar; magic via array ref' ); 97ok( exists $INC{'Bar.pm'}, ' %INC sees Bar.pm' ); 98is( ref $INC{'Bar.pm'}, 'ARRAY', ' val Bar.pm is an arrayref in %INC' ); 99is( $INC{'Bar.pm'}, $arrayref, ' val Bar.pm is correct in %INC' ); 100 101ok( eval "use Bar1; 1;", 'use Bar1' ); 102ok( exists $INC{'Bar1.pm'}, ' %INC sees Bar1.pm' ); 103is( ref $INC{'Bar1.pm'}, 'ARRAY', ' val Bar1.pm is an arrayref in %INC' ); 104is( $INC{'Bar1.pm'}, $arrayref, ' val Bar1.pm is correct in %INC' ); 105 106ok( eval { do 'Bar2.pl'; 1 }, 'do "Bar2.pl"' ); 107ok( exists $INC{'Bar2.pl'}, ' %INC sees Bar2.pl' ); 108is( ref $INC{'Bar2.pl'}, 'ARRAY', ' val Bar2.pl is an arrayref in %INC' ); 109is( $INC{'Bar2.pl'}, $arrayref, ' val Bar2.pl is correct in %INC' ); 110 111pop @INC; 112 113sub FooLoader::INC { 114 my ($self, $filename) = @_; 115 if (substr($filename,0,4) eq 'Quux') { 116 return get_temp_fh($filename); 117 } 118 else { 119 return undef; 120 } 121} 122 123my $href = bless( {}, 'FooLoader' ); 124push @INC, $href; 125 126$evalret = eval { require Quux; 1 }; 127die $@ if $@; 128ok( $evalret, 'require Quux; magic via hash object' ); 129ok( exists $INC{'Quux.pm'}, ' %INC sees Quux.pm' ); 130is( ref $INC{'Quux.pm'}, 'FooLoader', 131 ' val Quux.pm is an object in %INC' ); 132is( $INC{'Quux.pm'}, $href, ' val Quux.pm is correct in %INC' ); 133 134pop @INC; 135 136my $aref = bless( [], 'FooLoader' ); 137push @INC, $aref; 138 139$evalret = eval { require Quux1; 1 }; 140die $@ if $@; 141ok( $evalret, 'require Quux1; magic via array object' ); 142ok( exists $INC{'Quux1.pm'}, ' %INC sees Quux1.pm' ); 143is( ref $INC{'Quux1.pm'}, 'FooLoader', 144 ' val Quux1.pm is an object in %INC' ); 145is( $INC{'Quux1.pm'}, $aref, ' val Quux1.pm is correct in %INC' ); 146 147pop @INC; 148 149my $sref = bless( \(my $x = 1), 'FooLoader' ); 150push @INC, $sref; 151 152$evalret = eval { require Quux2; 1 }; 153die $@ if $@; 154ok( $evalret, 'require Quux2; magic via scalar object' ); 155ok( exists $INC{'Quux2.pm'}, ' %INC sees Quux2.pm' ); 156is( ref $INC{'Quux2.pm'}, 'FooLoader', 157 ' val Quux2.pm is an object in %INC' ); 158is( $INC{'Quux2.pm'}, $sref, ' val Quux2.pm is correct in %INC' ); 159 160pop @INC; 161 162push @INC, sub { 163 my ($self, $filename) = @_; 164 if (substr($filename,0,4) eq 'Toto') { 165 $INC{$filename} = 'xyz'; 166 return get_temp_fh($filename); 167 } 168 else { 169 return undef; 170 } 171}; 172 173$evalret = eval { require Toto; 1 }; 174die $@ if $@; 175ok( $evalret, 'require Toto; magic via anonymous code ref' ); 176ok( exists $INC{'Toto.pm'}, ' %INC sees Toto.pm' ); 177ok( ! ref $INC{'Toto.pm'}, q/ val Toto.pm isn't a ref in %INC/ ); 178is( $INC{'Toto.pm'}, 'xyz', ' val Toto.pm is correct in %INC' ); 179 180pop @INC; 181 182{ 183 my $autoloaded; 184 package AutoInc { 185 sub AUTOLOAD { 186 my ($self, $filename) = @_; 187 $autoloaded = our $AUTOLOAD; 188 return ::get_temp_fh($filename); 189 } 190 sub DESTROY {} 191 } 192 193 push @INC, bless {}, "AutoInc"; 194 $evalret = eval { require Quux3; 1 }; 195 ok($evalret, "require Quux3 via AUTOLOADed INC"); 196 ok(exists $INC{"Quux3.pm"}, "Quux3 in %INC"); 197 is($autoloaded, "AutoInc::INC", "AUTOLOAD was called for INC"); 198 199 pop @INC; 200} 201 202push @INC, sub { 203 my ($self, $filename) = @_; 204 if ($filename eq 'abc.pl') { 205 return get_temp_fh($filename, qq(return "abc";\n)); 206 } 207 else { 208 return undef; 209 } 210}; 211 212my $ret = ""; 213$ret ||= do 'abc.pl'; 214is( $ret, 'abc', 'do "abc.pl" sees return value' ); 215 216{ 217 my $got; 218 #local @INC; # local fails on tied @INC 219 my @old_INC = @INC; # because local doesn't work on tied arrays 220 @INC = ('lib', 'lib/Devel', sub { $got = $_[1]; return undef; }); 221 foreach my $filename ('/test_require.pm', './test_require.pm', 222 '../test_require.pm') { 223 local %INC; 224 undef $got; 225 undef $test_require::loaded; 226 eval { require $filename; }; 227 is($got, $filename, "the coderef sees the pathname $filename"); 228 is($test_require::loaded, undef, 'no module is loaded' ); 229 } 230 231 local %INC; 232 undef $got; 233 undef $test_require::loaded; 234 235 eval { require 'test_require.pm'; }; 236 is($got, undef, 'the directory is scanned for test_require.pm'); 237 is($test_require::loaded, 1, 'the module is loaded'); 238 @INC = @old_INC; 239} 240 241# this will segfault if it fails 242 243sub PVBM () { 'foo' } 244{ my $dummy = index 'foo', PVBM } 245 246# I don't know whether these requires should succeed or fail. 5.8 failed 247# all of them; 5.10 with an ordinary constant in place of PVBM lets the 248# latter two succeed. For now I don't care, as long as they don't 249# segfault :). 250 251unshift @INC, sub { PVBM }; 252eval 'require foo'; 253ok( 1, 'returning PVBM doesn\'t segfault require' ); 254eval 'use foo'; 255ok( 1, 'returning PVBM doesn\'t segfault use' ); 256shift @INC; 257unshift @INC, sub { \PVBM }; 258eval 'require foo'; 259ok( 1, 'returning PVBM ref doesn\'t segfault require' ); 260eval 'use foo'; 261ok( 1, 'returning PVBM ref doesn\'t segfault use' ); 262shift @INC; 263 264# [perl #92252] 265{ 266 my $die = sub { die }; 267 my $data = []; 268 unshift @INC, sub { $die, $data }; 269 270 # + 1 to account for prototype-defeating &... calling convention 271 my $initial_sub_refcnt = &Internals::SvREFCNT($die) + 1; 272 my $initial_data_refcnt = &Internals::SvREFCNT($data) + 1; 273 274 do "foo"; 275 refcount_is $die, $initial_sub_refcnt, "no leaks"; 276 refcount_is $data, $initial_data_refcnt, "no leaks"; 277 278 do "bar"; 279 refcount_is $die, $initial_sub_refcnt, "no leaks"; 280 refcount_is $data, $initial_data_refcnt, "no leaks"; 281 282 shift @INC; 283} 284 285unshift @INC, sub { \(my $tmp = '$_ = "are temps freed prematurely?"') }; 286eval { require foom }; 287is $_||$@, "are temps freed prematurely?", 288 "are temps freed prematurely when returned from inc filters?"; 289shift @INC; 290 291# [perl #120657] 292sub fake_module { 293 my (undef,$module_file) = @_; 294 !1 295} 296{ 297 local @INC = @INC; 298 @INC = (\&fake_module)x2; 299 eval { require "${\'bralbalhablah'}" }; 300 like $@, qr/^Can't locate/, 301 'require PADTMP passing freed var when @INC has multiple subs'; 302} 303 304SKIP: { 305 skip ("Not applicable when run from inccode-tie.t", 6) if tied @INC; 306 require Tie::Scalar; 307 package INCtie { 308 sub TIESCALAR { bless \my $foo } 309 sub FETCH { study; our $count++; ${$_[0]} } 310 } 311 local @INC = undef; 312 my $t = tie $INC[0], 'INCtie'; 313 my $called; 314 $$t = sub { $called ++; !1 }; 315 delete $INC{'foo.pm'}; # in case another test uses foo 316 eval { require foo }; 317 is $INCtie::count, 1, 318 'FETCH is called once on undef scalar-tied @INC elem'; 319 is $called, 1, 'sub in scalar-tied @INC elem is called'; 320 () = "$INC[0]"; # force a fetch, so the SV is ROK 321 $INCtie::count = 0; 322 eval { require foo }; 323 is $INCtie::count, 1, 324 'FETCH is called once on scalar-tied @INC elem holding ref'; 325 is $called, 2, 'sub in scalar-tied @INC elem holding ref is called'; 326 $$t = []; 327 $INCtie::count = 0; 328 eval { require foo }; 329 is $INCtie::count, 1, 330 'FETCH called once on scalar-tied @INC elem returning array'; 331 $$t = "string"; 332 $INCtie::count = 0; 333 eval { require foo }; 334 is $INCtie::count, 1, 335 'FETCH called once on scalar-tied @INC elem returning string'; 336} 337 338 339exit if is_miniperl(); 340 341SKIP: { 342 skip( "No PerlIO available", 3 ) unless $has_perlio; 343 pop @INC; 344 345 push @INC, sub { 346 my ($cr, $filename) = @_; 347 my $module = $filename; $module =~ s,/,::,g; $module =~ s/\.pm$//; 348 open my $fh, '<', 349 \"package $module; sub complain { warn q() }; \$::file = __FILE__;" 350 or die $!; 351 $INC{$filename} = "/custom/path/to/$filename"; 352 return $fh; 353 }; 354 355 require Publius::Vergilius::Maro; 356 is( $INC{'Publius/Vergilius/Maro.pm'}, 357 '/custom/path/to/Publius/Vergilius/Maro.pm', '%INC set correctly'); 358 is( our $file, '/custom/path/to/Publius/Vergilius/Maro.pm', 359 '__FILE__ set correctly' ); 360 { 361 my $warning; 362 local $SIG{__WARN__} = sub { $warning = shift }; 363 Publius::Vergilius::Maro::complain(); 364 like( $warning, qr{something's wrong at /custom/path/to/Publius/Vergilius/Maro.pm}, 'warn() reports correct file source' ); 365 } 366} 367pop @INC; 368 369if ($can_fork) { 370 # This little bundle of joy generates n more recursive use statements, 371 # with each module chaining the next one down to 0. If it works, then we 372 # can safely nest subprocesses 373 my $use_filter_too; 374 push @INC, sub { 375 return unless $_[1] =~ /^BBBLPLAST(\d+)\.pm/; 376 my $pid = open my $fh, "-|"; 377 if ($pid) { 378 # Parent 379 return $fh unless $use_filter_too; 380 # Try filters and state in addition. 381 return ($fh, sub {s/$_[1]/pass/; return}, "die") 382 } 383 die "Can't fork self: $!" unless defined $pid; 384 385 # Child 386 my $count = $1; 387 # Lets force some fun with odd sized reads. 388 $| = 1; 389 print 'push @main::bbblplast, '; 390 print "$count;\n"; 391 if ($count--) { 392 print "use BBBLPLAST$count;\n"; 393 } 394 if ($use_filter_too) { 395 print "die('In $_[1]');"; 396 } else { 397 print "pass('In $_[1]');"; 398 } 399 print '"Truth"'; 400 POSIX::_exit(0); 401 die "Can't get here: $!"; 402 }; 403 404 @::bbblplast = (); 405 require BBBLPLAST5; 406 is ("@::bbblplast", "0 1 2 3 4 5", "All ran"); 407 408 foreach (keys %INC) { 409 delete $INC{$_} if /^BBBLPLAST/; 410 } 411 412 @::bbblplast = (); 413 $use_filter_too = 1; 414 415 require BBBLPLAST5; 416 417 is ("@::bbblplast", "0 1 2 3 4 5", "All ran with a filter"); 418} 419SKIP:{ 420 skip "need fork",1 unless $can_fork; 421 fresh_perl_like('@INC=("A",bless({},"Hook"),"D"); ' 422 .'sub Hook::INCDIR { return "B","C"} ' 423 .'eval "require Frobnitz" or print $@;', 424 qr/\(\@INC[\w ]+: A Hook=HASH\(0x[A-Fa-f0-9]+\) B C D\)/, 425 {}, 426 "Check if INCDIR hook works as expected"); 427} 428