This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
FETCH/STORE/LENGTH callbacks for numbered capture variables
[perl5.git] / pp_ctl.c
index f818869..85f8278 100644 (file)
--- a/pp_ctl.c
+++ b/pp_ctl.c
@@ -76,6 +76,7 @@ PP(pp_regcomp)
     register PMOP *pm = (PMOP*)cLOGOP->op_other;
     SV *tmpstr;
     MAGIC *mg = NULL;
+    regexp * re;
 
     /* prevent recompiling under /o and ithreads. */
 #if defined(USE_ITHREADS)
@@ -118,21 +119,21 @@ PP(pp_regcomp)
            mg = mg_find(sv, PERL_MAGIC_qr);
     }
     if (mg) {
-       regexp * const re = (regexp *)mg->mg_obj;
+       regexp * const re = reg_temp_copy((regexp *)mg->mg_obj);
        ReREFCNT_dec(PM_GETRE(pm));
-       PM_SETRE(pm, ReREFCNT_inc(re));
+       PM_SETRE(pm, re);
     }
     else {
        STRLEN len;
-       const char *t = SvPV_const(tmpstr, len);
-       regexp * const re = PM_GETRE(pm);
+       const char *t = SvOK(tmpstr) ? SvPV_const(tmpstr, len) : "";
+       re = PM_GETRE(pm);
 
        /* Check against the last compiled regexp. */
        if (!re || !re->precomp || re->prelen != (I32)len ||
            memNE(re->precomp, t, len))
        {
            const regexp_engine *eng = re ? re->engine : NULL;
-
+            U32 pm_flags = pm->op_pmflags & PMf_COMPILETIME;
            if (re) {
                ReREFCNT_dec(re);
                PM_SETRE(pm, NULL);     /* crucial if regcomp aborts */
@@ -146,50 +147,42 @@ PP(pp_regcomp)
            if (PL_op->op_flags & OPf_SPECIAL)
                PL_reginterp_cnt = I32_MAX; /* Mark as safe.  */
 
-           pm->op_pmflags = pm->op_pmpermflags;        /* reset case sensitivity */
            if (DO_UTF8(tmpstr))
-               pm->op_pmdynflags |= PMdf_DYN_UTF8;
-           else {
-               pm->op_pmdynflags &= ~PMdf_DYN_UTF8;
-               if (pm->op_pmdynflags & PMdf_UTF8)
-                   t = (char*)bytes_to_utf8((U8*)t, &len);
-           }
-           if (eng) 
-               PM_SETRE(pm, CALLREGCOMP_ENG(eng,(char *)t, (char *)t + len, pm));
-            else
-                PM_SETRE(pm, CALLREGCOMP((char *)t, (char *)t + len, pm));
-                
-           if (!DO_UTF8(tmpstr) && (pm->op_pmdynflags & PMdf_UTF8))
-               Safefree(t);
+               pm_flags |= RXf_UTF8;
+
+               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.  */
        }
     }
+    
+    re = PM_GETRE(pm);
 
 #ifndef INCOMPLETE_TAINTS
     if (PL_tainting) {
        if (PL_tainted)
-           pm->op_pmdynflags |= PMdf_TAINTED;
+           re->extflags |= RXf_TAINTED;
        else
-           pm->op_pmdynflags &= ~PMdf_TAINTED;
+           re->extflags &= ~RXf_TAINTED;
     }
 #endif
 
     if (!PM_GETRE(pm)->prelen && PL_curpm)
        pm = PL_curpm;
-    else if (PM_GETRE(pm)->extflags & RXf_WHITE)
-       pm->op_pmflags |= PMf_WHITE;
-    else
-       pm->op_pmflags &= ~PMf_WHITE;
 
-    /* XXX runtime compiled output needs to move to the pad */
+
+#if !defined(USE_ITHREADS)
+    /* can't change the optree at runtime either */
+    /* PMf_KEEP is handled differently under threads to avoid these problems */
     if (pm->op_pmflags & PMf_KEEP) {
        pm->op_private &= ~OPpRUNTIME;  /* no point compiling again */
-#if !defined(USE_ITHREADS)
-       /* XXX can't change the optree at runtime either */
        cLOGOP->op_first->op_next = PL_op->op_next;
-#endif
     }
+#endif
     RETURN;
 }
 
@@ -279,14 +272,14 @@ PP(pp_substcont)
        s = orig + (m - s);
        cx->sb_strend = s + (cx->sb_strend - m);
     }
-    cx->sb_m = m = rx->startp[0] + orig;
+    cx->sb_m = m = rx->offs[0].start + orig;
     if (m > s) {
        if (DO_UTF8(dstr) && !SvUTF8(cx->sb_targ))
            sv_catpvn_utf8_upgrade(dstr, s, m - s, nsv);
        else
            sv_catpvn(dstr, s, m-s);
     }
-    cx->sb_s = rx->endp[0] + orig;
+    cx->sb_s = rx->offs[0].end + orig;
     { /* Update the pos() information. */
        SV * const sv = cx->sb_targ;
        MAGIC *mg;
@@ -309,7 +302,7 @@ PP(pp_substcont)
        (void)ReREFCNT_inc(rx);
     cx->sb_rxtainted |= RX_MATCH_TAINTED(rx);
     rxres_save(&cx->sb_rxres, rx);
-    RETURNOP(pm->op_pmreplstart);
+    RETURNOP(pm->op_pmstashstartu.op_pmreplstart);
 }
 
 void
@@ -345,8 +338,8 @@ Perl_rxres_save(pTHX_ void **rsp, REGEXP *rx)
     *p++ = PTR2UV(rx->subbeg);
     *p++ = (UV)rx->sublen;
     for (i = 0; i <= rx->nparens; ++i) {
-       *p++ = (UV)rx->startp[i];
-       *p++ = (UV)rx->endp[i];
+       *p++ = (UV)rx->offs[i].start;
+       *p++ = (UV)rx->offs[i].end;
     }
 }
 
@@ -373,8 +366,8 @@ Perl_rxres_restore(pTHX_ void **rsp, REGEXP *rx)
     rx->subbeg = INT2PTR(char*,*p++);
     rx->sublen = (I32)(*p++);
     for (i = 0; i <= rx->nparens; ++i) {
-       rx->startp[i] = (I32)(*p++);
-       rx->endp[i] = (I32)(*p++);
+       rx->offs[i].start = (I32)(*p++);
+       rx->offs[i].end = (I32)(*p++);
     }
 }
 
@@ -2915,10 +2908,10 @@ S_doeval(pTHX_ int gimme, OP** startop, CV* outside, U32 seq)
     SAVESPTR(PL_unitcheckav);
     PL_unitcheckav = newAV();
     SAVEFREESV(PL_unitcheckav);
-    SAVEI32(PL_error_count);
+    SAVEI8(PL_error_count);
 
 #ifdef PERL_MAD
-    SAVEI32(PL_madskills);
+    SAVEBOOL(PL_madskills);
     PL_madskills = 0;
 #endif
 
@@ -3089,7 +3082,7 @@ PP(pp_require)
 
        sv = new_version(sv);
        if (!sv_derived_from(PL_patchlevel, "version"))
-           upg_version(PL_patchlevel);
+           upg_version(PL_patchlevel, TRUE);
        if (cUNOP->op_first->op_type == OP_CONST && cUNOP->op_first->op_private & OPpCONST_NOVER) {
            if ( vcmp(sv,PL_patchlevel) <= 0 )
                DIE(aTHX_ "Perls since %"SVf" too modern--this is %"SVf", stopped",
@@ -3104,7 +3097,7 @@ PP(pp_require)
        /* If we request a version >= 5.9.5, load feature.pm with the
         * feature bundle that corresponds to the required version.
         * We do this only with use, not require. */
-       if (PL_compcv && vcmp(sv, sv_2mortal(upg_version(newSVnv(5.009005)))) >= 0) {
+       if (PL_compcv && vcmp(sv, sv_2mortal(upg_version(newSVnv(5.009005), FALSE))) >= 0) {
            SV *const importsv = vnormal(sv);
            *SvPVX_mutable(importsv) = ':';
            ENTER;
@@ -3283,7 +3276,7 @@ PP(pp_require)
                        || (*name == ':' && name[1] != ':' && strchr(name+2, ':'))
 #endif
                  ) {
-                   const char *dir = SvPVx_nolen_const(dirsv);
+                   const char *dir = SvPV_nolen_const(dirsv);
 #ifdef MACOS_TRADITIONAL
                    char buf1[256];
                    char buf2[256];
@@ -3511,7 +3504,7 @@ PP(pp_entereval)
     /* prepare to compile string */
 
     if (PERLDB_LINE && PL_curstash != PL_debstash)
-       save_lines(CopFILEAV(&PL_compiling), PL_linestr);
+       save_lines(CopFILEAV(&PL_compiling), PL_parser->linestr);
     PUTBACK;
     ret = doeval(gimme, NULL, runcv, seq);
     if (PERLDB_INTER && was != (I32)PL_sub_generation /* Some subs defined here. */
@@ -3737,8 +3730,7 @@ PP(pp_leavegiven)
 }
 
 /* Helper routines used by pp_smartmatch */
-STATIC
-PMOP *
+STATIC PMOP *
 S_make_matcher(pTHX_ regexp *re)
 {
     dVAR;
@@ -3751,8 +3743,7 @@ S_make_matcher(pTHX_ regexp *re)
     return matcher;
 }
 
-STATIC
-bool
+STATIC bool
 S_matcher_matches_sv(pTHX_ PMOP *matcher, SV *sv)
 {
     dVAR;
@@ -3766,8 +3757,7 @@ S_matcher_matches_sv(pTHX_ PMOP *matcher, SV *sv)
     return (SvTRUEx(POPs));
 }
 
-STATIC
-void
+STATIC void
 S_destroy_matcher(pTHX_ PMOP *matcher)
 {
     dVAR;
@@ -3785,8 +3775,7 @@ PP(pp_smartmatch)
 /* This version of do_smartmatch() implements the
  * table of smart matches that is found in perlsyn.
  */
-STATIC
-OP *
+STATIC OP *
 S_do_smartmatch(pTHX_ HV *seen_this, HV *seen_other)
 {
     dVAR;