This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
ensure regex evals report the right location
authorDavid Mitchell <davem@iabyn.com>
Fri, 30 Mar 2012 15:30:26 +0000 (16:30 +0100)
committerDavid Mitchell <davem@iabyn.com>
Wed, 13 Jun 2012 12:32:50 +0000 (13:32 +0100)
make sure that PL_curcop is set correctly on entry to a regex code block,
since (unlike a normal eval) there isn't always an initial OP_NEXTSTATE to
cause it to get set.  Otherwise, warning messages etc in the first
statement of the code block will appear to come from the wrong place.

regcomp.c
regexec.c
t/re/pat_re_eval.t

index f3052de..b9f9e41 100644 (file)
--- a/regcomp.c
+++ b/regcomp.c
@@ -8604,12 +8604,12 @@ S_reg(pTHX_ RExC_state_t *pRExC_state, I32 paren, I32 *flagp,U32 depth)
                        n = add_data(pRExC_state, 2, "rl");
                        RExC_rxi->data->data[n] =
                            (void*)SvREFCNT_inc((SV*)cb->src_regex);
                        n = add_data(pRExC_state, 2, "rl");
                        RExC_rxi->data->data[n] =
                            (void*)SvREFCNT_inc((SV*)cb->src_regex);
-                       RExC_rxi->data->data[n+1] = (void*)o->op_next;
+                       RExC_rxi->data->data[n+1] = (void*)o;
                    }
                    else {
                        n = add_data(pRExC_state, 1,
                               (RExC_pm_flags & PMf_HAS_CV) ? "L" : "l");
                    }
                    else {
                        n = add_data(pRExC_state, 1,
                               (RExC_pm_flags & PMf_HAS_CV) ? "L" : "l");
-                       RExC_rxi->data->data[n] = (void*)o->op_next;
+                       RExC_rxi->data->data[n] = (void*)o;
                    }
                }
                pRExC_state->code_index++;
                    }
                }
                pRExC_state->code_index++;
index f94d15a..21bbf76 100644 (file)
--- a/regexec.c
+++ b/regexec.c
@@ -4290,6 +4290,38 @@ S_regmatch(pTHX_ regmatch_info *reginfo, regnode *prog)
                    new_comppad =  (PAD*)AvARRAY(CvPADLIST(rex->qr_anoncv))[1];
                    PL_op = (OP_4tree*)rexi->data->data[n];
                }
                    new_comppad =  (PAD*)AvARRAY(CvPADLIST(rex->qr_anoncv))[1];
                    PL_op = (OP_4tree*)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;
+                   assert(o->op_type == OP_NULL);
+                   if (o->op_targ == OP_SCOPE) {
+                       o = cUNOPo->op_first;
+                   }
+                   else {
+                       assert(o->op_targ == OP_LEAVE);
+                       o = cUNOPo->op_first;
+                       assert(o->op_type == OP_ENTER);
+                       o = o->op_sibling;
+                   }
+
+                   if (o->op_type != OP_STUB) {
+                       assert(    o->op_type == OP_NEXTSTATE
+                               || o->op_type == OP_DBSTATE
+                               || (o->op_type == OP_NULL
+                                   &&  (  o->op_targ == OP_NEXTSTATE
+                                       || o->op_targ == OP_DBSTATE
+                                       )
+                                   )
+                       );
+                       PL_curcop = (COP*)o;
+                   }
+               }
+               PL_op = PL_op->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
                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
index 0e116b1..ecde318 100644 (file)
@@ -23,7 +23,7 @@ BEGIN {
 }
 
 
 }
 
 
-plan tests => 352;  # Update this when adding/deleting tests.
+plan tests => 355;  # Update this when adding/deleting tests.
 
 run_tests() unless caller;
 
 
 run_tests() unless caller;
 
@@ -732,6 +732,37 @@ sub run_tests {
        ok("a{" =~ /^${\'(??{"a{"})'}$/, "runtime code with unbalanced {}");
     }
 
        ok("a{" =~ /^${\'(??{"a{"})'}$/, "runtime code with unbalanced {}");
     }
 
+    # make sure warnings come from the right place
+
+    {
+       use warnings;
+       my ($s, $t, $w);
+       local $SIG{__WARN__} = sub { $w .= "@_" };
+
+       $w = ''; $s = 's';
+       my $r = qr/(?{$t=$s+1})/;
+       "a" =~ /a$r/;
+       like($w, qr/pat_re_eval/, "warning main file");
+
+       # do it in an eval to get predictable line numbers
+       eval q[
+
+           $r = qr/(?{$t=$s+1})/;
+       ];
+       $w = ''; $s = 's';
+       "a" =~ /a$r/;
+       like($w, qr/ at \(eval \d+\) line 3/, "warning eval A");
+
+       $w = ''; $s = 's';
+       eval q[
+           use re 'eval';
+           my $c = '(?{$t=$s+1})';
+           "a" =~ /a$c/;
+           1;
+       ];
+       like($w, qr/ at \(eval \d+\) line 1/, "warning eval B");
+    }
+
 } # End of sub run_tests
 
 1;
 } # End of sub run_tests
 
 1;