From: Rafael Garcia-Suarez <rgarciasuarez@gmail.com>
Date: Fri, 3 Nov 2006 10:09:19 +0000 (+0000)
Subject: When code is loaded through an @INC-hook, and when this hook
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=a3b58a99a41a86ac422b863ee2844e354b2915f3;p=p5sagit%2Fp5-mst-13.2.git

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
--- 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
--- 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;