From: Vincent Pit <vince@profvince.com>
Date: Mon, 16 Aug 2010 12:53:34 +0000 (+0200)
Subject: Only check methods where the method name is a constant
X-Git-Tag: rt60378^0
X-Git-Url: http://git.vpit.fr/?p=perl%2Fmodules%2Findirect.git;a=commitdiff_plain;h=6dcc20b6e77e55bd8b635d42663ec99ecf42bad2

Only check methods where the method name is a constant

This fixes RT #60378.
---

diff --git a/indirect.xs b/indirect.xs
index 578c154..4ce10e5 100644
--- a/indirect.xs
+++ b/indirect.xs
@@ -649,28 +649,35 @@ STATIC OP *(*indirect_old_ck_method)(pTHX_ OP *) = 0;
 STATIC OP *indirect_ck_method(pTHX_ OP *o) {
  if (indirect_hint()) {
   OP *op = cUNOPo->op_first;
-  const indirect_op_info_t *oi = indirect_map_fetch(op);
-  const char *s = NULL;
-  line_t line;
-  SV *sv;
 
-  if (oi && (s = oi->pos)) {
-   sv   = sv_2mortal(newSVpvn(oi->buf, oi->len));
-   line = oi->line; /* Keep the old line so that we really point to the first */
-  } else {
-   sv = cSVOPx_sv(op);
-   if (!SvPOK(sv) || (SvTYPE(sv) < SVt_PV))
-    goto done;
-   sv   = sv_mortalcopy(sv);
-   s    = indirect_find(sv, PL_oldbufptr);
-   line = CopLINE(&PL_compiling);
-  }
+  /* Indirect method call is only possible when the method is a bareword, so
+   * don't trip up on $obj->$meth. */
+  if (op && op->op_type == OP_CONST) {
+   const indirect_op_info_t *oi = indirect_map_fetch(op);
+   const char *s = NULL;
+   line_t line;
+   SV *sv;
+
+   if (oi && (s = oi->pos)) {
+    sv   = sv_2mortal(newSVpvn(oi->buf, oi->len));
+    /* Keep the old line so that we really point to the first line of the
+     * expression. */
+    line = oi->line;
+   } else {
+    sv = cSVOPx_sv(op);
+    if (!SvPOK(sv) || (SvTYPE(sv) < SVt_PV))
+     goto done;
+    sv   = sv_mortalcopy(sv);
+    s    = indirect_find(sv, PL_oldbufptr);
+    line = CopLINE(&PL_compiling);
+   }
 
-  o = CALL_FPTR(indirect_old_ck_method)(aTHX_ o);
-  /* o may now be a method_named */
+   o = CALL_FPTR(indirect_old_ck_method)(aTHX_ o);
+   /* o may now be a method_named */
 
-  indirect_map_store(o, s, sv, line);
-  return o;
+   indirect_map_store(o, s, sv, line);
+   return o;
+  }
  }
 
 done:
diff --git a/t/20-good.t b/t/20-good.t
index 3539498..f883537 100644
--- a/t/20-good.t
+++ b/t/20-good.t
@@ -9,12 +9,12 @@ package main;
 use strict;
 use warnings;
 
-use Test::More tests => 56 * 8;
+use Test::More tests => 80 * 8;
 
 BEGIN { delete $ENV{PERL_INDIRECT_PM_DISABLE} }
 
 my ($obj, $pkg, $cb, $x, @a);
-our $y;
+our ($y, $meth);
 sub meh;
 sub zap (&);
 
@@ -124,6 +124,12 @@ $obj = Hlagh->$cb($pkg);
 ####
 $obj = Hlagh->$cb(sub { 'foo' },  bar => $obj);
 ####
+$obj = Hlagh->$meth;
+####
+$obj =   Hlagh
+   -> 
+          $meth   ( 1,   2   );
+####
 $obj = $pkg->new   ;
 ####
 $obj = $pkg  ->   new  (   );
@@ -151,6 +157,30 @@ $obj = $pkg->$cb( $obj  );
 ####
 $obj = $pkg->$cb(qw/foo bar baz/);
 ####
+$obj = $pkg->$meth;
+####
+$obj 
+ =
+    $pkg
+          ->
+              $meth
+  ( 1 .. 10 );
+####
+$obj = $y->$cb;
+####
+$obj =  $y
+  ->          $cb   (
+  'foo', 1, 2, 'bar'
+);
+####
+$obj = $y->$meth;
+####
+$obj =
+  $y->
+      $meth   (
+ qr(hello),
+);
+####
 meh;
 ####
 meh $_;
@@ -187,10 +217,42 @@ print STDOUT "bananananananana\n";
 ####
 $x->foo($pkg->$cb)
 ####
+$obj = "apple ${\($x->new)} pear"
+####
+$obj = "apple @{[$x->new]} pear"
+####
+$obj = "apple ${\($y->new)} pear"
+####
+$obj = "apple @{[$y->new]} pear"
+####
+$obj = "apple ${\($x->$cb)} pear"
+####
+$obj = "apple @{[$x->$cb]} pear"
+####
+$obj = "apple ${\($y->$cb)} pear"
+####
+$obj = "apple @{[$y->$cb]} pear"
+####
+$obj = "apple ${\($x->$meth)} pear"
+####
+$obj = "apple @{[$x->$meth]} pear"
+####
+$obj = "apple ${\($y->$meth)} pear"
+####
+$obj = "apple @{[$y->$meth]} pear"
+####
 $obj = "apple ${\(new Hlagh)} pear"
 ####
 $obj = "apple @{[new Hlagh]} pear"
 ####
+$obj = "apple ${\(new $x)} pear"
+####
+$obj = "apple @{[new $x]} pear"
+####
+$obj = "apple ${\(new $y)} pear"
+####
+$obj = "apple @{[new $y]} pear"
+####
 exec $x $x, @a;
 ####
 exec { $a[0] } @a;