[p5sagit/p5-mst-13.2.git] / t / op / inccode.t

#!./perl -w

# Tests for the coderef-in-@INC feature

my $can_fork = 0;
my $minitest = $ENV{PERL_CORE_MINITEST};

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

if (!$minitest) {
    use Config; 
    if (PerlIO::Layer->find('perlio') && $Config{d_fork} &&
	eval 'require POSIX; 1') {
	$can_fork = 1;
    }
}

use strict;
use File::Spec;

require "test.pl";
plan(tests => 45 + !$minitest * (3 + 14 * $can_fork));

my @tempfiles = ();

sub get_temp_fh {
    my $f = "DummyModule0000";
    1 while -e ++$f;
    push @tempfiles, $f;
    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;
}

END { 1 while unlink @tempfiles }

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 $filename = $^O eq 'MacOS' ? ':Foo:Foo.pm' : './Foo.pm';
    #local @INC; # local fails on tied @INC
    my @old_INC = @INC; # because local doesn't work on tied arrays
    @INC = sub { $filename = 'seen'; return undef; };
    eval { require $filename; };
    is( $filename, 'seen', 'the coderef sees fully-qualified pathnames' );
    @INC = @old_INC;
}

exit if $minitest;

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	2
	3	# Tests for the coderef-in-@INC feature
	4
6b75eab3	5	my $can_fork = 0;
ab742322	6	my $minitest = $ENV{PERL_CORE_MINITEST};
ab742322	7
e5d18500	8	BEGIN {
f8973f08	9	chdir 't' if -d 't';
69026470	10	@INC = qw(. ../lib);
e5d18500	11	}
ab742322	12
ab742322	13	if (!$minitest) {
6b75eab3	14	use Config;
	15	if (PerlIO::Layer->find('perlio') && $Config{d_fork} &&
	16	eval 'require POSIX; 1') {
	17	$can_fork = 1;
	18	}
	19	}
f8973f08	20
6b75eab3	21	use strict;
47de4e93	22	use File::Spec;
69026470	23
69026470	24	require "test.pl";
ab742322	25	plan(tests => 45 + !$minitest * (3 + 14 * $can_fork));
47de4e93	26
22e2837f	27	my @tempfiles = ();
22e2837f	28
47de4e93	29	sub get_temp_fh {
22e2837f	30	my $f = "DummyModule0000";
	31	1 while -e ++$f;
	32	push @tempfiles, $f;
	33	open my $fh, ">$f" or die "Can't create $f: $!";
3a5db825	34	print $fh "package ".substr($_[0],0,-3).";\n1;\n";
3a5db825	35	print $fh $_[1] if @_ > 1;
d1e4d418	36	close $fh or die "Couldn't close: $!";
47de4e93	37	open $fh, $f or die "Can't open $f: $!";
	38	return $fh;
	39	}
f8973f08	40
22e2837f	41	END { 1 while unlink @tempfiles }
22e2837f	42
e5d18500	43	sub fooinc {
	44	my ($self, $filename) = @_;
	45	if (substr($filename,0,3) eq 'Foo') {
47de4e93	46	return get_temp_fh($filename);
e5d18500	47	}
e5d18500	48	else {
f8973f08	49	return undef;
e5d18500	50	}
	51	}
	52
	53	push @INC, \&fooinc;
	54
d1e4d418	55	my $evalret = eval { require Bar; 1 };
	56	ok( !$evalret, 'Trying non-magic package' );
	57
	58	$evalret = eval { require Foo; 1 };
	59	die $@ if $@;
	60	ok( $evalret, 'require Foo; magic via code ref' );
	61	ok( exists $INC{'Foo.pm'}, ' %INC sees Foo.pm' );
	62	is( ref $INC{'Foo.pm'}, 'CODE', ' val Foo.pm is a coderef in %INC' );
	63	is( $INC{'Foo.pm'}, \&fooinc, ' val Foo.pm is correct in %INC' );
	64
	65	$evalret = eval "use Foo1; 1;";
	66	die $@ if $@;
	67	ok( $evalret, 'use Foo1' );
	68	ok( exists $INC{'Foo1.pm'}, ' %INC sees Foo1.pm' );
	69	is( ref $INC{'Foo1.pm'}, 'CODE', ' val Foo1.pm is a coderef in %INC' );
	70	is( $INC{'Foo1.pm'}, \&fooinc, ' val Foo1.pm is correct in %INC' );
	71
	72	$evalret = eval { do 'Foo2.pl'; 1 };
	73	die $@ if $@;
	74	ok( $evalret, 'do "Foo2.pl"' );
	75	ok( exists $INC{'Foo2.pl'}, ' %INC sees Foo2.pl' );
	76	is( ref $INC{'Foo2.pl'}, 'CODE', ' val Foo2.pl is a coderef in %INC' );
	77	is( $INC{'Foo2.pl'}, \&fooinc, ' val Foo2.pl is correct in %INC' );
e5d18500	78
	79	pop @INC;
	80
f8973f08	81
e5d18500	82	sub fooinc2 {
	83	my ($self, $filename) = @_;
	84	if (substr($filename, 0, length($self->[1])) eq $self->[1]) {
47de4e93	85	return get_temp_fh($filename);
e5d18500	86	}
e5d18500	87	else {
f8973f08	88	return undef;
e5d18500	89	}
	90	}
	91
47de4e93	92	my $arrayref = [ \&fooinc2, 'Bar' ];
47de4e93	93	push @INC, $arrayref;
e5d18500	94
d1e4d418	95	$evalret = eval { require Foo; 1; };
	96	die $@ if $@;
	97	ok( $evalret, 'Originally loaded packages preserved' );
	98	$evalret = eval { require Foo3; 1; };
	99	ok( !$evalret, 'Original magic INC purged' );
	100
	101	$evalret = eval { require Bar; 1 };
	102	die $@ if $@;
	103	ok( $evalret, 'require Bar; magic via array ref' );
	104	ok( exists $INC{'Bar.pm'}, ' %INC sees Bar.pm' );
	105	is( ref $INC{'Bar.pm'}, 'ARRAY', ' val Bar.pm is an arrayref in %INC' );
	106	is( $INC{'Bar.pm'}, $arrayref, ' val Bar.pm is correct in %INC' );
	107
	108	ok( eval "use Bar1; 1;", 'use Bar1' );
	109	ok( exists $INC{'Bar1.pm'}, ' %INC sees Bar1.pm' );
	110	is( ref $INC{'Bar1.pm'}, 'ARRAY', ' val Bar1.pm is an arrayref in %INC' );
	111	is( $INC{'Bar1.pm'}, $arrayref, ' val Bar1.pm is correct in %INC' );
	112
	113	ok( eval { do 'Bar2.pl'; 1 }, 'do "Bar2.pl"' );
	114	ok( exists $INC{'Bar2.pl'}, ' %INC sees Bar2.pl' );
	115	is( ref $INC{'Bar2.pl'}, 'ARRAY', ' val Bar2.pl is an arrayref in %INC' );
	116	is( $INC{'Bar2.pl'}, $arrayref, ' val Bar2.pl is correct in %INC' );
e5d18500	117
	118	pop @INC;
	119
	120	sub FooLoader::INC {
	121	my ($self, $filename) = @_;
	122	if (substr($filename,0,4) eq 'Quux') {
47de4e93	123	return get_temp_fh($filename);
e5d18500	124	}
e5d18500	125	else {
f8973f08	126	return undef;
e5d18500	127	}
	128	}
	129
47de4e93	130	my $href = bless( {}, 'FooLoader' );
47de4e93	131	push @INC, $href;
e5d18500	132
d1e4d418	133	$evalret = eval { require Quux; 1 };
	134	die $@ if $@;
	135	ok( $evalret, 'require Quux; magic via hash object' );
	136	ok( exists $INC{'Quux.pm'}, ' %INC sees Quux.pm' );
6ece0f6b	137	is( ref $INC{'Quux.pm'}, 'FooLoader',
d1e4d418	138	' val Quux.pm is an object in %INC' );
d1e4d418	139	is( $INC{'Quux.pm'}, $href, ' val Quux.pm is correct in %INC' );
e5d18500	140
	141	pop @INC;
	142
47de4e93	143	my $aref = bless( [], 'FooLoader' );
47de4e93	144	push @INC, $aref;
e5d18500	145
d1e4d418	146	$evalret = eval { require Quux1; 1 };
	147	die $@ if $@;
	148	ok( $evalret, 'require Quux1; magic via array object' );
	149	ok( exists $INC{'Quux1.pm'}, ' %INC sees Quux1.pm' );
6ece0f6b	150	is( ref $INC{'Quux1.pm'}, 'FooLoader',
d1e4d418	151	' val Quux1.pm is an object in %INC' );
d1e4d418	152	is( $INC{'Quux1.pm'}, $aref, ' val Quux1.pm is correct in %INC' );
e5d18500	153
	154	pop @INC;
	155
47de4e93	156	my $sref = bless( \(my $x = 1), 'FooLoader' );
47de4e93	157	push @INC, $sref;
e5d18500	158
d1e4d418	159	$evalret = eval { require Quux2; 1 };
	160	die $@ if $@;
	161	ok( $evalret, 'require Quux2; magic via scalar object' );
	162	ok( exists $INC{'Quux2.pm'}, ' %INC sees Quux2.pm' );
6ece0f6b	163	is( ref $INC{'Quux2.pm'}, 'FooLoader',
d1e4d418	164	' val Quux2.pm is an object in %INC' );
d1e4d418	165	is( $INC{'Quux2.pm'}, $sref, ' val Quux2.pm is correct in %INC' );
f8973f08	166
f8973f08	167	pop @INC;
9ae8cd5b	168
	169	push @INC, sub {
	170	my ($self, $filename) = @_;
	171	if (substr($filename,0,4) eq 'Toto') {
	172	$INC{$filename} = 'xyz';
	173	return get_temp_fh($filename);
	174	}
	175	else {
	176	return undef;
	177	}
	178	};
	179
d1e4d418	180	$evalret = eval { require Toto; 1 };
	181	die $@ if $@;
	182	ok( $evalret, 'require Toto; magic via anonymous code ref' );
	183	ok( exists $INC{'Toto.pm'}, ' %INC sees Toto.pm' );
	184	ok( ! ref $INC{'Toto.pm'}, q/ val Toto.pm isn't a ref in %INC/ );
	185	is( $INC{'Toto.pm'}, 'xyz', ' val Toto.pm is correct in %INC' );
9ae8cd5b	186
9ae8cd5b	187	pop @INC;
d820be44	188
3a5db825	189	push @INC, sub {
	190	my ($self, $filename) = @_;
	191	if ($filename eq 'abc.pl') {
	192	return get_temp_fh($filename, qq(return "abc";\n));
	193	}
	194	else {
	195	return undef;
	196	}
	197	};
	198
6b75eab3	199	my $ret = "";
3a5db825	200	$ret \|\|= do 'abc.pl';
	201	is( $ret, 'abc', 'do "abc.pl" sees return value' );
	202
ab742322	203	{
ab742322	204	my $filename = $^O eq 'MacOS' ? ':Foo:Foo.pm' : './Foo.pm';
c38a6530	205	#local @INC; # local fails on tied @INC
c38a6530	206	my @old_INC = @INC; # because local doesn't work on tied arrays
ab742322	207	@INC = sub { $filename = 'seen'; return undef; };
	208	eval { require $filename; };
	209	is( $filename, 'seen', 'the coderef sees fully-qualified pathnames' );
c38a6530	210	@INC = @old_INC;
ab742322	211	}
	212
	213	exit if $minitest;
	214
3a5db825	215	pop @INC;
3a5db825	216
a3b58a99	217	push @INC, sub {
	218	my ($cr, $filename) = @_;
	219	my $module = $filename; $module =~ s,/,::,g; $module =~ s/\.pm$//;
	220	open my $fh, '<', \"package $module; sub complain { warn q() }; \$::file = __FILE__;"
	221	or die $!;
	222	$INC{$filename} = "/custom/path/to/$filename";
	223	return $fh;
	224	};
	225
	226	require Publius::Vergilius::Maro;
	227	is( $INC{'Publius/Vergilius/Maro.pm'}, '/custom/path/to/Publius/Vergilius/Maro.pm', '%INC set correctly');
	228	is( our $file, '/custom/path/to/Publius/Vergilius/Maro.pm', '__FILE__ set correctly' );
	229	{
	230	my $warning;
	231	local $SIG{__WARN__} = sub { $warning = shift };
	232	Publius::Vergilius::Maro::complain();
	233	like( $warning, qr{something's wrong at /custom/path/to/Publius/Vergilius/Maro.pm}, 'warn() reports correct file source' );
	234	}
	235
	236	pop @INC;
	237
6b75eab3	238	if ($can_fork) {
	239	require PerlIO::scalar;
	240	# This little bundle of joy generates n more recursive use statements,
	241	# with each module chaining the next one down to 0. If it works, then we
	242	# can safely nest subprocesses
	243	my $use_filter_too;
	244	push @INC, sub {
	245	return unless $_[1] =~ /^BBBLPLAST(\d+)\.pm/;
	246	my $pid = open my $fh, "-\|";
	247	if ($pid) {
	248	# Parent
	249	return $fh unless $use_filter_too;
	250	# Try filters and state in addition.
	251	return ($fh, sub {s/$_[1]/pass/; return}, "die")
	252	}
	253	die "Can't fork self: $!" unless defined $pid;
	254
	255	# Child
	256	my $count = $1;
	257	# Lets force some fun with odd sized reads.
	258	$\| = 1;
	259	print 'push @main::bbblplast, ';
	260	print "$count;\n";
	261	if ($count--) {
	262	print "use BBBLPLAST$count;\n";
	263	}
	264	if ($use_filter_too) {
	265	print "die('In $_[1]');";
	266	} else {
	267	print "pass('In $_[1]');";
	268	}
	269	print '"Truth"';
	270	POSIX::_exit(0);
	271	die "Can't get here: $!";
	272	};
	273
	274	@::bbblplast = ();
	275	require BBBLPLAST5;
	276	is ("@::bbblplast", "0 1 2 3 4 5", "All ran");
	277
	278	foreach (keys %INC) {
	279	delete $INC{$_} if /^BBBLPLAST/;
	280	}
	281
	282	@::bbblplast = ();
	283	$use_filter_too = 1;
	284
	285	require BBBLPLAST5;
	286
	287	is ("@::bbblplast", "0 1 2 3 4 5", "All ran with a filter");
	288	}