This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
make calling of /(?{}) code blocks correct
authorDavid Mitchell <davem@iabyn.com>
Fri, 4 May 2012 15:34:01 +0000 (16:34 +0100)
committerDavid Mitchell <davem@iabyn.com>
Wed, 13 Jun 2012 12:32:52 +0000 (13:32 +0100)
Formerly, it just updated PL_comppad, set PL_op to the first op of the
code block, and did CALLRUNOPS().

This had a lot of problems, e.g. depth of recursion, and not having
anything on the context stack for die/caller/next/goto etc to see, usually
leading to segfaults.

Make it so that it uses the MULTICALL API instead. This makes it push a
new stack and a CxSUB context stack frame; it also makes us share code
rather than rolling our own.

MULTICALL had to be extended in two ways to make this work; but these have
not yet been made part of the public API. First, it had to allow changing
of the current CV while leaving the current CxSUB frame in place, and
secondly it had to allow pushing a CV with a zero increment of CvDEPTH.
This latter is to handle direct literal blocks:

    /(?{...})/

which are compiled into the same CV as the surrounding scope; therefore we
need to push the same sub twice at the same depth (usually 1), i.e.

    $ ./perl -Dstv -e'sub f { /(?{$x})/ } f'
    ...
    (29912:-e:1) gvsv(main::x)

    STACK 0: MAIN
      CX 0: BLOCK  =>
      CX 1: SUB    =>           <=== the same sub ...
      retop=leave
    STACK 1: SORT
      CX 0: SUB    => UNDEF     <==== ... as this
      retop=(null)

(note that stack 1 is misidentified as SORT; this is a bug in MULTICALl
to be fixed later).

One has to be very careful with the save stack; /(?{})/ is designed
not to introduce a new scope, so that the effects of 'local' etc
accumulate across multiple block invocations (but get popped on
backtracking). This is why we couldn't just do a POP_MULTICALL/PUSH_MULTICALL
pair to change the current CV; the former would pop the save stack too.

Note that in the current implementation, after calling out to the first
code block, we leave the CxSUB and PL_comppad value in place, on the
assumption that it may be soon re-used, and only pop the CxSUB at the end
of S_regmatch(). However, when popping the savestack on backtracking, this
will restore PL_comppad to its original value; so when calling a new code
block with the same CV, we can't rely on PL_comppad still being correct.

Also, this means that outside of a code block call, the context stack and
PL_comppad are wrong; I can't think of anything within the regex code
that could be using these; but it if it turns out not to be the case,
then we'd have to change it so that after each code block call, we pop the
CxSUB off the stack and restore PL_comppad, but without popping the save
stack.

cop.h
pp_ctl.c
regexec.c
t/re/pat_re_eval.t
t/re/reg_eval_scope.t

diff --git a/cop.h b/cop.h
index af98965..041420c 100644 (file)
--- a/cop.h
+++ b/cop.h
@@ -1180,6 +1180,12 @@ See L<perlcall/LIGHTWEIGHT CALLBACKS>.
     U8 hasargs = 0             /* used by PUSHSUB */
 
 #define PUSH_MULTICALL(the_cv) \
+    PUSH_MULTICALL_WITHDEPTH(the_cv, 1);
+
+/* Like PUSH_MULTICALL, but allows you to specify the CvDEPTH increment,
+ * rather than the default of 1 (this isn't part of the public API) */
+
+#define PUSH_MULTICALL_WITHDEPTH(the_cv, depth) \
     STMT_START {                                                       \
        CV * const _nOnclAshIngNamE_ = the_cv;                          \
        CV * const cv = _nOnclAshIngNamE_;                              \
@@ -1191,7 +1197,8 @@ See L<perlcall/LIGHTWEIGHT CALLBACKS>.
        PUSHSTACKi(PERLSI_SORT);                                        \
        PUSHBLOCK(cx, CXt_SUB|CXp_MULTICALL, PL_stack_sp);              \
        PUSHSUB(cx);                                                    \
-       if (++CvDEPTH(cv) >= 2) {                                       \
+       CvDEPTH(cv) += depth;                                           \
+       if (CvDEPTH(cv) >= 2) {                                         \
            PERL_STACK_OVERFLOW_CHECK();                                \
            Perl_pad_push(aTHX_ padlist, CvDEPTH(cv));                  \
        }                                                               \
@@ -1209,8 +1216,9 @@ See L<perlcall/LIGHTWEIGHT CALLBACKS>.
 
 #define POP_MULTICALL \
     STMT_START {                                                       \
-       if (! --CvDEPTH(multicall_cv))                                  \
-           LEAVESUB(multicall_cv);                                     \
+       if (! ((CvDEPTH(multicall_cv) = cx->blk_sub.olddepth)) ) {      \
+               LEAVESUB(multicall_cv);                                 \
+       }                                                               \
        POPBLOCK(cx,PL_curpm);                                          \
        POPSTACK;                                                       \
        CATCH_SET(multicall_oldcatch);                                  \
@@ -1218,6 +1226,31 @@ See L<perlcall/LIGHTWEIGHT CALLBACKS>.
        SPAGAIN;                                                        \
     } STMT_END
 
+/* Change the CV of an already-pushed MULTICALL CxSUB block.
+ * (this isn't part of the public API) */
+
+#define CHANGE_MULTICALL_WITHDEPTH(the_cv, depth) \
+    STMT_START {                                                       \
+       CV * const _nOnclAshIngNamE_ = the_cv;                          \
+       CV * const cv = _nOnclAshIngNamE_;                              \
+       AV * const padlist = CvPADLIST(cv);                             \
+       cx = &cxstack[cxstack_ix];                                      \
+       assert(cx->cx_type & CXp_MULTICALL);                            \
+       if (! ((CvDEPTH(multicall_cv) = cx->blk_sub.olddepth)) ) {      \
+               LEAVESUB(multicall_cv);                                 \
+       }                                                               \
+       cx->cx_type &= ~CXp_HASARGS;                                    \
+       PUSHSUB(cx);                                                    \
+       CvDEPTH(cv) += depth;                                           \
+       if (CvDEPTH(cv) >= 2) {                                         \
+           PERL_STACK_OVERFLOW_CHECK();                                \
+           Perl_pad_push(aTHX_ padlist, CvDEPTH(cv));                  \
+       }                                                               \
+       SAVECOMPPAD();                                                  \
+       PAD_SET_CUR_NOSAVE(padlist, CvDEPTH(cv));                       \
+       multicall_cv = cv;                                              \
+       multicall_cop = CvSTART(cv);                                    \
+    } STMT_END
 /*
  * Local variables:
  * c-indentation-style: bsd
index 01bb5c3..4e00d9a 100644 (file)
--- a/pp_ctl.c
+++ b/pp_ctl.c
@@ -1834,7 +1834,7 @@ PP(pp_caller)
     if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
        GV * const cvgv = CvGV(dbcx->blk_sub.cv);
        /* So is ccstack[dbcxix]. */
-       if (isGV(cvgv)) {
+       if (cvgv && isGV(cvgv)) {
            SV * const sv = newSV(0);
            gv_efullname3(sv, cvgv, NULL);
            mPUSHs(sv);
index e14c69c..0fbbc17 100644 (file)
--- a/regexec.c
+++ b/regexec.c
@@ -2576,18 +2576,6 @@ S_regtry(pTHX_ regmatch_info *reginfo, char **startpos)
        MAGIC *mg;
 
        PL_reg_state.re_state_eval_setup_done = TRUE;
-       DEBUG_EXECUTE_r(DEBUG_s(
-           PerlIO_printf(Perl_debug_log, "  setting stack tmpbase at %"IVdf"\n",
-                         (IV)(PL_stack_sp - PL_stack_base));
-           ));
-       SAVESTACK_CXPOS();
-       cxstack[cxstack_ix].blk_oldsp = PL_stack_sp - PL_stack_base;
-       /* Otherwise OP_NEXTSTATE will free whatever on stack now.  */
-       SAVETMPS;
-       /* Apparently this is not needed, judging by wantarray. */
-       /* SAVEI8(cxstack[cxstack_ix].blk_gimme);
-          cxstack[cxstack_ix].blk_gimme = G_SCALAR; */
-
        if (reginfo->sv) {
            /* Make $_ available to executed code. */
            if (reginfo->sv != DEFSV) {
@@ -3125,11 +3113,22 @@ S_regmatch(pTHX_ regmatch_info *reginfo, regnode *prog)
                                false: plain (?=foo)
                                true:  used as a condition: (?(?=foo))
                            */
-    PAD* const initial_pad = PL_comppad;
+    PAD* last_pad = NULL;
+    dMULTICALL;
+    I32 gimme = G_SCALAR;
+    CV *caller_cv = NULL;      /* who called us */
+    CV *last_pushed_cv = NULL; /* most recently called (?{}) CV */
+
 #ifdef DEBUGGING
     GET_RE_DEBUG_FLAGS_DECL;
 #endif
 
+    /* shut up 'may be used uninitialized' compiler warnings for dMULTICALL */
+    multicall_oldcatch = 0;
+    multicall_cv = NULL;
+    cx = NULL;
+
+
     PERL_ARGS_ASSERT_REGMATCH;
 
     DEBUG_OPTIMISE_r( DEBUG_EXECUTE_r({
@@ -4244,13 +4243,15 @@ S_regmatch(pTHX_ regmatch_info *reginfo, regnode *prog)
             }    
            {
                /* execute the code in the {...} */
+
                dSP;
-               SV ** const before = SP;
+               SV ** before;
                OP * const oop = PL_op;
                COP * const ocurcop = PL_curcop;
-               PAD *old_comppad, *new_comppad;
+               OP *nop;
                char *saved_regeol = PL_regeol;
                struct re_save_state saved_state;
+               CV *newcv;
 
                /* To not corrupt the existing regex state while executing the
                 * eval we would normally put it on the save stack, like with
@@ -4267,36 +4268,40 @@ S_regmatch(pTHX_ regmatch_info *reginfo, regnode *prog)
                 * variable.
                 */
                Copy(&PL_reg_state, &saved_state, 1, struct re_save_state);
+
                PL_reg_state.re_reparsing = FALSE;
 
+               if (!caller_cv)
+                   caller_cv = find_runcv(NULL);
+
                n = ARG(scan);
+
                if (rexi->data->what[n] == 'r') { /* code from an external qr */
-                   /* XXX assumes pad depth is 1; this isn't necessarily
-                    * the case with recursive qr//'s */
-                   new_comppad = (PAD*)AvARRAY(CvPADLIST(
-                                           ((struct regexp *)SvANY(
+                   newcv = ((struct regexp *)SvANY(
                                                (REGEXP*)(rexi->data->data[n])
                                            ))->qr_anoncv
-                                       ))[1];
-                   PL_op = (OP*)rexi->data->data[n+1];
+                                       ;
+                   nop = (OP*)rexi->data->data[n+1];
                }
                else if (rexi->data->what[n] == 'l') { /* literal code */
-                   new_comppad = initial_pad; /* the pad of the current sub */
-                   PL_op = (OP*)rexi->data->data[n];
+                   newcv = caller_cv;
+                   nop = (OP*)rexi->data->data[n];
+                   assert(CvDEPTH(newcv));
                }
                else {
                    /* literal with own CV */
                    assert(rexi->data->what[n] == 'L');
-                   new_comppad =  (PAD*)AvARRAY(CvPADLIST(rex->qr_anoncv))[1];
-                   PL_op = (OP*)rexi->data->data[n];
+                   newcv = rex->qr_anoncv;
+                   nop = (OP*)rexi->data->data[n];
                }
+
                /* the initial nextstate you would normally execute
                 * at the start of an eval (which would cause error
                 * messages to come from the eval), may be optimised
                 * away from the execution path in the regex code blocks;
                 * so manually set PL_curcop to it initially */
                {
-                   OP *o = cUNOPx(PL_op)->op_first;
+                   OP *o = cUNOPx(nop)->op_first;
                    assert(o->op_type == OP_NULL);
                    if (o->op_targ == OP_SCOPE) {
                        o = cUNOPo->op_first;
@@ -4320,21 +4325,31 @@ S_regmatch(pTHX_ regmatch_info *reginfo, regnode *prog)
                        PL_curcop = (COP*)o;
                    }
                }
-               PL_op = PL_op->op_next;
+               nop = nop->op_next;
 
                DEBUG_STATE_r( PerlIO_printf(Perl_debug_log, 
-                   "  re EVAL PL_op=0x%"UVxf"\n", PTR2UV(PL_op)) );
-               /* wrap the call in two SAVECOMPPADs. This ensures that
-                * when the save stack is eventually unwound, all the
-                * accumulated SAVEt_CLEARSV's will be processed with
-                * interspersed SAVEt_COMPPAD's to ensure that lexicals
-                * are cleared in the right pad */
-               if (PL_comppad == new_comppad)
-                   old_comppad = new_comppad;
-               else {
-                   SAVECOMPPAD();
-                   PAD_SAVE_LOCAL(old_comppad, new_comppad);
+                   "  re EVAL PL_op=0x%"UVxf"\n", PTR2UV(nop)) );
+
+               /* normally if we're about to execute code from the same
+                * CV that we used previously, we just use the existing
+                * CX stack entry. However, its possible that in the
+                * meantime we may have backtracked, popped from the save
+                * stack, and undone the SAVECOMPPAD(s) associated with
+                * PUSH_MULTICALL; in which case PL_comppad no longer
+                * points to newcv's pad. */
+               if (newcv != last_pushed_cv || PL_comppad != last_pad)
+               {
+                   I32 depth = (newcv == caller_cv) ? 0 : 1;
+                   if (last_pushed_cv) {
+                       CHANGE_MULTICALL_WITHDEPTH(newcv, depth);
+                   }
+                   else {
+                       PUSH_MULTICALL_WITHDEPTH(newcv, depth);
+                   }
+                   last_pushed_cv = newcv;
                }
+               last_pad = PL_comppad;
+
                PL_regoffs[0].end = PL_reg_magic->mg_len = locinput - PL_bostr;
 
                 if (sv_yes_mark) {
@@ -4342,6 +4357,11 @@ S_regmatch(pTHX_ regmatch_info *reginfo, regnode *prog)
                     sv_setsv(sv_mrk, sv_yes_mark);
                 }
 
+               /* we don't use MULTICALL here as we want to call the
+                * first op of the block of interest, rather than the
+                * first op of the sub */
+               before = SP;
+               PL_op = nop;
                CALLRUNOPS(aTHX);                       /* Scalar context. */
                SPAGAIN;
                if (SP == before)
@@ -4353,11 +4373,11 @@ S_regmatch(pTHX_ regmatch_info *reginfo, regnode *prog)
 
                Copy(&saved_state, &PL_reg_state, 1, struct re_save_state);
 
+               /* *** Note that at this point we don't restore
+                * PL_comppad, (or pop the CxSUB) on the assumption it may
+                * be used again soon. This is safe as long as nothing
+                * in the regexp code uses the pad ! */
                PL_op = oop;
-               if (old_comppad != PL_comppad) {
-                   SAVECOMPPAD();
-                   PAD_RESTORE_LOCAL(old_comppad);
-               }
                PL_curcop = ocurcop;
                PL_regeol = saved_regeol;
                if (!logical) {
@@ -5968,6 +5988,12 @@ no_silent:
         sv_setsv(sv_mrk, sv_yes_mark);
     }
 
+
+    if (last_pushed_cv) {
+       dSP;
+       POP_MULTICALL;
+    }
+
     /* clean up; in particular, free all slabs above current one */
     LEAVE_SCOPE(oldsave);
 
index 177b5f7..20dbf06 100644 (file)
@@ -23,7 +23,7 @@ BEGIN {
 }
 
 
-plan tests => 427;  # Update this when adding/deleting tests.
+plan tests => 434;  # Update this when adding/deleting tests.
 
 run_tests() unless caller;
 
@@ -807,6 +807,51 @@ sub run_tests {
        like($w, qr/ at \(eval \d+\) line 1/, "warning eval B");
     }
 
+    # jumbo test for:
+    # * recursion;
+    # * mixing all the different types of blocks (literal, qr/literal/,
+    #   runtime);
+    # * backtracking (the Z+ alternation ensures CURLYX and full
+    #   scope popping on backtracking)
+
+    {
+        sub recurse2 {
+            my ($depth)= @_;
+           return unless $depth;
+            my $s1 = '3-LMN';
+            my $r1 = qr/(??{"$s1-$depth"})/;
+
+           my $s2 = '4-PQR';
+            my $c1 = '(??{"$s2-$depth"})';
+            use re 'eval';
+           ok(   "<12345-ABC-$depth-123-LMN-$depth-1234-PQR-$depth>"
+               . "<12345-ABC-$depth-123-LMN-$depth-1234-PQR-$depth>"
+               =~
+                 /^<(\d|Z+)+(??{"45-ABC-$depth-"})(\d|Z+)+$r1-\d+$c1>
+                   <(\d|Z+)+(??{"45-ABC-$depth-"})(\d|Z+)+$r1-\d+$c1>$/x,
+               "recurse2($depth)");
+           recurse2($depth-1);
+       }
+       recurse2(5);
+    }
+
+    # make sure that errors during compiling run-time code get trapped
+
+    {
+       use re 'eval';
+
+       my $code = '(?{$x=})';
+       eval { "a" =~ /^a$code/ };
+       like($@, qr/syntax error at \(eval \d+\) line \d+/, 'syntax error');
+
+       $code = '(?{BEGIN{die})';
+       eval { "a" =~ /^a$code/ };
+       like($@,
+           qr/BEGIN failed--compilation aborted at \(eval \d+\) line \d+/,
+           'syntax error');
+    }
+
+
 } # End of sub run_tests
 
 1;
index 5873a3d..e1b2a80 100644 (file)
@@ -9,13 +9,7 @@ BEGIN {
     skip_all_if_miniperl("no dynamic loading on miniperl, no re");
 }
 
-plan 18;
-
-# Functions for turning to-do-ness on and off (as there are so many
-# to-do tests) 
-sub on { $::TODO = "(?{}) implementation is screwy" }
-sub off { undef $::TODO }
-
+plan 29;
 
 fresh_perl_is <<'CODE', '781745', {}, '(?{}) has its own lexical scope';
  my $x = 7; my $a = 4; my $b = 5;
@@ -104,7 +98,6 @@ is $pack, 'baz', '/text$qr/ inherits package';
 "ba" =~ m+b${\do { use re "/i"; qr|(?{ $::re = qr-- })a| }}+;
 is $re, '(?^i:)', '/text$qr/ inherits pragmata';
 
-off;
 {
   use re 'eval';
   package bar;
@@ -117,38 +110,142 @@ is $pack, 'bar', '/$text/ containing (?{}) inherits package';
 }
 is $re, '(?^m:)', '/$text/ containing (?{}) inherits pragmata';
 
-on;
-
 fresh_perl_is <<'CODE', '45', { stderr => 1 }, '(?{die})';
- eval { my $a=4; my $b=5; "a" =~ /(?{die})a/ }; print $a,$b"
+my $a=4; my $b=5;  eval { "a" =~ /(?{die})a/ }; print $a,$b;
 CODE
 
-SKIP: {
-    # The remaining TODO tests crash, which will display an error dialog
-    # on Windows that has to be manually dismissed.  We don't want this
-    # to happen for release builds: 5.14.x, 5.16.x etc.
-    # On UNIX, they produce ugly 'Aborted' shell output mixed in with the
-    # test harness output, so skip on all platforms.
-    skip "Don't run crashing TODO test on release build", 3
-       if $::TODO && (int($]*1000) & 1) == 0;
+fresh_perl_is <<'CODE', 'Y45', { stderr => 1 }, '(?{eval{die}})';
+my $a=4; my $b=5;
+"a" =~ /(?{eval { die; print "X" }; print "Y"; })a/; print $a,$b;
+CODE
 
-    fresh_perl_is <<'CODE', '45', { stderr => 1 }, '(?{last})';
-     {  my $a=4; my $b=5; "a" =~ /(?{last})a/ }; print $a,$b
+fresh_perl_is <<'CODE',
+    my $a=4; my $b=5;
+    sub f { "a" =~ /(?{print((caller(0))[3], "\n");})a/ };
+    f();
+    print $a,$b;
 CODE
-    fresh_perl_is <<'CODE', '45', { stderr => 1 }, '(?{next})';
-     {  my $a=4; my $b=5; "a" =~ /(?{last})a/ }; print $a,$b
+    "main::f\n45",
+    { stderr => 1 }, 'sub f {(?{caller})}';
+
+
+fresh_perl_is <<'CODE',
+    my $a=4; my $b=5;
+    sub f { print ((caller(0))[3], "-", (caller(1))[3], "\n") };
+    "a" =~ /(?{f()})a/;
+    print $a,$b;
 CODE
-    fresh_perl_is <<'CODE', '45', { stderr => 1 }, '(?{return})';
-     print sub {  my $a=4; my $b=5; "a" =~ /(?{return $a.$b})a/ }->();
+    "main::f-(unknown)\n45",
+    { stderr => 1 }, 'sub f {caller} /(?{f()})/';
+
+
+fresh_perl_is <<'CODE',
+    my $a=4; my $b=5;
+    sub f {
+       "a" =~ /(?{print "X"; return; print "Y"; })a/;
+       print "Z";
+    };
+    f();
+    print $a,$b;
 CODE
-}
+    "XZ45",
+    { stderr => 1 }, 'sub f {(?{return})}';
+
+
+fresh_perl_is <<'CODE',
+my $a=4; my $b=5; "a" =~ /(?{last})a/; print $a,$b
+CODE
+    q{Can't "last" outside a loop block at - line 1.},
+    { stderr => 1 }, '(?{last})';
+
+
+fresh_perl_is <<'CODE',
+my $a=4; my $b=5; "a" =~ /(?{for (1..4) {last}})a/; print $a,$b
+CODE
+    '45',
+    { stderr => 1 }, '(?{for {last}})';
+
 
-fresh_perl_is <<'CODE', '45', { stderr => 1 }, '(?{goto})';
-  my $a=4; my $b=5; "a" =~ /(?{goto _})a/; die; _: print $a,$b
+fresh_perl_is <<'CODE',
+for (1) {  my $a=4; my $b=5; "a" =~ /(?{last})a/ }; print $a,$b
 CODE
+    q{Can't "last" outside a loop block at - line 1.},
+    { stderr => 1 }, 'for (1) {(?{last})}';
+
+
+fresh_perl_is <<'CODE',
+my $a=4; my $b=5; eval { "a" =~ /(?{last})a/ }; print $a,$b
+CODE
+    '45',
+    { stderr => 1 }, 'eval {(?{last})}';
+
+
+fresh_perl_is <<'CODE',
+my $a=4; my $b=5; "a" =~ /(?{next})a/; print $a,$b
+CODE
+    q{Can't "next" outside a loop block at - line 1.},
+    { stderr => 1 }, '(?{next})';
+
+
+fresh_perl_is <<'CODE',
+my $a=4; my $b=5; "a" =~ /(?{for (1,2,3) { next} })a/; print $a,$b
+CODE
+    '45',
+    { stderr => 1 }, '(?{for {next}})';
+
+
+fresh_perl_is <<'CODE',
+for (1) {  my $a=4; my $b=5; "a" =~ /(?{next})a/ }; print $a,$b
+CODE
+    q{Can't "next" outside a loop block at - line 1.},
+    { stderr => 1 }, 'for (1) {(?{next})}';
+
+
+fresh_perl_is <<'CODE',
+my $a=4; my $b=5; eval { "a" =~ /(?{next})a/ }; print $a,$b
+CODE
+    '45',
+    { stderr => 1 }, 'eval {(?{next})}';
+
+
+fresh_perl_is <<'CODE',
+my $a=4; my $b=5;
+"a" =~ /(?{ goto FOO; print "X"; })a/;
+print "Y";
+FOO:
+print $a,$b
+CODE
+    q{Can't "goto" out of a pseudo block at - line 2.},
+    { stderr => 1 }, '{(?{goto})}';
+
+
+{
+    local $::TODO = "goto doesn't yet work in pseduo blocks";
+fresh_perl_is <<'CODE',
+my $a=4; my $b=5;
+"a" =~ /(?{ goto FOO; print "X"; FOO: print "Y"; })a/;
+print "Z";
+FOO;
+print $a,$b
+CODE
+    "YZ45",
+    { stderr => 1 }, '{(?{goto FOO; FOO:})}';
+}
 
-off;
 
 # [perl #92256]
 { my $y = "a"; $y =~ /a(?{ undef *_ })/ }
 pass "undef *_ in a re-eval does not cause a double free";
+
+# make sure regexp warnings are reported on the right line
+# (we don't care what warning; the 32768 limit is just one
+# that was easy to reproduce) */
+{
+    use warnings;
+    my $w;
+    local $SIG{__WARN__} = sub { $w = "@_" };
+    my $qr = qr/(??{'a'})/;
+    my $filler = 1;
+    ("a" x 40_000) =~ /^$qr(ab*)+/; my $line = __LINE__;
+    like($w, qr/recursion limit.* line $line\b/, "warning on right line");
+}