[perl5.git] / t / op / inccode.t

#!./perl -w

# Tests for the coderef-in-@INC feature

BEGIN {
    chdir 't' if -d 't';
    @INC = qw(. ../lib);
    require './test.pl';
}

use Config;

my $can_fork   = 0;
my $has_perlio = $Config{useperlio};

unless (is_miniperl()) {
    if ($Config{d_fork} && eval 'require POSIX; 1') {
	$can_fork = 1;
    }
}

use strict;

plan(tests => 68 + !is_miniperl() * (3 + 14 * $can_fork));

sub get_temp_fh {
    my $f = tempfile();
    open my $fh, ">$f" or die "Can't create $f: $!";
    print $fh "package ".substr($_[0],0,-3).";\n1;\n";
    print $fh $_[1] if @_ > 1;
    close $fh or die "Couldn't close: $!";
    open $fh, $f or die "Can't open $f: $!";
    return $fh;
}

sub fooinc {
    my ($self, $filename) = @_;
    if (substr($filename,0,3) eq 'Foo') {
	return get_temp_fh($filename);
    }
    else {
        return undef;
    }
}

push @INC, \&fooinc;

my $evalret = eval { require Bar; 1 };
ok( !$evalret,      'Trying non-magic package' );

$evalret = eval { require Foo; 1 };
die $@ if $@;
ok( $evalret,                      'require Foo; magic via code ref'  );
ok( exists $INC{'Foo.pm'},         '  %INC sees Foo.pm' );
is( ref $INC{'Foo.pm'}, 'CODE',    '  val Foo.pm is a coderef in %INC' );
is( $INC{'Foo.pm'}, \&fooinc,	   '  val Foo.pm is correct in %INC' );

$evalret = eval "use Foo1; 1;";
die $@ if $@;
ok( $evalret,                      'use Foo1' );
ok( exists $INC{'Foo1.pm'},        '  %INC sees Foo1.pm' );
is( ref $INC{'Foo1.pm'}, 'CODE',   '  val Foo1.pm is a coderef in %INC' );
is( $INC{'Foo1.pm'}, \&fooinc,     '  val Foo1.pm is correct in %INC' );

$evalret = eval { do 'Foo2.pl'; 1 };
die $@ if $@;
ok( $evalret,                      'do "Foo2.pl"' );
ok( exists $INC{'Foo2.pl'},        '  %INC sees Foo2.pl' );
is( ref $INC{'Foo2.pl'}, 'CODE',   '  val Foo2.pl is a coderef in %INC' );
is( $INC{'Foo2.pl'}, \&fooinc,     '  val Foo2.pl is correct in %INC' );

pop @INC;


sub fooinc2 {
    my ($self, $filename) = @_;
    if (substr($filename, 0, length($self->[1])) eq $self->[1]) {
	return get_temp_fh($filename);
    }
    else {
        return undef;
    }
}

my $arrayref = [ \&fooinc2, 'Bar' ];
push @INC, $arrayref;

$evalret = eval { require Foo; 1; };
die $@ if $@;
ok( $evalret,                     'Originally loaded packages preserved' );
$evalret = eval { require Foo3; 1; };
ok( !$evalret,                    'Original magic INC purged' );

$evalret = eval { require Bar; 1 };
die $@ if $@;
ok( $evalret,                     'require Bar; magic via array ref' );
ok( exists $INC{'Bar.pm'},        '  %INC sees Bar.pm' );
is( ref $INC{'Bar.pm'}, 'ARRAY',  '  val Bar.pm is an arrayref in %INC' );
is( $INC{'Bar.pm'}, $arrayref,    '  val Bar.pm is correct in %INC' );

ok( eval "use Bar1; 1;",          'use Bar1' );
ok( exists $INC{'Bar1.pm'},       '  %INC sees Bar1.pm' );
is( ref $INC{'Bar1.pm'}, 'ARRAY', '  val Bar1.pm is an arrayref in %INC' );
is( $INC{'Bar1.pm'}, $arrayref,   '  val Bar1.pm is correct in %INC' );

ok( eval { do 'Bar2.pl'; 1 },     'do "Bar2.pl"' );
ok( exists $INC{'Bar2.pl'},       '  %INC sees Bar2.pl' );
is( ref $INC{'Bar2.pl'}, 'ARRAY', '  val Bar2.pl is an arrayref in %INC' );
is( $INC{'Bar2.pl'}, $arrayref,   '  val Bar2.pl is correct in %INC' );

pop @INC;

sub FooLoader::INC {
    my ($self, $filename) = @_;
    if (substr($filename,0,4) eq 'Quux') {
	return get_temp_fh($filename);
    }
    else {
        return undef;
    }
}

my $href = bless( {}, 'FooLoader' );
push @INC, $href;

$evalret = eval { require Quux; 1 };
die $@ if $@;
ok( $evalret,                      'require Quux; magic via hash object' );
ok( exists $INC{'Quux.pm'},        '  %INC sees Quux.pm' );
is( ref $INC{'Quux.pm'}, 'FooLoader',
				   '  val Quux.pm is an object in %INC' );
is( $INC{'Quux.pm'}, $href,        '  val Quux.pm is correct in %INC' );

pop @INC;

my $aref = bless( [], 'FooLoader' );
push @INC, $aref;

$evalret = eval { require Quux1; 1 };
die $@ if $@;
ok( $evalret,                      'require Quux1; magic via array object' );
ok( exists $INC{'Quux1.pm'},       '  %INC sees Quux1.pm' );
is( ref $INC{'Quux1.pm'}, 'FooLoader',
				   '  val Quux1.pm is an object in %INC' );
is( $INC{'Quux1.pm'}, $aref,       '  val Quux1.pm  is correct in %INC' );

pop @INC;

my $sref = bless( \(my $x = 1), 'FooLoader' );
push @INC, $sref;

$evalret = eval { require Quux2; 1 };
die $@ if $@;
ok( $evalret,                      'require Quux2; magic via scalar object' );
ok( exists $INC{'Quux2.pm'},       '  %INC sees Quux2.pm' );
is( ref $INC{'Quux2.pm'}, 'FooLoader',
				   '  val Quux2.pm is an object in %INC' );
is( $INC{'Quux2.pm'}, $sref,       '  val Quux2.pm is correct in %INC' );

pop @INC;

push @INC, sub {
    my ($self, $filename) = @_;
    if (substr($filename,0,4) eq 'Toto') {
	$INC{$filename} = 'xyz';
	return get_temp_fh($filename);
    }
    else {
        return undef;
    }
};

$evalret = eval { require Toto; 1 };
die $@ if $@;
ok( $evalret,                      'require Toto; magic via anonymous code ref'  );
ok( exists $INC{'Toto.pm'},        '  %INC sees Toto.pm' );
ok( ! ref $INC{'Toto.pm'},         q/  val Toto.pm isn't a ref in %INC/ );
is( $INC{'Toto.pm'}, 'xyz',	   '  val Toto.pm is correct in %INC' );

pop @INC;

push @INC, sub {
    my ($self, $filename) = @_;
    if ($filename eq 'abc.pl') {
	return get_temp_fh($filename, qq(return "abc";\n));
    }
    else {
	return undef;
    }
};

my $ret = "";
$ret ||= do 'abc.pl';
is( $ret, 'abc', 'do "abc.pl" sees return value' );

{
    my $got;
    #local @INC; # local fails on tied @INC
    my @old_INC = @INC; # because local doesn't work on tied arrays
    @INC = ('lib', 'lib/Devel', sub { $got = $_[1]; return undef; });
    foreach my $filename ('/test_require.pm', './test_require.pm',
			  '../test_require.pm') {
	local %INC;
	undef $got;
	undef $test_require::loaded;
	eval { require $filename; };
	is($got, $filename, "the coderef sees the pathname $filename");
	is($test_require::loaded, undef, 'no module is loaded' );
    }

    local %INC;
    undef $got;
    undef $test_require::loaded;

    eval { require 'test_require.pm'; };
    is($got, undef, 'the directory is scanned for test_require.pm');
    is($test_require::loaded, 1, 'the module is loaded');
    @INC = @old_INC;
}

# this will segfault if it fails

sub PVBM () { 'foo' }
{ my $dummy = index 'foo', PVBM }

# I don't know whether these requires should succeed or fail. 5.8 failed
# all of them; 5.10 with an ordinary constant in place of PVBM lets the
# latter two succeed. For now I don't care, as long as they don't
# segfault :).

unshift @INC, sub { PVBM };
eval 'require foo';
ok( 1, 'returning PVBM doesn\'t segfault require' );
eval 'use foo';
ok( 1, 'returning PVBM doesn\'t segfault use' );
shift @INC;
unshift @INC, sub { \PVBM };
eval 'require foo';
ok( 1, 'returning PVBM ref doesn\'t segfault require' );
eval 'use foo';
ok( 1, 'returning PVBM ref doesn\'t segfault use' );
shift @INC;

# [perl #92252]
{
    my $die = sub { die };
    my $data = [];
    unshift @INC, sub { $die, $data };

    my $initial_sub_refcnt = &Internals::SvREFCNT($die);
    my $initial_data_refcnt = &Internals::SvREFCNT($data);

    do "foo";
    is(&Internals::SvREFCNT($die), $initial_sub_refcnt, "no leaks");
    is(&Internals::SvREFCNT($data), $initial_data_refcnt, "no leaks");

    do "bar";
    is(&Internals::SvREFCNT($die), $initial_sub_refcnt, "no leaks");
    is(&Internals::SvREFCNT($data), $initial_data_refcnt, "no leaks");

    shift @INC;
}

unshift @INC, sub { \(my $tmp = '$_ = "are temps freed prematurely?"') };
eval { require foom };
is $_||$@, "are temps freed prematurely?",
           "are temps freed prematurely when returned from inc filters?";
shift @INC;

# [perl #120657]
sub fake_module {
    my (undef,$module_file) = @_;
    !1
}
{
    local @INC = @INC;
    unshift @INC, (\&fake_module)x2;
    eval { require "${\'bralbalhablah'}" };
    like $@, qr/^Can't locate/,
        'require PADTMP passing freed var when @INC has multiple subs';\r
}    

SKIP: {
    skip ("Not applicable when run from inccode-tie.t", 6) if tied @INC;
    require Tie::Scalar;
    package INCtie {
        sub TIESCALAR { bless \my $foo }
        sub FETCH { study; our $count++; ${$_[0]} }
    }
    local @INC = undef;
    my $t = tie $INC[0], 'INCtie';
    my $called;
    $$t = sub { $called ++; !1 };
    delete $INC{'foo.pm'}; # in case another test uses foo
    eval { require foo };
    is $INCtie::count, 2, # 2nd time for "Can't locate" -- XXX correct?
        'FETCH is called once on undef scalar-tied @INC elem';
    is $called, 1, 'sub in scalar-tied @INC elem is called';
    () = "$INC[0]"; # force a fetch, so the SV is ROK
    $INCtie::count = 0;
    eval { require foo };
    is $INCtie::count, 2,
        'FETCH is called once on scalar-tied @INC elem holding ref';
    is $called, 2, 'sub in scalar-tied @INC elem holding ref is called';
    $$t = [];
    $INCtie::count = 0;
    eval { require foo };
    is $INCtie::count, 1,
       'FETCH called once on scalar-tied @INC elem returning array';
    $$t = "string";
    $INCtie::count = 0;
    eval { require foo };
    is $INCtie::count, 2,
       'FETCH called once on scalar-tied @INC elem returning string';
}


exit if is_miniperl();

SKIP: {
    skip( "No PerlIO available", 3 ) unless $has_perlio;
    pop @INC;

    push @INC, sub {
        my ($cr, $filename) = @_;
        my $module = $filename; $module =~ s,/,::,g; $module =~ s/\.pm$//;
        open my $fh, '<',
             \"package $module; sub complain { warn q() }; \$::file = __FILE__;"
	    or die $!;
        $INC{$filename} = "/custom/path/to/$filename";
        return $fh;
    };

    require Publius::Vergilius::Maro;
    is( $INC{'Publius/Vergilius/Maro.pm'},
        '/custom/path/to/Publius/Vergilius/Maro.pm', '%INC set correctly');
    is( our $file, '/custom/path/to/Publius/Vergilius/Maro.pm',
        '__FILE__ set correctly' );
    {
        my $warning;
        local $SIG{__WARN__} = sub { $warning = shift };
        Publius::Vergilius::Maro::complain();
        like( $warning, qr{something's wrong at /custom/path/to/Publius/Vergilius/Maro.pm}, 'warn() reports correct file source' );
    }
}
pop @INC;

if ($can_fork) {
    require PerlIO::scalar;
    # This little bundle of joy generates n more recursive use statements,
    # with each module chaining the next one down to 0. If it works, then we
    # can safely nest subprocesses
    my $use_filter_too;
    push @INC, sub {
	return unless $_[1] =~ /^BBBLPLAST(\d+)\.pm/;
	my $pid = open my $fh, "-|";
	if ($pid) {
	    # Parent
	    return $fh unless $use_filter_too;
	    # Try filters and state in addition.
	    return ($fh, sub {s/$_[1]/pass/; return}, "die")
	}
	die "Can't fork self: $!" unless defined $pid;

	# Child
	my $count = $1;
	# Lets force some fun with odd sized reads.
	$| = 1;
	print 'push @main::bbblplast, ';
	print "$count;\n";
	if ($count--) {
	    print "use BBBLPLAST$count;\n";
	}
	if ($use_filter_too) {
	    print "die('In $_[1]');";
	} else {
	    print "pass('In $_[1]');";
	}
	print '"Truth"';
	POSIX::_exit(0);
	die "Can't get here: $!";
    };

    @::bbblplast = ();
    require BBBLPLAST5;
    is ("@::bbblplast", "0 1 2 3 4 5", "All ran");

    foreach (keys %INC) {
	delete $INC{$_} if /^BBBLPLAST/;
    }

    @::bbblplast = ();
    $use_filter_too = 1;

    require BBBLPLAST5;

    is ("@::bbblplast", "0 1 2 3 4 5", "All ran with a filter");
}
Commit	Line	Data
69026470	1	#!./perl -w
e5d18500 AMS	2
	3	# Tests for the coderef-in-@INC feature
	4
	5	BEGIN {
f8973f08	6	chdir 't' if -d 't';
69026470	7	@INC = qw(. ../lib);
9c123506	8	require './test.pl';
e5d18500	9	}
ab742322	10
9c123506 NC	11	use Config;
	12
	13	my $can_fork = 0;
	14	my $has_perlio = $Config{useperlio};
	15
	16	unless (is_miniperl()) {
240b6766	17	if ($Config{d_fork} && eval 'require POSIX; 1') {
6b75eab3 NC	18	$can_fork = 1;
	19	}
	20	}
f8973f08	21
6b75eab3	22	use strict;
69026470	23
6567ce24	24	plan(tests => 68 + !is_miniperl() * (3 + 14 * $can_fork));
47de4e93 RGS	25
47de4e93 RGS	26	sub get_temp_fh {
1c25d394	27	my $f = tempfile();
22e2837f	28	open my $fh, ">$f" or die "Can't create $f: $!";
3a5db825 GA	29	print $fh "package ".substr($_[0],0,-3).";\n1;\n";
3a5db825 GA	30	print $fh $_[1] if @_ > 1;
d1e4d418	31	close $fh or die "Couldn't close: $!";
47de4e93 RGS	32	open $fh, $f or die "Can't open $f: $!";
	33	return $fh;
	34	}
f8973f08	35
e5d18500 AMS	36	sub fooinc {
	37	my ($self, $filename) = @_;
	38	if (substr($filename,0,3) eq 'Foo') {
47de4e93	39	return get_temp_fh($filename);
e5d18500 AMS	40	}
e5d18500 AMS	41	else {
f8973f08	42	return undef;
e5d18500 AMS	43	}
	44	}
	45
	46	push @INC, \&fooinc;
	47
d1e4d418 A	48	my $evalret = eval { require Bar; 1 };
	49	ok( !$evalret, 'Trying non-magic package' );
	50
	51	$evalret = eval { require Foo; 1 };
	52	die $@ if $@;
	53	ok( $evalret, 'require Foo; magic via code ref' );
	54	ok( exists $INC{'Foo.pm'}, ' %INC sees Foo.pm' );
	55	is( ref $INC{'Foo.pm'}, 'CODE', ' val Foo.pm is a coderef in %INC' );
	56	is( $INC{'Foo.pm'}, \&fooinc, ' val Foo.pm is correct in %INC' );
	57
	58	$evalret = eval "use Foo1; 1;";
	59	die $@ if $@;
	60	ok( $evalret, 'use Foo1' );
	61	ok( exists $INC{'Foo1.pm'}, ' %INC sees Foo1.pm' );
	62	is( ref $INC{'Foo1.pm'}, 'CODE', ' val Foo1.pm is a coderef in %INC' );
	63	is( $INC{'Foo1.pm'}, \&fooinc, ' val Foo1.pm is correct in %INC' );
	64
	65	$evalret = eval { do 'Foo2.pl'; 1 };
	66	die $@ if $@;
	67	ok( $evalret, 'do "Foo2.pl"' );
	68	ok( exists $INC{'Foo2.pl'}, ' %INC sees Foo2.pl' );
	69	is( ref $INC{'Foo2.pl'}, 'CODE', ' val Foo2.pl is a coderef in %INC' );
	70	is( $INC{'Foo2.pl'}, \&fooinc, ' val Foo2.pl is correct in %INC' );
e5d18500 AMS	71
	72	pop @INC;
	73
f8973f08	74
e5d18500 AMS	75	sub fooinc2 {
	76	my ($self, $filename) = @_;
	77	if (substr($filename, 0, length($self->[1])) eq $self->[1]) {
47de4e93	78	return get_temp_fh($filename);
e5d18500 AMS	79	}
e5d18500 AMS	80	else {
f8973f08	81	return undef;
e5d18500 AMS	82	}
	83	}
	84
47de4e93 RGS	85	my $arrayref = [ \&fooinc2, 'Bar' ];
47de4e93 RGS	86	push @INC, $arrayref;
e5d18500	87
d1e4d418 A	88	$evalret = eval { require Foo; 1; };
	89	die $@ if $@;
	90	ok( $evalret, 'Originally loaded packages preserved' );
	91	$evalret = eval { require Foo3; 1; };
	92	ok( !$evalret, 'Original magic INC purged' );
	93
	94	$evalret = eval { require Bar; 1 };
	95	die $@ if $@;
	96	ok( $evalret, 'require Bar; magic via array ref' );
	97	ok( exists $INC{'Bar.pm'}, ' %INC sees Bar.pm' );
	98	is( ref $INC{'Bar.pm'}, 'ARRAY', ' val Bar.pm is an arrayref in %INC' );
	99	is( $INC{'Bar.pm'}, $arrayref, ' val Bar.pm is correct in %INC' );
	100
	101	ok( eval "use Bar1; 1;", 'use Bar1' );
	102	ok( exists $INC{'Bar1.pm'}, ' %INC sees Bar1.pm' );
	103	is( ref $INC{'Bar1.pm'}, 'ARRAY', ' val Bar1.pm is an arrayref in %INC' );
	104	is( $INC{'Bar1.pm'}, $arrayref, ' val Bar1.pm is correct in %INC' );
	105
	106	ok( eval { do 'Bar2.pl'; 1 }, 'do "Bar2.pl"' );
	107	ok( exists $INC{'Bar2.pl'}, ' %INC sees Bar2.pl' );
	108	is( ref $INC{'Bar2.pl'}, 'ARRAY', ' val Bar2.pl is an arrayref in %INC' );
	109	is( $INC{'Bar2.pl'}, $arrayref, ' val Bar2.pl is correct in %INC' );
e5d18500 AMS	110
	111	pop @INC;
	112
	113	sub FooLoader::INC {
	114	my ($self, $filename) = @_;
	115	if (substr($filename,0,4) eq 'Quux') {
47de4e93	116	return get_temp_fh($filename);
e5d18500 AMS	117	}
e5d18500 AMS	118	else {
f8973f08	119	return undef;
e5d18500 AMS	120	}
	121	}
	122
47de4e93 RGS	123	my $href = bless( {}, 'FooLoader' );
47de4e93 RGS	124	push @INC, $href;
e5d18500	125
d1e4d418 A	126	$evalret = eval { require Quux; 1 };
	127	die $@ if $@;
	128	ok( $evalret, 'require Quux; magic via hash object' );
	129	ok( exists $INC{'Quux.pm'}, ' %INC sees Quux.pm' );
6ece0f6b	130	is( ref $INC{'Quux.pm'}, 'FooLoader',
d1e4d418 A	131	' val Quux.pm is an object in %INC' );
d1e4d418 A	132	is( $INC{'Quux.pm'}, $href, ' val Quux.pm is correct in %INC' );
e5d18500 AMS	133
	134	pop @INC;
	135
47de4e93 RGS	136	my $aref = bless( [], 'FooLoader' );
47de4e93 RGS	137	push @INC, $aref;
e5d18500	138
d1e4d418 A	139	$evalret = eval { require Quux1; 1 };
	140	die $@ if $@;
	141	ok( $evalret, 'require Quux1; magic via array object' );
	142	ok( exists $INC{'Quux1.pm'}, ' %INC sees Quux1.pm' );
6ece0f6b	143	is( ref $INC{'Quux1.pm'}, 'FooLoader',
d1e4d418 A	144	' val Quux1.pm is an object in %INC' );
d1e4d418 A	145	is( $INC{'Quux1.pm'}, $aref, ' val Quux1.pm is correct in %INC' );
e5d18500 AMS	146
	147	pop @INC;
	148
47de4e93 RGS	149	my $sref = bless( \(my $x = 1), 'FooLoader' );
47de4e93 RGS	150	push @INC, $sref;
e5d18500	151
d1e4d418 A	152	$evalret = eval { require Quux2; 1 };
	153	die $@ if $@;
	154	ok( $evalret, 'require Quux2; magic via scalar object' );
	155	ok( exists $INC{'Quux2.pm'}, ' %INC sees Quux2.pm' );
6ece0f6b	156	is( ref $INC{'Quux2.pm'}, 'FooLoader',
d1e4d418 A	157	' val Quux2.pm is an object in %INC' );
d1e4d418 A	158	is( $INC{'Quux2.pm'}, $sref, ' val Quux2.pm is correct in %INC' );
f8973f08 MS	159
f8973f08 MS	160	pop @INC;
9ae8cd5b RGS	161
	162	push @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
d1e4d418 A	173	$evalret = eval { require Toto; 1 };
	174	die $@ if $@;
	175	ok( $evalret, 'require Toto; magic via anonymous code ref' );
	176	ok( exists $INC{'Toto.pm'}, ' %INC sees Toto.pm' );
	177	ok( ! ref $INC{'Toto.pm'}, q/ val Toto.pm isn't a ref in %INC/ );
	178	is( $INC{'Toto.pm'}, 'xyz', ' val Toto.pm is correct in %INC' );
9ae8cd5b RGS	179
9ae8cd5b RGS	180	pop @INC;
d820be44	181
3a5db825 GA	182	push @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
6b75eab3	192	my $ret = "";
3a5db825 GA	193	$ret \|\|= do 'abc.pl';
	194	is( $ret, 'abc', 'do "abc.pl" sees return value' );
	195
ab742322	196	{
e6c837f5	197	my $got;
c38a6530 RD	198	#local @INC; # local fails on tied @INC
c38a6530 RD	199	my @old_INC = @INC; # because local doesn't work on tied arrays
e6c837f5 NC	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');
c38a6530	218	@INC = @old_INC;
ab742322 RB	219	}
ab742322 RB	220
6e592b3a BM	221	# this will segfault if it fails
	222
	223	sub 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
	231	unshift @INC, sub { PVBM };
	232	eval 'require foo';
	233	ok( 1, 'returning PVBM doesn\'t segfault require' );
	234	eval 'use foo';
	235	ok( 1, 'returning PVBM doesn\'t segfault use' );
	236	shift @INC;
	237	unshift @INC, sub { \PVBM };
	238	eval 'require foo';
	239	ok( 1, 'returning PVBM ref doesn\'t segfault require' );
	240	eval 'use foo';
	241	ok( 1, 'returning PVBM ref doesn\'t segfault use' );
	242	shift @INC;
	243
d60d2019 JL	244	# [perl #92252]
	245	{
	246	my $die = sub { die };
	247	my $data = [];
	248	unshift @INC, sub { $die, $data };
	249
6429869b JL	250	my $initial_sub_refcnt = &Internals::SvREFCNT($die);
6429869b JL	251	my $initial_data_refcnt = &Internals::SvREFCNT($data);
d60d2019 JL	252
d60d2019 JL	253	do "foo";
6429869b JL	254	is(&Internals::SvREFCNT($die), $initial_sub_refcnt, "no leaks");
6429869b JL	255	is(&Internals::SvREFCNT($data), $initial_data_refcnt, "no leaks");
d60d2019 JL	256
d60d2019 JL	257	do "bar";
6429869b JL	258	is(&Internals::SvREFCNT($die), $initial_sub_refcnt, "no leaks");
6429869b JL	259	is(&Internals::SvREFCNT($data), $initial_data_refcnt, "no leaks");
d60d2019 JL	260
	261	shift @INC;
	262	}
	263
c39fcc09 FC	264	unshift @INC, sub { \(my $tmp = '$_ = "are temps freed prematurely?"') };
	265	eval { require foom };
	266	is $_\|\|$@, "are temps freed prematurely?",
	267	"are temps freed prematurely when returned from inc filters?";
	268	shift @INC;
	269
901ee108 FC	270	# [perl #120657]
	271	sub fake_module {
	272	my (undef,$module_file) = @_;
	273	!1
	274	}
	275	{
	276	local @INC = @INC;
	277	unshift @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';\r
	281	}
	282
6567ce24 FC	283	SKIP: {
	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
901ee108	317
9c123506	318	exit if is_miniperl();
ab742322	319
240b6766 AT	320	SKIP: {
	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	}
a3b58a99	345	}
a3b58a99 RGS	346	pop @INC;
a3b58a99 RGS	347
6b75eab3 NC	348	if ($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	}