# 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);
+ require './test.pl';
+ set_up_inc('../lib');
}
-if (!$minitest) {
- use Config;
- if (PerlIO::Layer->find('perlio') && $Config{d_fork} &&
- eval 'require POSIX; 1') {
+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;
-use File::Spec;
-
-require "test.pl";
-plan(tests => 45 + !$minitest * (3 + 14 * $can_fork));
-my @tempfiles = ();
+plan(tests => 68 + !is_miniperl() * (3 + 14 * $can_fork));
sub get_temp_fh {
- my $f = "DummyModule0000";
- 1 while -e ++$f;
- push @tempfiles, $f;
+ 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;
return $fh;
}
-END { 1 while unlink @tempfiles }
-
sub fooinc {
my ($self, $filename) = @_;
if (substr($filename,0,3) eq 'Foo') {
is( $ret, 'abc', 'do "abc.pl" sees return value' );
{
- my $filename = $^O eq 'MacOS' ? ':Foo:Foo.pm' : './Foo.pm';
- local @INC;
- @INC = sub { $filename = 'seen'; return undef; };
- eval { require $filename; };
- is( $filename, 'seen', 'the coderef sees fully-qualified pathnames' );
+ 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;
}
-exit if $minitest;
+# 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 };
-pop @INC;
+ my $initial_sub_refcnt = &Internals::SvREFCNT($die);
+ my $initial_data_refcnt = &Internals::SvREFCNT($data);
-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;
-};
+ 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");
-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' );
+ 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
+}
{
- 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' );
+ local @INC = @INC;
+ @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) {
https://perl5.git.perl.org / perl5.git / blobdiff