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 => 68 + !is_miniperl() * (3 + 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 182push @INC, sub { 183 my ($self, $filename) = @_; 184 if ($filename eq 'abc.pl') { 185 return get_temp_fh($filename, qq(return "abc";\n)); 186 } 187 else { 188 return undef; 189 } 190}; 191 192my $ret = ""; 193$ret ||= do 'abc.pl'; 194is( $ret, 'abc', 'do "abc.pl" sees return value' ); 195 196{ 197 my $got; 198 #local @INC; # local fails on tied @INC 199 my @old_INC = @INC; # because local doesn't work on tied arrays 200 @INC = ('lib', 'lib/Devel', sub { $got = $_[1]; return undef; }); 201 foreach my $filename ('/test_require.pm', './test_require.pm', 202 '../test_require.pm') { 203 local %INC; 204 undef $got; 205 undef $test_require::loaded; 206 eval { require $filename; }; 207 is($got, $filename, "the coderef sees the pathname $filename"); 208 is($test_require::loaded, undef, 'no module is loaded' ); 209 } 210 211 local %INC; 212 undef $got; 213 undef $test_require::loaded; 214 215 eval { require 'test_require.pm'; }; 216 is($got, undef, 'the directory is scanned for test_require.pm'); 217 is($test_require::loaded, 1, 'the module is loaded'); 218 @INC = @old_INC; 219} 220 221# this will segfault if it fails 222 223sub PVBM () { 'foo' } 224{ my $dummy = index 'foo', PVBM } 225 226# I don't know whether these requires should succeed or fail. 5.8 failed 227# all of them; 5.10 with an ordinary constant in place of PVBM lets the 228# latter two succeed. For now I don't care, as long as they don't 229# segfault :). 230 231unshift @INC, sub { PVBM }; 232eval 'require foo'; 233ok( 1, 'returning PVBM doesn\'t segfault require' ); 234eval 'use foo'; 235ok( 1, 'returning PVBM doesn\'t segfault use' ); 236shift @INC; 237unshift @INC, sub { \PVBM }; 238eval 'require foo'; 239ok( 1, 'returning PVBM ref doesn\'t segfault require' ); 240eval 'use foo'; 241ok( 1, 'returning PVBM ref doesn\'t segfault use' ); 242shift @INC; 243 244# [perl #92252] 245{ 246 my $die = sub { die }; 247 my $data = []; 248 unshift @INC, sub { $die, $data }; 249 250 my $initial_sub_refcnt = &Internals::SvREFCNT($die); 251 my $initial_data_refcnt = &Internals::SvREFCNT($data); 252 253 do "foo"; 254 is(&Internals::SvREFCNT($die), $initial_sub_refcnt, "no leaks"); 255 is(&Internals::SvREFCNT($data), $initial_data_refcnt, "no leaks"); 256 257 do "bar"; 258 is(&Internals::SvREFCNT($die), $initial_sub_refcnt, "no leaks"); 259 is(&Internals::SvREFCNT($data), $initial_data_refcnt, "no leaks"); 260 261 shift @INC; 262} 263 264unshift @INC, sub { \(my $tmp = '$_ = "are temps freed prematurely?"') }; 265eval { require foom }; 266is $_||$@, "are temps freed prematurely?", 267 "are temps freed prematurely when returned from inc filters?"; 268shift @INC; 269 270# [perl #120657] 271sub fake_module { 272 my (undef,$module_file) = @_; 273 !1 274} 275{ 276 local @INC = @INC; 277 @INC = (\&fake_module)x2; 278 eval { require "${\'bralbalhablah'}" }; 279 like $@, qr/^Can't locate/, 280 'require PADTMP passing freed var when @INC has multiple subs'; 281} 282 283SKIP: { 284 skip ("Not applicable when run from inccode-tie.t", 6) if tied @INC; 285 require Tie::Scalar; 286 package INCtie { 287 sub TIESCALAR { bless \my $foo } 288 sub FETCH { study; our $count++; ${$_[0]} } 289 } 290 local @INC = undef; 291 my $t = tie $INC[0], 'INCtie'; 292 my $called; 293 $$t = sub { $called ++; !1 }; 294 delete $INC{'foo.pm'}; # in case another test uses foo 295 eval { require foo }; 296 is $INCtie::count, 2, # 2nd time for "Can't locate" -- XXX correct? 297 'FETCH is called once on undef scalar-tied @INC elem'; 298 is $called, 1, 'sub in scalar-tied @INC elem is called'; 299 () = "$INC[0]"; # force a fetch, so the SV is ROK 300 $INCtie::count = 0; 301 eval { require foo }; 302 is $INCtie::count, 2, 303 'FETCH is called once on scalar-tied @INC elem holding ref'; 304 is $called, 2, 'sub in scalar-tied @INC elem holding ref is called'; 305 $$t = []; 306 $INCtie::count = 0; 307 eval { require foo }; 308 is $INCtie::count, 1, 309 'FETCH called once on scalar-tied @INC elem returning array'; 310 $$t = "string"; 311 $INCtie::count = 0; 312 eval { require foo }; 313 is $INCtie::count, 2, 314 'FETCH called once on scalar-tied @INC elem returning string'; 315} 316 317 318exit if is_miniperl(); 319 320SKIP: { 321 skip( "No PerlIO available", 3 ) unless $has_perlio; 322 pop @INC; 323 324 push @INC, sub { 325 my ($cr, $filename) = @_; 326 my $module = $filename; $module =~ s,/,::,g; $module =~ s/\.pm$//; 327 open my $fh, '<', 328 \"package $module; sub complain { warn q() }; \$::file = __FILE__;" 329 or die $!; 330 $INC{$filename} = "/custom/path/to/$filename"; 331 return $fh; 332 }; 333 334 require Publius::Vergilius::Maro; 335 is( $INC{'Publius/Vergilius/Maro.pm'}, 336 '/custom/path/to/Publius/Vergilius/Maro.pm', '%INC set correctly'); 337 is( our $file, '/custom/path/to/Publius/Vergilius/Maro.pm', 338 '__FILE__ set correctly' ); 339 { 340 my $warning; 341 local $SIG{__WARN__} = sub { $warning = shift }; 342 Publius::Vergilius::Maro::complain(); 343 like( $warning, qr{something's wrong at /custom/path/to/Publius/Vergilius/Maro.pm}, 'warn() reports correct file source' ); 344 } 345} 346pop @INC; 347 348if ($can_fork) { 349 require PerlIO::scalar; 350 # This little bundle of joy generates n more recursive use statements, 351 # with each module chaining the next one down to 0. If it works, then we 352 # can safely nest subprocesses 353 my $use_filter_too; 354 push @INC, sub { 355 return unless $_[1] =~ /^BBBLPLAST(\d+)\.pm/; 356 my $pid = open my $fh, "-|"; 357 if ($pid) { 358 # Parent 359 return $fh unless $use_filter_too; 360 # Try filters and state in addition. 361 return ($fh, sub {s/$_[1]/pass/; return}, "die") 362 } 363 die "Can't fork self: $!" unless defined $pid; 364 365 # Child 366 my $count = $1; 367 # Lets force some fun with odd sized reads. 368 $| = 1; 369 print 'push @main::bbblplast, '; 370 print "$count;\n"; 371 if ($count--) { 372 print "use BBBLPLAST$count;\n"; 373 } 374 if ($use_filter_too) { 375 print "die('In $_[1]');"; 376 } else { 377 print "pass('In $_[1]');"; 378 } 379 print '"Truth"'; 380 POSIX::_exit(0); 381 die "Can't get here: $!"; 382 }; 383 384 @::bbblplast = (); 385 require BBBLPLAST5; 386 is ("@::bbblplast", "0 1 2 3 4 5", "All ran"); 387 388 foreach (keys %INC) { 389 delete $INC{$_} if /^BBBLPLAST/; 390 } 391 392 @::bbblplast = (); 393 $use_filter_too = 1; 394 395 require BBBLPLAST5; 396 397 is ("@::bbblplast", "0 1 2 3 4 5", "All ran with a filter"); 398} 399