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

#!./perl -w

# Tests for the coderef-in-@INC feature

use Config;

my $can_fork   = 0;
my $minitest   = $ENV{PERL_CORE_MINITEST};
my $has_perlio = $Config{useperlio};

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

if (!$minitest) {
    if ($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;

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