This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Move bulk of pp_regcomp() into re_op_compile()
authorDavid Mitchell <davem@iabyn.com>
Fri, 4 Nov 2011 10:12:20 +0000 (10:12 +0000)
committerDavid Mitchell <davem@iabyn.com>
Wed, 13 Jun 2012 12:25:52 +0000 (13:25 +0100)
When called, pp_regcomp() is presented with a list of SVs on the stack.
Previously, it would perform (amongst other things):
  * overloading those SVs;
  * concatenating them;
  * detection of bare /$qr/;
  * detection of unchanged pattern;
optionally followed by a call to the built-in or an external regexp
compiler.

Since we want to avoid premature concatenation (so that we can handle
/$runtime(?{...})/), move all these activities from pp_regcomp() into
re_op_compile().

This makes re_op_compile() a bit cumbersome, with a large arg list,
but I haven't found any way of only moving only a subset of the above.

Note that a side-effect of this is that qr-overloading now works for all
regex compilations, not just those reached via pp_regcomp(); in particular
this now invokes the qr method rather than the "" method if available:
/(??{ $overloaded_object })/

embed.fnc
embed.h
lib/overload.t
op.c
pp_ctl.c
proto.h
regcomp.c

index 128cc68..0fe55c6 100644 (file)
--- a/embed.fnc
+++ b/embed.fnc
@@ -1058,8 +1058,11 @@ Ap       |void*  |regdupe_internal|NN REGEXP * const r|NN CLONE_PARAMS* param
 #endif
 p      |regexp_engine*|current_re_engine
 Ap     |REGEXP*|pregcomp       |NN SV * const pattern|const U32 flags
-p      |REGEXP*|re_op_compile  |NULLOK SV * const * const patternp \
-                               |int pat_count|NULLOK OP *expr|U32 flags
+p      |REGEXP*|re_op_compile  |NULLOK SV ** const patternp \
+                               |int pat_count|NULLOK OP *expr \
+                               |NULLOK const regexp_engine* eng \
+                               |NULLOK REGEXP *old_re|NULLOK int *is_bare_re \
+                               |U32 flags
 Ap     |REGEXP*|re_compile     |NN SV * const pattern|U32 flags
 Ap     |char*  |re_intuit_start|NN REGEXP * const rx|NULLOK SV* sv|NN char* strpos \
                                |NN char* strend|const U32 flags \
diff --git a/embed.h b/embed.h
index 7dea742..f85d44c 100644 (file)
--- a/embed.h
+++ b/embed.h
 #define parser_free(a)         Perl_parser_free(aTHX_ a)
 #define peep(a)                        Perl_peep(aTHX_ a)
 #define pmruntime(a,b,c,d)     Perl_pmruntime(aTHX_ a,b,c,d)
-#define re_op_compile(a,b,c,d) Perl_re_op_compile(aTHX_ a,b,c,d)
+#define re_op_compile(a,b,c,d,e,f,g)   Perl_re_op_compile(aTHX_ a,b,c,d,e,f,g)
 #define refcounted_he_chain_2hv(a,b)   Perl_refcounted_he_chain_2hv(aTHX_ a,b)
 #define refcounted_he_fetch_pv(a,b,c,d)        Perl_refcounted_he_fetch_pv(aTHX_ a,b,c,d)
 #define refcounted_he_fetch_pvn(a,b,c,d,e)     Perl_refcounted_he_fetch_pvn(aTHX_ a,b,c,d,e)
index 16a7486..d5c1833 100644 (file)
@@ -48,7 +48,7 @@ package main;
 
 $| = 1;
 BEGIN { require './test.pl' }
-plan tests => 5049;
+plan tests => 5055;
 
 use Scalar::Util qw(tainted);
 
@@ -1188,17 +1188,26 @@ foreach my $op (qw(<=> == != < <= > >=)) {
         # doesn't look like a regex
         ok("x" =~ $x, "qr-only matches");
         ok("y" !~ $x, "qr-only doesn't match what it shouldn't");
+        ok("x" =~ /^(??{$x})$/, "qr-only with ?? matches");
+        ok("y" !~ /^(??{$x})$/, "qr-only with ?? doesn't match what it shouldn't");
         ok("xx" =~ /x$x/, "qr-only matches with concat");
         like("$x", qr/^QRonly=ARRAY/, "qr-only doesn't have string overload");
 
         my $qr = bless qr/y/, "QRonly";
         ok("x" =~ $qr, "qr with qr-overload uses overload");
         ok("y" !~ $qr, "qr with qr-overload uses overload");
+       {
+           local $::TODO = '?? fails with "qr with qr"' ;
+           ok("x" =~ /^(??{$qr})$/, "qr with qr-overload with ?? uses overload");
+           ok("y" !~ /^(??{$qr})$/, "qr with qr-overload with ?? uses overload");
+       }
         is("$qr", "".qr/y/, "qr with qr-overload stringify");
 
         my $rx = $$qr;
         ok("y" =~ $rx, "bare rx with qr-overload doesn't overload match");
         ok("x" !~ $rx, "bare rx with qr-overload doesn't overload match");
+        ok("y" =~ /^(??{$rx})$/, "bare rx with qr-overload with ?? doesn't overload match");
+        ok("x" !~ /^(??{$rx})$/, "bare rx with qr-overload with ?? doesn't overload match");
         is("$rx", "".qr/y/, "bare rx with qr-overload stringify");
     }
     {
diff --git a/op.c b/op.c
index c735d96..44fc40b 100644 (file)
--- a/op.c
+++ b/op.c
@@ -4427,7 +4427,8 @@ Perl_pmruntime(pTHX_ OP *o, OP *expr, bool isreg, I32 floor)
        }
        else {
            /* compile-time pattern that includes literal code blocks */
-           REGEXP* re = re_op_compile(NULL, 0, expr, pm_flags);
+           REGEXP* re =
+                   re_op_compile(NULL, 0, expr, NULL, NULL, NULL, pm_flags);
            PM_SETRE(pm, re);
            if (pm->op_pmflags & PMf_HAS_CV) {
                CV *cv;
index a9df7b0..a82dcbb 100644 (file)
--- a/pp_ctl.c
+++ b/pp_ctl.c
@@ -81,10 +81,12 @@ PP(pp_regcomp)
     dVAR;
     dSP;
     register PMOP *pm = (PMOP*)cLOGOP->op_other;
-    SV **args, **svp;
+    SV **args;
     int nargs;
-    SV *tmpstr;
     REGEXP *re = NULL;
+    REGEXP *new_re;
+    const regexp_engine *eng;
+    int is_bare_re;
 
     if (PL_op->op_flags & OPf_STACKED) {
        dMARK;
@@ -104,160 +106,72 @@ PP(pp_regcomp)
     }
 #endif
 
-    /* apply magic and RE overloading to each arg */
-
-    for (svp = args; svp <= SP; svp++) {
-       SV *rx = *svp;
-       SvGETMAGIC(rx);
-       if (SvROK(rx) && SvAMAGIC(rx)) {
-           SV *sv = AMG_CALLunary(rx, regexp_amg);
-           if (sv) {
-               if (SvROK(sv))
-                   sv = SvRV(sv);
-               if (SvTYPE(sv) != SVt_REGEXP)
-                   Perl_croak(aTHX_ "Overloaded qr did not return a REGEXP");
-               *svp = sv;
-           }
-       }
-    }
-
-    if (nargs == 1) {
-       tmpstr = *args;
-       /* maybe foo =~ $re ? */
-       if (SvROK(tmpstr)) {
-           SV * const sv = SvRV(tmpstr);
-           if (SvTYPE(sv) == SVt_REGEXP)
-               re = (REGEXP*) sv;
-       }
-       else if (SvTYPE(tmpstr) == SVt_REGEXP)
-           re = (REGEXP*) tmpstr;
-    }
-
-    if (re) {
-       /* The match's LHS's get-magic might need to access this op's reg-
-          exp (as is sometimes the case with $';  see bug 70764).  So we
-          must call get-magic now before we replace the regexp. Hopeful-
-          ly this hack can be replaced with the approach described at
-          http://www.nntp.perl.org/group/perl.perl5.porters/2007/03
-          /msg122415.html some day. */
-       if(pm->op_type == OP_MATCH) {
-        SV *lhs;
-        const bool was_tainted = PL_tainted;
-        if (pm->op_flags & OPf_STACKED)
-           lhs = args[-1];
-        else if (pm->op_private & OPpTARGET_MY)
-           lhs = PAD_SV(pm->op_targ);
-        else lhs = DEFSV;
-        SvGETMAGIC(lhs);
-        /* Restore the previous value of PL_tainted (which may have been
-           modified by get-magic), to avoid incorrectly setting the
-           RXf_TAINTED flag further down. */
-        PL_tainted = was_tainted;
+    re = PM_GETRE(pm);
+    assert (re != (REGEXP*) &PL_sv_undef);
+    eng = re ? RX_ENGINE(re) : current_re_engine();
+
+    if (PL_op->op_flags & OPf_SPECIAL)
+       PL_reginterp_cnt = (I32_MAX>>1); /* Mark as safe.  */
+
+    new_re = re_op_compile(args, nargs, pm->op_code_list, eng, re,
+               &is_bare_re, (pm->op_pmflags & RXf_PMf_COMPILETIME));
+
+    if (is_bare_re) {
+       REGEXP *tmp;
+       /* The match's LHS's get-magic might need to access this op's regexp
+          (e.g. $' =~ /$re/ while foo; see bug 70764).  So we must call
+          get-magic now before we replace the regexp. Hopefully this hack can
+          be replaced with the approach described at
+          http://www.nntp.perl.org/group/perl.perl5.porters/2007/03/msg122415.html
+          some day. */
+       if (pm->op_type == OP_MATCH) {
+           SV *lhs;
+           const bool was_tainted = PL_tainted;
+           if (pm->op_flags & OPf_STACKED)
+               lhs = args[-1];
+           else if (pm->op_private & OPpTARGET_MY)
+               lhs = PAD_SV(pm->op_targ);
+           else lhs = DEFSV;
+           SvGETMAGIC(lhs);
+           /* Restore the previous value of PL_tainted (which may have been
+              modified by get-magic), to avoid incorrectly setting the
+              RXf_TAINTED flag further down. */
+           PL_tainted = was_tainted;
        }
-
-       re = reg_temp_copy(NULL, re);
-       ReREFCNT_dec(PM_GETRE(pm));
-       PM_SETRE(pm, re);
+       tmp = reg_temp_copy(NULL, new_re);
+       ReREFCNT_dec(new_re);
+       new_re = tmp;
     }
-    else {
-       STRLEN len = 0;
-       const char *t;
-
-       /* concat multiple args */
-
-       if (nargs > 1) {
-           tmpstr = PAD_SV(ARGTARG);
-           sv_setpvs(tmpstr, "");
-           svp = args-1;
-           while (++svp <= SP) {
-               SV *msv = *svp;
-               SV *sv;
-
-               if ((SvAMAGIC(tmpstr) || SvAMAGIC(msv)) &&
-                   (sv = amagic_call(tmpstr, msv, concat_amg, AMGf_assign)))
-               {
-                  sv_setsv(tmpstr, sv);
-                  continue;
-               }
-               sv_catsv_nomg(tmpstr, msv);
-           }
-           SvSETMAGIC(tmpstr);
-       }
-       else
-           tmpstr = *args;
-
-       t = SvOK(tmpstr) ? SvPV_nomg_const(tmpstr, len) : "";
-       re = PM_GETRE(pm);
-       assert (re != (REGEXP*) &PL_sv_undef);
-
-       /* Check against the last compiled regexp. */
-       if (!re || !RX_PRECOMP(re) || RX_PRELEN(re) != len ||
-           memNE(RX_PRECOMP(re), t, len))
-       {
-           const regexp_engine *eng;
-            U32 pm_flags = pm->op_pmflags & RXf_PMf_COMPILETIME;
-
-           if (re) {
-               eng = RX_ENGINE(re);
-               ReREFCNT_dec(re);
-#ifdef USE_ITHREADS
-               PM_SETRE(pm, (REGEXP*) &PL_sv_undef);
-#else
-               PM_SETRE(pm, NULL);     /* crucial if regcomp aborts */
-#endif
-           }
-           else
-               eng = current_re_engine();
-
-           if (PL_op->op_flags & OPf_SPECIAL)
-               PL_reginterp_cnt = I32_MAX; /* Mark as safe.  */
-
-           if ((SvUTF8(tmpstr) && IN_BYTES)
-                   || SvGMAGICAL(tmpstr) || SvAMAGIC(tmpstr))
-           {
-               /* make a temporary copy; either to avoid repeating
-                * get-magic, or overloaded stringify, or to convert to bytes */
-               tmpstr = newSVpvn_flags(t, len, SVs_TEMP |
-                                           (IN_BYTES ? 0 : SvUTF8(tmpstr)));
-           }
-
-           if (eng)
-               PM_SETRE(pm, CALLREGCOMP_ENG(eng, tmpstr, pm_flags));
-           else
-               PM_SETRE(pm, CALLREGCOMP(tmpstr, pm_flags));
-
-           PL_reginterp_cnt = 0;       /* XXXX Be extra paranoid - needed
-                                          inside tie/overload accessors.  */
-       }
+    if (re != new_re) {
+       ReREFCNT_dec(re);
+       PM_SETRE(pm, new_re);
     }
-    
-    re = PM_GETRE(pm);
 
+    PL_reginterp_cnt = 0;      /* XXXX Be extra paranoid - needed
+                                  inside tie/overload accessors.  */
 #ifndef INCOMPLETE_TAINTS
-    if (PL_tainting) {
-       if (PL_tainted) {
-           SvTAINTED_on((SV*)re);
-           RX_EXTFLAGS(re) |= RXf_TAINTED;
-       }
+    if (PL_tainting && PL_tainted) {
+       SvTAINTED_on((SV*)new_re);
+       RX_EXTFLAGS(new_re) |= RXf_TAINTED;
     }
 #endif
 
-    if (!RX_PRELEN(PM_GETRE(pm)) && PL_curpm)
-       pm = PL_curpm;
-
-
 #if !defined(USE_ITHREADS)
     /* can't change the optree at runtime either */
     /* PMf_KEEP is handled differently under threads to avoid these problems */
+    if (!RX_PRELEN(PM_GETRE(pm)) && PL_curpm)
+       pm = PL_curpm;
     if (pm->op_pmflags & PMf_KEEP) {
        pm->op_private &= ~OPpRUNTIME;  /* no point compiling again */
        cLOGOP->op_first->op_next = PL_op->op_next;
     }
 #endif
+
     SP = args-1;
     RETURN;
 }
 
+
 PP(pp_substcont)
 {
     dVAR;
diff --git a/proto.h b/proto.h
index fef000f..ccab428 100644 (file)
--- a/proto.h
+++ b/proto.h
@@ -3150,7 +3150,7 @@ PERL_CALLCONV SV* Perl_re_intuit_string(pTHX_ REGEXP  *const r)
 #define PERL_ARGS_ASSERT_RE_INTUIT_STRING      \
        assert(r)
 
-PERL_CALLCONV REGEXP*  Perl_re_op_compile(pTHX_ SV * const * const patternp, int pat_count, OP *expr, U32 flags);
+PERL_CALLCONV REGEXP*  Perl_re_op_compile(pTHX_ SV ** const patternp, int pat_count, OP *expr, const regexp_engine* eng, REGEXP *old_re, int *is_bare_re, U32 flags);
 PERL_CALLCONV Malloc_t Perl_realloc(Malloc_t where, MEM_SIZE nbytes)
                        __attribute__malloc__
                        __attribute__warn_unused_result__;
index 2af85f0..11fc0e0 100644 (file)
--- a/regcomp.c
+++ b/regcomp.c
@@ -4964,8 +4964,10 @@ Perl_pregcomp(pTHX_ SV * const pattern, const U32 flags)
 REGEXP *
 Perl_re_compile(pTHX_ SV * const pattern, U32 orig_pm_flags)
 {
+    SV *pat = pattern; /* defeat constness! */
     PERL_ARGS_ASSERT_RE_COMPILE;
-    return Perl_re_op_compile(aTHX_ &pattern, 1, NULL, orig_pm_flags);
+    return Perl_re_op_compile(aTHX_ &pat, 1, NULL,
+                                   NULL, NULL, NULL, orig_pm_flags);
 }
 
 /* given a list of CONSTs and DO blocks in expr, append all the CONSTs to
@@ -5003,6 +5005,23 @@ S_get_pat_and_code_indices(pTHX_ RExC_state_t *pRExC_state, OP* expr, SV* pat) {
  * The pattern may be passed either as:
  *    a list of SVs (patternp plus pat_count)
  *    a list of OPs (expr)
+ * If both are passed, the SV list is used, but the OP list indicates
+ * which SVs are actually pre-compiled codeblocks
+ *
+ * The list of SVs have magic and qr overloading applied to them (and
+ * the list may be modified in-place with replacement SVs in the latter
+ * case).
+ *
+ * If the pattern hasn't changed from old_re, then old-re will be
+ * returned.
+ *
+ * If eng is set (and  not equal to PL_core_reg_engine), then
+ * just do the intial concatenation of arguments, then pass on to
+ * the external engine.
+ *
+ * If is_bare_re is not null, set it to a boolean indicating whether
+ * the the arg list reduced (after overloading) to a single bare
+ * regex which has been returned (i.e. /$qr/).
  *
  * We can't allocate space until we know how big the compiled form will be,
  * but we can't compile it (and thus know how big it is) until we've got a
@@ -5018,8 +5037,9 @@ S_get_pat_and_code_indices(pTHX_ RExC_state_t *pRExC_state, OP* expr, SV* pat) {
  */
 
 REGEXP *
-Perl_re_op_compile(pTHX_ SV * const * const patternp, int pat_count,
-                   OP *expr, U32 orig_pm_flags)
+Perl_re_op_compile(pTHX_ SV ** const patternp, int pat_count,
+                   OP *expr, const regexp_engine* eng, REGEXP *old_re,
+                    int *is_bare_re, U32 orig_pm_flags)
 {
     dVAR;
     REGEXP *rx;
@@ -5115,7 +5135,64 @@ Perl_re_op_compile(pTHX_ SV * const * const patternp, int pat_count,
 
     pRExC_state->code_indices = NULL;
     pRExC_state->max_code_index = 0;
-    if (expr) {
+
+    if (is_bare_re)
+       *is_bare_re = 0;
+
+    if (pat_count) {
+       /* handle a list of SVs */
+
+       SV **svp;
+
+       /* apply magic and RE overloading to each arg */
+       for (svp = patternp; svp < patternp + pat_count; svp++) {
+           SV *rx = *svp;
+           SvGETMAGIC(rx);
+           if (SvROK(rx) && SvAMAGIC(rx)) {
+               SV *sv = AMG_CALLunary(rx, regexp_amg);
+               if (sv) {
+                   if (SvROK(sv))
+                       sv = SvRV(sv);
+                   if (SvTYPE(sv) != SVt_REGEXP)
+                       Perl_croak(aTHX_ "Overloaded qr did not return a REGEXP");
+                   *svp = sv;
+               }
+           }
+       }
+
+       if (pat_count > 1) {
+           /* concat multiple args */
+           pat = newSVpvn("", 0);
+           SAVEFREESV(pat);
+           for (svp = patternp; svp < patternp + pat_count; svp++) {
+               SV *sv, *msv = *svp;
+               if ((SvAMAGIC(pat) || SvAMAGIC(msv)) &&
+                       (sv = amagic_call(pat, msv, concat_amg, AMGf_assign)))
+                   sv_setsv(pat, sv);
+               else
+                   sv_catsv_nomg(pat, msv);
+           }
+           SvSETMAGIC(pat);
+       }
+       else
+           pat = *patternp;
+
+       /* handle bare regex: foo =~ $re */
+       {
+           SV *re = pat;
+           if (SvROK(re))
+               re = SvRV(re);
+           if (SvTYPE(re) == SVt_REGEXP) {
+               if (is_bare_re)
+                   *is_bare_re = 1;
+               SvREFCNT_inc(re);
+               return (REGEXP*)re;
+           }
+       }
+    }
+    else {
+       /* not a list of SVs, so must be a list of OPs */
+       assert(expr);
        if (expr->op_type == OP_LIST) {
            OP *o;
            bool is_utf8 = 0;
@@ -5145,20 +5222,30 @@ Perl_re_op_compile(pTHX_ SV * const * const patternp, int pat_count,
            pat = cSVOPx_sv(expr);
        }
     }
-    else
-    {
-       assert(pat_count ==1); /*XXX*/
-       pat = *patternp;
-    }
 
-    exp = SvPV(pat, plen);
+    exp = SvPV_nomg(pat, plen);
 
-    if (plen == 0) { /* ignore the utf8ness if the pattern is 0 length */
-       RExC_utf8 = RExC_orig_utf8 = 0;
+    if (eng && eng != &PL_core_reg_engine) {
+       if ((SvUTF8(pat) && IN_BYTES)
+               || SvGMAGICAL(pat) || SvAMAGIC(pat))
+       {
+           /* make a temporary copy; either to convert to bytes,
+            * or to avoid repeating get-magic / overloaded stringify */
+           pat = newSVpvn_flags(exp, plen, SVs_TEMP |
+                                       (IN_BYTES ? 0 : SvUTF8(pat)));
+       }
+       return CALLREGCOMP_ENG(eng, pat, orig_pm_flags);
     }
-    else {
-       RExC_utf8 = RExC_orig_utf8 = SvUTF8(pat);
+
+    if (old_re && RX_PRECOMP(old_re) && RX_PRELEN(old_re) == plen
+          && memEQ(RX_PRECOMP(old_re), exp, plen))
+    {
+       ReREFCNT_inc(old_re);
+       return old_re;
     }
+
+    /* ignore the utf8ness if the pattern is 0 length */
+    RExC_utf8 = RExC_orig_utf8 = (plen == 0 || IN_BYTES) ? 0 : SvUTF8(pat);
     RExC_uni_semantics = 0;
     RExC_contains_locale = 0;
 
@@ -5203,7 +5290,8 @@ Perl_re_op_compile(pTHX_ SV * const * const patternp, int pat_count,
         DEBUG_PARSE_r(PerlIO_printf(Perl_debug_log,
            "UTF8 mismatch! Converting to utf8 for resizing and compile\n"));
 
-       if (expr && expr->op_type == OP_LIST) {
+       if (!pat_count) {
+           assert(expr && expr->op_type == OP_LIST);
            sv_setpvn(pat, "", 0);
            SvUTF8_on(pat);
            S_get_pat_and_code_indices(aTHX_ pRExC_state, expr, pat);
@@ -5359,7 +5447,8 @@ Perl_re_op_compile(pTHX_ SV * const * const patternp, int pat_count,
 
         p = sv_grow(MUTABLE_SV(rx), wraplen + 1); /* +1 for the ending NUL */
        SvPOK_on(rx);
-       SvFLAGS(rx) |= SvUTF8(pat);
+       if (RExC_utf8)
+           SvFLAGS(rx) |= SVf_UTF8;
         *p++='('; *p++='?';
 
         /* If a default, cover it using the caret */