From: Vincent Pit <vince@profvince.com>
Date: Thu, 5 Sep 2013 11:02:10 +0000 (+0200)
Subject: Handle __PACKAGE__ as object name correctly
X-Git-Tag: rt88428^0
X-Git-Url: http://git.vpit.fr/?a=commitdiff_plain;h=07fb4eb28539b53578b1421e348c12c921d180f1;p=perl%2Fmodules%2Findirect.git

Handle __PACKAGE__ as object name correctly

__PACKAGE__ cannot appear as the object name for indirect calls, but it
can for direct ones. This could cause wrong reports of indirect calls
when the actual package name appeared later in the source, for instance
in a comment. This is fixed by looking for '__PACKAGE__' in the source
buffer when we already have a hit for the current package name, and by
keeping the first one of those two.

This fixes RT #88428.
---

diff --git a/indirect.xs b/indirect.xs
index 7878802..3bd5e6c 100644
--- a/indirect.xs
+++ b/indirect.xs
@@ -576,6 +576,25 @@ STATIC OP *indirect_ck_const(pTHX_ OP *o) {
    STRLEN pos;
 
    if (indirect_find(sv, PL_oldbufptr, &pos)) {
+    STRLEN len;
+
+    /* If the constant is equal to the current package name, try to look for
+     * a "__PACKAGE__" coming before what we got. We only need to check this
+     * when we already had a match because __PACKAGE__ can only appear in
+     * direct method calls ("new __PACKAGE__" is a syntax error). */
+    len = SvCUR(sv);
+    if (len == HvNAMELEN_get(PL_curstash)
+        && memcmp(SvPVX(sv), HvNAME_get(PL_curstash), len) == 0) {
+     STRLEN pos_pkg;
+     SV    *pkg = sv_newmortal();
+     sv_setpvn(pkg, "__PACKAGE__", sizeof("__PACKAGE__")-1);
+
+     if (indirect_find(pkg, PL_oldbufptr, &pos_pkg) && pos_pkg < pos) {
+      sv  = pkg;
+      pos = pos_pkg;
+     }
+    }
+
     indirect_map_store(o, pos, sv, CopLINE(&PL_compiling));
     return o;
    }
diff --git a/t/20-good.t b/t/20-good.t
index d57de4f..f6fe90a 100644
--- a/t/20-good.t
+++ b/t/20-good.t
@@ -9,7 +9,7 @@ package main;
 use strict;
 use warnings;
 
-use Test::More tests => 112 * 8 + 10;
+use Test::More tests => 119 * 8 + 10;
 
 BEGIN { delete $ENV{PERL_INDIRECT_PM_DISABLE} }
 
@@ -441,3 +441,25 @@ sub {
  my $self = shift;
  return $_[0] ? undef : $self->new;
 }
+####
+package Hurp;
+__PACKAGE__->new;
+####
+package Hurp;
+__PACKAGE__->new # Hurp
+####
+package Hurp;
+__PACKAGE__->new;
+# Hurp
+####
+package __PACKAGE_;
+__PACKAGE__->new # __PACKAGE_
+####
+package __PACKAGE_;
+__PACKAGE_->new # __PACKAGE__
+####
+package __PACKAGE___;
+__PACKAGE__->new # __PACKAGE___
+####
+package __PACKAGE___;
+__PACKAGE___->new # __PACKAGE__
diff --git a/t/21-bad.t b/t/21-bad.t
index fa2c322..0d3b48d 100644
--- a/t/21-bad.t
+++ b/t/21-bad.t
@@ -11,8 +11,8 @@ use warnings;
 
 my ($tests, $reports);
 BEGIN {
- $tests   = 82;
- $reports = 94;
+ $tests   = 84;
+ $reports = 96;
 }
 
 use Test::More tests => 3 * (4 * $tests + $reports) + 4;
@@ -491,3 +491,13 @@ meh { feh $x; 1; } new Hlagh, feh $y;
 $obj = "apple @{[new { feh $x; meh $y; 1 }]} pear"
 ----
 [ 'feh', '$x' ], [ 'meh', '$y' ], [ 'new', '{' ]
+####
+package __PACKAGE_;
+new __PACKAGE_;
+----
+[ 'new', '__PACKAGE_' ]
+####
+package __PACKAGE___;
+new __PACKAGE___;
+----
+[ 'new', '__PACKAGE___' ]