fix caller with re_evals.
authorDavid Mitchell <davem@iabyn.com>
Wed, 24 Apr 2013 13:41:33 +0000 (14:41 +0100)
committerDavid Mitchell <davem@iabyn.com>
Wed, 24 Apr 2013 15:39:47 +0000 (16:39 +0100)
(See RT #113928)

In code like

    sub foo {  /A(?{ bar; caller(); }B/; }

the regex /A(?{B})C/ is, from a scope point of view, supposed to
be compiled and executed as:

    /A/ && do { B } && /C/;

i.e. the code block in B is part of the same sub as the code surrounding
the regex. Thus the result of caller() above should see the caller as
whoever called foo.

Due to an implementation detail, we actually push a hidden extra
sub CX before calling the pattern. This detail was leaking when caller()
was used. Fux it so that it ignores this extra context frame.

Conversely, for a qr//, that *is* supposed to be seen as an extra level
of anonymous sub, so add tests to ensure that is so.
i.e.

    $r = qr/...(?{code}).../
    /...$r.../

is supposed to behave like

    $r = sub { code };
    $r->();

pp_ctl.c
t/re/reg_eval_scope.t

index aae200f..f08e376 100644 (file)
--- a/pp_ctl.c
+++ b/pp_ctl.c
@@ -1438,8 +1438,14 @@ S_dopoptosub_at(pTHX_ const PERL_CONTEXT *cxstk, I32 startingblock)
        switch (CxTYPE(cx)) {
        default:
            continue;
-       case CXt_EVAL:
        case CXt_SUB:
+            /* in sub foo { /(?{...})/ }, foo ends up on the CX stack
+             * twice; the first for the normal foo() call, and the second
+             * for a faked up re-entry into the sub to execute the
+             * code block. Hide this faked entry from the world. */
+            if (cx->cx_type & CXp_SUB_RE_FAKE)
+                continue;
+       case CXt_EVAL:
        case CXt_FORMAT:
            DEBUG_l( Perl_deb(aTHX_ "(dopoptosub_at(): found sub at cx=%ld)\n", (long)i));
            return i;
index 46b9bb2..80eeb8a 100644 (file)
@@ -9,7 +9,7 @@ BEGIN {
     skip_all_if_miniperl("no dynamic loading on miniperl, no re");
 }
 
-plan 34;
+plan 45;
 
 fresh_perl_is <<'CODE', '781745', {}, '(?{}) has its own lexical scope';
  my $x = 7; my $a = 4; my $b = 5;
@@ -131,11 +131,11 @@ CODE
 
 fresh_perl_is <<'CODE',
     my $a=4; my $b=5;
-    sub f { print ((caller(0))[3], "-", (caller(1))[3], "\n") };
+    sub f { print ((caller(0))[3], "-", (caller(1))[3], "-\n") };
     "a" =~ /(?{f()})a/;
     print $a,$b;
 CODE
-    "main::f-(unknown)\n45",
+    "main::f--\n45",
     { stderr => 1 }, 'sub f {caller} /(?{f()})/';
 
 
@@ -282,3 +282,66 @@ pass "undef *_ in a re-eval does not cause a double free";
     $l = __LINE__; "4" =~ /^$c/x or warn "foo";
     like($w, qr/foo.+line $l/, 'curcop 4');
 }
+
+# [perl #113928] caller behaving unexpectedly in re-evals
+#
+#   /(?{...})/ should be in the same caller scope as the surrounding code;
+# qr/(?{...})/ should be in an anon sub
+
+{
+
+    my $l;
+
+    sub callers {
+       my @c;
+       my $stack = '';
+       my $i = 1;
+       while (@c = caller($i++)) {
+           $stack .= "($c[3]:" . ($c[2] - $l) . ')';
+       }
+       $stack;
+    }
+
+    $l = __LINE__;
+    my $c;
+    is (callers(), '', 'callers() null');
+    "" =~ /(?{ $c = callers() })/;
+    is ($c, '', 'callers() //');
+
+    $l = __LINE__;
+    sub m1 { "" =~ /(?{ $c = callers() })/; }
+    m1();
+    is ($c, '(main::m1:2)', 'callers() m1');
+
+    $l = __LINE__;
+    my $r1 = qr/(?{ $c = callers() })/;
+    "" =~ /$r1/;
+    is ($c, '(main::__ANON__:2)', 'callers() r1');
+
+    $l = __LINE__;
+    sub r1 { "" =~ /$r1/; }
+    r1();
+    is ($c, '(main::__ANON__:1)(main::r1:2)', 'callers() r1/r1');
+
+    $l = __LINE__;
+    sub c2 { $c = callers() }
+    my $r2 = qr/(?{ c2 })/;
+    "" =~ /$r2/;
+    is ($c, '(main::c2:2)(main::__ANON__:3)', 'callers() r2/c2');
+    sub r2 { "" =~ /$r2/; }
+    r2();
+    is ($c, '(main::c2:2)(main::__ANON__:5)(main::r2:6)', 'callers() r2/r2/c2');
+
+    $l = __LINE__;
+    sub c3 { $c = callers() }
+    my $r3 = qr/(?{ c3 })/;
+    my $c1;
+    "ABC" =~ /A(?{ $c1 = callers() })B${r3}C/;
+    is ($c, '(main::c3:2)(main::__ANON__:4)', 'callers() r3/c3');
+    is ($c1,'', 'callers() r3/c3 part 2');
+    sub r3 { "ABC" =~ /A(?{ $c1 = callers() })B${r3}C/; }
+    r3();
+    is ($c, '(main::c3:2)(main::__ANON__:7)(main::r3:8)', 'callers() r3/r3/c3');
+    is ($c1,'(main::r3:8)', 'callers() r3/r3/c3 part 2');
+
+}