1#!./perl -w 2 3# Tests for the coderef-in-@INC feature 4 5use Config; 6 7my $can_fork = 0; 8my $minitest = $ENV{PERL_CORE_MINITEST}; 9my $has_perlio = $Config{useperlio}; 10 11BEGIN { 12 chdir 't' if -d 't'; 13 @INC = qw(. ../lib); 14} 15 16if (!$minitest) { 17 if ($Config{d_fork} && eval 'require POSIX; 1') { 18 $can_fork = 1; 19 } 20} 21 22use strict; 23use File::Spec; 24 25require "test.pl"; 26plan(tests => 49 + !$minitest * (3 + 14 * $can_fork)); 27 28sub get_temp_fh { 29 my $f = tempfile(); 30 open my $fh, ">$f" or die "Can't create $f: $!"; 31 print $fh "package ".substr($_[0],0,-3).";\n1;\n"; 32 print $fh $_[1] if @_ > 1; 33 close $fh or die "Couldn't close: $!"; 34 open $fh, $f or die "Can't open $f: $!"; 35 return $fh; 36} 37 38sub fooinc { 39 my ($self, $filename) = @_; 40 if (substr($filename,0,3) eq 'Foo') { 41 return get_temp_fh($filename); 42 } 43 else { 44 return undef; 45 } 46} 47 48push @INC, \&fooinc; 49 50my $evalret = eval { require Bar; 1 }; 51ok( !$evalret, 'Trying non-magic package' ); 52 53$evalret = eval { require Foo; 1 }; 54die $@ if $@; 55ok( $evalret, 'require Foo; magic via code ref' ); 56ok( exists $INC{'Foo.pm'}, ' %INC sees Foo.pm' ); 57is( ref $INC{'Foo.pm'}, 'CODE', ' val Foo.pm is a coderef in %INC' ); 58is( $INC{'Foo.pm'}, \&fooinc, ' val Foo.pm is correct in %INC' ); 59 60$evalret = eval "use Foo1; 1;"; 61die $@ if $@; 62ok( $evalret, 'use Foo1' ); 63ok( exists $INC{'Foo1.pm'}, ' %INC sees Foo1.pm' ); 64is( ref $INC{'Foo1.pm'}, 'CODE', ' val Foo1.pm is a coderef in %INC' ); 65is( $INC{'Foo1.pm'}, \&fooinc, ' val Foo1.pm is correct in %INC' ); 66 67$evalret = eval { do 'Foo2.pl'; 1 }; 68die $@ if $@; 69ok( $evalret, 'do "Foo2.pl"' ); 70ok( exists $INC{'Foo2.pl'}, ' %INC sees Foo2.pl' ); 71is( ref $INC{'Foo2.pl'}, 'CODE', ' val Foo2.pl is a coderef in %INC' ); 72is( $INC{'Foo2.pl'}, \&fooinc, ' val Foo2.pl is correct in %INC' ); 73 74pop @INC; 75 76 77sub fooinc2 { 78 my ($self, $filename) = @_; 79 if (substr($filename, 0, length($self->[1])) eq $self->[1]) { 80 return get_temp_fh($filename); 81 } 82 else { 83 return undef; 84 } 85} 86 87my $arrayref = [ \&fooinc2, 'Bar' ]; 88push @INC, $arrayref; 89 90$evalret = eval { require Foo; 1; }; 91die $@ if $@; 92ok( $evalret, 'Originally loaded packages preserved' ); 93$evalret = eval { require Foo3; 1; }; 94ok( !$evalret, 'Original magic INC purged' ); 95 96$evalret = eval { require Bar; 1 }; 97die $@ if $@; 98ok( $evalret, 'require Bar; magic via array ref' ); 99ok( exists $INC{'Bar.pm'}, ' %INC sees Bar.pm' ); 100is( ref $INC{'Bar.pm'}, 'ARRAY', ' val Bar.pm is an arrayref in %INC' ); 101is( $INC{'Bar.pm'}, $arrayref, ' val Bar.pm is correct in %INC' ); 102 103ok( eval "use Bar1; 1;", 'use Bar1' ); 104ok( exists $INC{'Bar1.pm'}, ' %INC sees Bar1.pm' ); 105is( ref $INC{'Bar1.pm'}, 'ARRAY', ' val Bar1.pm is an arrayref in %INC' ); 106is( $INC{'Bar1.pm'}, $arrayref, ' val Bar1.pm is correct in %INC' ); 107 108ok( eval { do 'Bar2.pl'; 1 }, 'do "Bar2.pl"' ); 109ok( exists $INC{'Bar2.pl'}, ' %INC sees Bar2.pl' ); 110is( ref $INC{'Bar2.pl'}, 'ARRAY', ' val Bar2.pl is an arrayref in %INC' ); 111is( $INC{'Bar2.pl'}, $arrayref, ' val Bar2.pl is correct in %INC' ); 112 113pop @INC; 114 115sub FooLoader::INC { 116 my ($self, $filename) = @_; 117 if (substr($filename,0,4) eq 'Quux') { 118 return get_temp_fh($filename); 119 } 120 else { 121 return undef; 122 } 123} 124 125my $href = bless( {}, 'FooLoader' ); 126push @INC, $href; 127 128$evalret = eval { require Quux; 1 }; 129die $@ if $@; 130ok( $evalret, 'require Quux; magic via hash object' ); 131ok( exists $INC{'Quux.pm'}, ' %INC sees Quux.pm' ); 132is( ref $INC{'Quux.pm'}, 'FooLoader', 133 ' val Quux.pm is an object in %INC' ); 134is( $INC{'Quux.pm'}, $href, ' val Quux.pm is correct in %INC' ); 135 136pop @INC; 137 138my $aref = bless( [], 'FooLoader' ); 139push @INC, $aref; 140 141$evalret = eval { require Quux1; 1 }; 142die $@ if $@; 143ok( $evalret, 'require Quux1; magic via array object' ); 144ok( exists $INC{'Quux1.pm'}, ' %INC sees Quux1.pm' ); 145is( ref $INC{'Quux1.pm'}, 'FooLoader', 146 ' val Quux1.pm is an object in %INC' ); 147is( $INC{'Quux1.pm'}, $aref, ' val Quux1.pm is correct in %INC' ); 148 149pop @INC; 150 151my $sref = bless( \(my $x = 1), 'FooLoader' ); 152push @INC, $sref; 153 154$evalret = eval { require Quux2; 1 }; 155die $@ if $@; 156ok( $evalret, 'require Quux2; magic via scalar object' ); 157ok( exists $INC{'Quux2.pm'}, ' %INC sees Quux2.pm' ); 158is( ref $INC{'Quux2.pm'}, 'FooLoader', 159 ' val Quux2.pm is an object in %INC' ); 160is( $INC{'Quux2.pm'}, $sref, ' val Quux2.pm is correct in %INC' ); 161 162pop @INC; 163 164push @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 175$evalret = eval { require Toto; 1 }; 176die $@ if $@; 177ok( $evalret, 'require Toto; magic via anonymous code ref' ); 178ok( exists $INC{'Toto.pm'}, ' %INC sees Toto.pm' ); 179ok( ! ref $INC{'Toto.pm'}, q/ val Toto.pm isn't a ref in %INC/ ); 180is( $INC{'Toto.pm'}, 'xyz', ' val Toto.pm is correct in %INC' ); 181 182pop @INC; 183 184push @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 194my $ret = ""; 195$ret ||= do 'abc.pl'; 196is( $ret, 'abc', 'do "abc.pl" sees return value' ); 197 198{ 199 my $filename = './Foo.pm'; 200 #local @INC; # local fails on tied @INC 201 my @old_INC = @INC; # because local doesn't work on tied arrays 202 @INC = sub { $filename = 'seen'; return undef; }; 203 eval { require $filename; }; 204 is( $filename, 'seen', 'the coderef sees fully-qualified pathnames' ); 205 @INC = @old_INC; 206} 207 208# this will segfault if it fails 209 210sub 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 218unshift @INC, sub { PVBM }; 219eval 'require foo'; 220ok( 1, 'returning PVBM doesn\'t segfault require' ); 221eval 'use foo'; 222ok( 1, 'returning PVBM doesn\'t segfault use' ); 223shift @INC; 224unshift @INC, sub { \PVBM }; 225eval 'require foo'; 226ok( 1, 'returning PVBM ref doesn\'t segfault require' ); 227eval 'use foo'; 228ok( 1, 'returning PVBM ref doesn\'t segfault use' ); 229shift @INC; 230 231exit if $minitest; 232 233SKIP: { 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 } 258} 259pop @INC; 260 261if ($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} 312