From: Vincent Pit 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/?a=commitdiff_plain;h=6dcc20b6e77e55bd8b635d42663ec99ecf42bad2;p=perl%2Fmodules%2Findirect.git 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;