Handle indirect calls on blocks

diff --git a/indirect.xs b/indirect.xs
index 45309ce648a1cf43b3b0cccd4a31b076d864a616..36585193fdfaedb6bed331987d7d42b84430df9a 100644 (file)
--- a/indirect.xs
+++ b/indirect.xs
@@ -401,13 +401,20 @@ STATIC void indirect_map_store(pTHX_ const OP *o, const char *src, SV *sv, line_
   oi->size = 0;
  }
 
- s = SvPV_const(sv, len);
+ if (sv) {
+  s = SvPV_const(sv, len);
+ } else {
+  s   = "{";
+  len = 1;
+ }
+
  if (len > oi->size) {
   Safefree(oi->buf);
   Newx(oi->buf, len, char);
   oi->size = len;
  }
  Copy(s, oi->buf, len, char);
+
  oi->len  = len;
  oi->pos  = src;
  oi->line = line;
@@ -570,6 +577,41 @@ STATIC OP *indirect_ck_padany(pTHX_ OP *o) {
  return o;
 }
 
+/* ... ck_scope ............................................................ */
+
+STATIC OP *(*indirect_old_ck_scope)  (pTHX_ OP *) = 0;
+STATIC OP *(*indirect_old_ck_lineseq)(pTHX_ OP *) = 0;
+
+STATIC OP *indirect_ck_scope(pTHX_ OP *o) {
+ OP *(*old_ck)(pTHX_ OP *) = 0;
+
+ switch (o->op_type) {
+  case OP_SCOPE:   old_ck = indirect_old_ck_scope;   break;
+  case OP_LINESEQ: old_ck = indirect_old_ck_lineseq; break;
+ }
+ o = CALL_FPTR(old_ck)(aTHX_ o);
+
+ if (indirect_hint()) {
+  indirect_map_store(o, PL_oldbufptr, NULL, CopLINE(&PL_compiling));
+  return o;
+ }
+
+ indirect_map_delete(o);
+ return o;
+}
+
+/* ... ck_leave ............................................................ */
+
+STATIC OP *(*indirect_old_ck_leave)(pTHX_ OP *) = 0;
+
+STATIC OP *indirect_ck_leave(pTHX_ OP *o) {
+ o = CALL_FPTR(indirect_old_ck_leave)(aTHX_ o);
+
+ /* Cleanup relevant entries in case ck_method catches them later. */
+ indirect_map_delete(o);
+ return o;
+}
+
 /* ... ck_method ........................................................... */
 
 STATIC OP *(*indirect_old_ck_method)(pTHX_ OP *) = 0;
@@ -649,6 +691,8 @@ STATIC OP *indirect_ck_entersub(pTHX_ OP *o) {
    case OP_CONST:
    case OP_RV2SV:
    case OP_PADSV:
+   case OP_SCOPE:
+   case OP_LEAVE:
     break;
    default:
     goto done;
@@ -732,6 +776,13 @@ BOOT:
   PL_check[OP_RV2SV]       = MEMBER_TO_FPTR(indirect_ck_rv2sv);
   indirect_old_ck_padany   = PL_check[OP_PADANY];
   PL_check[OP_PADANY]      = MEMBER_TO_FPTR(indirect_ck_padany);
+  indirect_old_ck_scope    = PL_check[OP_SCOPE];
+  PL_check[OP_SCOPE]       = MEMBER_TO_FPTR(indirect_ck_scope);
+  indirect_old_ck_lineseq  = PL_check[OP_LINESEQ];
+  PL_check[OP_LINESEQ]     = MEMBER_TO_FPTR(indirect_ck_scope);
+  indirect_old_ck_leave    = PL_check[OP_LEAVE];
+  PL_check[OP_LEAVE]       = MEMBER_TO_FPTR(indirect_ck_leave);
+
   indirect_old_ck_method   = PL_check[OP_METHOD];
   PL_check[OP_METHOD]      = MEMBER_TO_FPTR(indirect_ck_method);
   indirect_old_ck_entersub = PL_check[OP_ENTERSUB];

diff --git a/lib/indirect.pm b/lib/indirect.pm
index 53dc846c35692076b047854e0aafa6f41e031276..af8d4f7a8c71efaacbbc40e5ee60ae42fed3be68 100644 (file)
--- a/lib/indirect.pm
+++ b/lib/indirect.pm
@@ -48,7 +48,7 @@ BEGIN {
 When enabled (or disabled as some may prefer to say, since you actually turn it on by calling C<no indirect>), this pragma warns about indirect object syntax constructs that may have slipped into your code.
 This syntax is now considered harmful, since its parsing has many quirks and its use is error prone (when C<swoosh> isn't defined, C<swoosh $x> actually compiles to C<< $x->swoosh >>).
 
-It currently does not warn when the object is enclosed between braces (like C<meth { $obj } @args>) or for core functions (C<print> or C<say>).
+It currently does not warn for core functions (C<print>, C<say>, C<exec> or C<system>).
 This may change in the future, or may be added as optional features that would be enabled by passing options to C<unimport>.
 
 This module is B<not> a source filter.
@@ -127,7 +127,11 @@ Returns the default error message generated by C<indirect> when an invalid const
 =cut
 
 sub msg {
- "Indirect call of method \"$_[1]\" on object \"$_[0]\" at $_[2] line $_[3].\n"
+ my $obj = $_[0];
+
+ join ' ', "Indirect call of method \"$_[1]\" on",
+           ($obj =~ /^\s*\{/ ? "a block" : "object \"$obj\""),
+           "at $_[2] line $_[3].\n";
 };
 
 =head1 CONSTANTS

diff --git a/t/20-good.t b/t/20-good.t
index 88d80603cbae021567a929cbc75fb85206526595..0f482a55cf0a3bce2d3026b11fa39457e8215261 100644 (file)
--- a/t/20-good.t
+++ b/t/20-good.t
@@ -14,6 +14,7 @@ use Test::More tests => 56 * 4;
 my ($obj, $pkg, $cb, $x, @a);
 our $y;
 sub meh;
+sub try (&);
 
 {
  local $/ = "####";
@@ -129,21 +130,6 @@ $obj = $pkg->$cb( $obj  );
 ####
 $obj = $pkg->$cb(qw/foo bar baz/);
 ####
-$obj = new { $x };
-####
-$obj = new
-  {
-     $x  }
-  ();
-####
-$obj = new {
-  $x  } qq/foo/;
-####
-$obj = new
-   {
-      $x
-    }(qw/bar baz/);
-####
 meh;
 ####
 meh $_;
@@ -191,3 +177,11 @@ exec { $a[0] } @a;
 system $x $x, @a;
 ####
 system { $a[0] } @a;
+####
+try { };
+####
+try { 1; };
+####
+try { 1; 1; };
+####
+try { try { }; 1; };

diff --git a/t/21-bad.t b/t/21-bad.t
index 9f8f3ff0de6a5da8c40f90b81dbde18e7c6dcbdf..eea745eb863c64e8301c610f528aeabc740e1549 100644 (file)
--- a/t/21-bad.t
+++ b/t/21-bad.t
@@ -11,8 +11,8 @@ use warnings;
 
 my ($tests, $reports);
 BEGIN {
- $tests   = 52;
- $reports = 53;
+ $tests   = 60;
+ $reports = 68;
 }
 
 use Test::More tests => 3 * (4 * $tests + $reports) + 2;
@@ -27,10 +27,11 @@ sub expect {
 
  map {
   my ($meth, $obj, $file, $line) = @$_;
-  $_    = quotemeta      for $meth, $obj;
+  $meth = quotemeta $meth;
+  $obj  = ($obj =~ /^\s*\{/) ? "a block" : "object \"\Q$obj\E\"";
   $file = '\(eval \d+\)' unless defined $file;
   $line = '\d+'          unless defined $line;
-  qr/^Indirect call of method "$meth" on object "$obj" at $file line $line/
+  qr/^Indirect call of method "$meth" on $obj at $file line $line/
  } eval $expected;
 }
 
@@ -354,3 +355,40 @@ new Hlagh (meh $x)
 Hlagh->new(meh $x)
 ----
 [ 'meh', '$x' ]
+####
+meh { };
+----
+[ 'meh', '{' ]
+####
+meh {
+ 1;
+};
+----
+[ 'meh', '{' ]
+####
+meh {
+ 1;
+ 1;
+};
+----
+[ 'meh', '{' ]
+####
+meh { new Hlagh; 1; };
+----
+[ 'new', 'Hlagh' ], [ 'meh', '{' ]
+####
+meh { feh $x; 1; };
+----
+[ 'feh', '$x' ], [ 'meh', '{' ]
+####
+meh { feh $x; use indirect; new Hlagh; 1; };
+----
+[ 'feh', '$x' ], [ 'meh', '{' ]
+####
+meh { feh $y; 1; };
+----
+[ 'feh', '$y' ], [ 'meh', '{' ]
+####
+meh { feh $x; 1; } new Hlagh, feh $y;
+----
+[ 'feh', '$x' ], [ 'new', 'Hlagh' ], [ 'feh', '$y' ], [ 'meh', '{' ]