When code is loaded through an @INC-hook, and when this hook

has set a filename entry in %INC, make sure __FILE__ is set
for this code accordingly to the contents of that %INC entry.

p4raw-id: //depot/perl@29197

diff --git a/pp_ctl.c b/pp_ctl.c
index 7b91e86..7a8da0d 100644 (file)
--- a/pp_ctl.c
+++ b/pp_ctl.c
@@ -3166,6 +3166,7 @@ PP(pp_require)
 
                if (SvROK(dirsv)) {
                    int count;
+                   SV **svp;
                    SV *loader = dirsv;
 
                    if (SvTYPE(SvRV(loader)) == SVt_PVAV
@@ -3193,6 +3194,11 @@ PP(pp_require)
                        count = call_sv(loader, G_ARRAY);
                    SPAGAIN;
 
+                   /* Adjust file name if the hook has set an %INC entry */
+                   svp = hv_fetch(GvHVn(PL_incgv), name, len, 0);
+                   if (svp)
+                       tryname = SvPVX_const(*svp);
+
                    if (count > 0) {
                        int i = 0;
                        SV *arg;

diff --git a/t/op/inccode.t b/t/op/inccode.t
index f897852..d9516fa 100644 (file)
--- a/t/op/inccode.t
+++ b/t/op/inccode.t
@@ -19,7 +19,7 @@ use strict;
 use File::Spec;
 
 require "test.pl";
-plan(tests => 45 + 14 * $can_fork);
+plan(tests => 48 + 14 * $can_fork);
 
 my @tempfiles = ();
 
@@ -199,6 +199,27 @@ is( $ret, 'abc', 'do "abc.pl" sees return value' );
 
 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;
+
 my $filename = $^O eq 'MacOS' ? ':Foo:Foo.pm' : './Foo.pm';
 {
     local @INC;