1#!./perl -w 2 3# Tests for the coderef-in-@INC feature 4 5BEGIN { 6 chdir 't' if -d 't'; 7 @INC = qw(. ../lib); 8 require './test.pl'; 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 => 60 + !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 264exit if is_miniperl(); 265 266SKIP: { 267 skip( "No PerlIO available", 3 ) unless $has_perlio; 268 pop @INC; 269 270 push @INC, sub { 271 my ($cr, $filename) = @_; 272 my $module = $filename; $module =~ s,/,::,g; $module =~ s/\.pm$//; 273 open my $fh, '<', 274 \"package $module; sub complain { warn q() }; \$::file = __FILE__;" 275 or die $!; 276 $INC{$filename} = "/custom/path/to/$filename"; 277 return $fh; 278 }; 279 280 require Publius::Vergilius::Maro; 281 is( $INC{'Publius/Vergilius/Maro.pm'}, 282 '/custom/path/to/Publius/Vergilius/Maro.pm', '%INC set correctly'); 283 is( our $file, '/custom/path/to/Publius/Vergilius/Maro.pm', 284 '__FILE__ set correctly' ); 285 { 286 my $warning; 287 local $SIG{__WARN__} = sub { $warning = shift }; 288 Publius::Vergilius::Maro::complain(); 289 like( $warning, qr{something's wrong at /custom/path/to/Publius/Vergilius/Maro.pm}, 'warn() reports correct file source' ); 290 } 291} 292pop @INC; 293 294if ($can_fork) { 295 require PerlIO::scalar; 296 # This little bundle of joy generates n more recursive use statements, 297 # with each module chaining the next one down to 0. If it works, then we 298 # can safely nest subprocesses 299 my $use_filter_too; 300 push @INC, sub { 301 return unless $_[1] =~ /^BBBLPLAST(\d+)\.pm/; 302 my $pid = open my $fh, "-|"; 303 if ($pid) { 304 # Parent 305 return $fh unless $use_filter_too; 306 # Try filters and state in addition. 307 return ($fh, sub {s/$_[1]/pass/; return}, "die") 308 } 309 die "Can't fork self: $!" unless defined $pid; 310 311 # Child 312 my $count = $1; 313 # Lets force some fun with odd sized reads. 314 $| = 1; 315 print 'push @main::bbblplast, '; 316 print "$count;\n"; 317 if ($count--) { 318 print "use BBBLPLAST$count;\n"; 319 } 320 if ($use_filter_too) { 321 print "die('In $_[1]');"; 322 } else { 323 print "pass('In $_[1]');"; 324 } 325 print '"Truth"'; 326 POSIX::_exit(0); 327 die "Can't get here: $!"; 328 }; 329 330 @::bbblplast = (); 331 require BBBLPLAST5; 332 is ("@::bbblplast", "0 1 2 3 4 5", "All ran"); 333 334 foreach (keys %INC) { 335 delete $INC{$_} if /^BBBLPLAST/; 336 } 337 338 @::bbblplast = (); 339 $use_filter_too = 1; 340 341 require BBBLPLAST5; 342 343 is ("@::bbblplast", "0 1 2 3 4 5", "All ran with a filter"); 344} 345