This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
handle weird/undef (?{}), (??{}) return value
authorDavid Mitchell <davem@iabyn.com>
Mon, 4 Jun 2012 12:24:23 +0000 (13:24 +0100)
committerDavid Mitchell <davem@iabyn.com>
Wed, 13 Jun 2012 12:32:55 +0000 (13:32 +0100)
All three code block variants: (?{}), (??{}), (?(?{}X|Y)),
make use of the return value of the block, either to set $^R, determine
truth, or to interpret as a pattern.  Evaluating this value may trigger
magic calls, uninitialized var warnings etc. Make sure that this
processing happens in the right environment; specifically, before we've
restored vars and paren indices, and we set PL_op temporarily to NULL so
that uninit var warnings don't try to look in the wrong place: neither the
outer op (eg OP_MATCH) nor the inner op (the last op of the code block:
currently happens to be OP_NULL, but that's a bug; will eventually be last
*real* op, e.g. padsv) are suitable for identifying where the warning came
from.

For the (??{}) case, if we can't extract a pre-compiled regex from it,
we force it to a PV, making a temp copy if necessary.

regexec.c
t/re/pat_re_eval.t

index 1ae61c3..9c4b53d 100644 (file)
--- a/regexec.c
+++ b/regexec.c
@@ -4404,6 +4404,40 @@ S_regmatch(pTHX_ regmatch_info *reginfo, regnode *prog)
                    PUTBACK;
                }
 
+               /* before restoring everything, evaluate the returned
+                * value, so that 'uninit' warnings don't use the wrong
+                * PL_op or pad. Also need to process any magic vars (e.g.
+                * $1 *before* parentheses are restored */
+
+               PL_op = NULL;
+
+               if (logical == 0)        /*   (?{})/   */
+                   sv_setsv(save_scalar(PL_replgv), ret); /* $^R */
+               else if (logical == 1) { /*   /(?(?{...})X|Y)/    */
+                   sw = cBOOL(SvTRUE(ret));
+                   logical = 0;
+               }
+               else {                   /*  /(??{})  */
+                   SV *sv = ret;
+                   re_sv = NULL;
+                   if (SvROK(sv))
+                       sv = SvRV(sv);
+                   if (SvTYPE(sv) == SVt_REGEXP)
+                       re_sv = (REGEXP*) sv;
+                   else if (SvSMAGICAL(sv)) {
+                       MAGIC *mg = mg_find(sv, PERL_MAGIC_qr);
+                       if (mg)
+                           re_sv = (REGEXP *) mg->mg_obj;
+                   }
+
+                   /* force any magic, undef warnings here */
+                   if (!re_sv && !SvAMAGIC(ret)) {
+                       ret = sv_mortalcopy(ret);
+                       (void) SvPV_force_nolen(ret);
+                   }
+
+               }
+
                Copy(&saved_state, &PL_reg_state, 1, struct re_save_state);
 
                /* *** Note that at this point we don't restore
@@ -4413,36 +4447,18 @@ S_regmatch(pTHX_ regmatch_info *reginfo, regnode *prog)
                PL_op = oop;
                PL_curcop = ocurcop;
                PL_regeol = saved_regeol;
-               if (!logical) {
-                   /* /(?{...})/ */
-                   /* restore all paren positions. Note that where the
-                    * return value is used, we must delay this as the
-                    * returned string to be compiled may be $1 for
-                    * example */
-                   S_regcp_restore(aTHX_ rex, runops_cp);
-                   sv_setsv(save_scalar(PL_replgv), ret);
+               S_regcp_restore(aTHX_ rex, runops_cp);
+
+               if (logical != 2)
                    break;
-               }
            }
-           if (logical == 2) { /* Postponed subexpression: /(??{...})/ */
+
+               /* only /(??{})/  from now on */
                logical = 0;
                {
                    /* extract RE object from returned value; compiling if
                     * necessary */
 
-                   re_sv = NULL;
-                   {
-                       SV *sv = ret;
-                       if (SvROK(sv))
-                           sv = SvRV(sv);
-                       if (SvTYPE(sv) == SVt_REGEXP) {
-                           re_sv = (REGEXP*) sv;
-                       } else if (SvSMAGICAL(sv)) {
-                           MAGIC *mg = mg_find(sv, PERL_MAGIC_qr);
-                           if (mg)
-                               re_sv = (REGEXP *) mg->mg_obj;
-                       }
-                   }
                    if (re_sv) {
                        re_sv = reg_temp_copy(NULL, re_sv);
                    }
@@ -4527,12 +4543,6 @@ S_regmatch(pTHX_ regmatch_info *reginfo, regnode *prog)
                /* now continue from first node in postoned RE */
                PUSH_YES_STATE_GOTO(EVAL_AB, startpoint);
                /* NOTREACHED */
-           }
-           /* logical is 1,   /(?(?{...})X|Y)/ */
-           sw = cBOOL(SvTRUE(ret));
-           S_regcp_restore(aTHX_ rex, runops_cp);
-           logical = 0;
-           break;
        }
 
        case EVAL_AB: /* cleanup after a successful (??{A})B */
index 89628ae..f158f85 100644 (file)
@@ -23,7 +23,7 @@ BEGIN {
 }
 
 
-plan tests => 447;  # Update this when adding/deleting tests.
+plan tests => 448;  # Update this when adding/deleting tests.
 
 run_tests() unless caller;
 
@@ -955,6 +955,18 @@ sub run_tests {
        ok("a" !~ /^(a)(??{ \$1 })/, '(??{ ref })');
     }
 
+    # make sure the uninit warning from returning an undef var
+    # sees the right var
+
+    {
+       my ($u1, $u2);
+       my $warn = '';
+       local $SIG{__WARN__} = sub {  $warn .= $_[0] };
+       $u1 =~ /(??{$u2})/ or die;
+       like($warn, qr/value \$u1 in pattern match.*\n.*value at/, 'uninit');
+    }
+
+
 
 } # End of sub run_tests