From: Vincent Pit Date: Tue, 14 Jul 2009 14:00:19 +0000 (+0200) Subject: Handle indirect calls on blocks X-Git-Tag: v0.16~10 X-Git-Url: http://git.vpit.fr/?p=perl%2Fmodules%2Findirect.git;a=commitdiff_plain;h=ff16be2f69592b80dfcbc397b37dd4ea070b9d62;hp=a5339a6ced4d5e3ad1541320476c3d6bf8ff9408 Handle indirect calls on blocks --- diff --git a/indirect.xs b/indirect.xs index 45309ce..3658519 100644 --- 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 53dc846..af8d4f7 100644 --- 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), 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 isn't defined, C actually compiles to C<< $x->swoosh >>). -It currently does not warn when the object is enclosed between braces (like C) or for core functions (C or C). +It currently does not warn for core functions (C, C, C or C). This may change in the future, or may be added as optional features that would be enabled by passing options to C. This module is B a source filter. @@ -127,7 +127,11 @@ Returns the default error message generated by C 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 88d8060..0f482a5 100644 --- 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 9f8f3ff..eea745e 100644 --- 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', '{' ]