Re: Named-capture regex syntax

[p5sagit/p5-mst-13.2.git] / pp_ctl.c

diff --git a/pp_ctl.c b/pp_ctl.c
index cda9811..36f0963 100644 (file)
--- a/pp_ctl.c
+++ b/pp_ctl.c
@@ -131,10 +131,18 @@ PP(pp_regcomp)
        if (!re || !re->precomp || re->prelen != (I32)len ||
            memNE(re->precomp, t, len))
        {
+           const regexp_engine *eng = re ? re->engine : NULL;
+
            if (re) {
                ReREFCNT_dec(re);
                PM_SETRE(pm, NULL);     /* crucial if regcomp aborts */
+           } else if (PL_curcop->cop_hints_hash) {
+               SV *ptr = Perl_refcounted_he_fetch(aTHX_ PL_curcop->cop_hints_hash, 0,
+                                      "regcomp", 7, 0, 0);
+                if (ptr && SvIOK(ptr) && SvIV(ptr))
+                    eng = INT2PTR(regexp_engine*,SvIV(ptr));
            }
+
            if (PL_op->op_flags & OPf_SPECIAL)
                PL_reginterp_cnt = I32_MAX; /* Mark as safe.  */
 
@@ -146,7 +154,11 @@ PP(pp_regcomp)
                if (pm->op_pmdynflags & PMdf_UTF8)
                    t = (char*)bytes_to_utf8((U8*)t, &len);
            }
-           PM_SETRE(pm, CALLREGCOMP((char *)t, (char *)t + len, pm));
+           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);
            PL_reginterp_cnt = 0;       /* XXXX Be extra paranoid - needed
@@ -283,7 +295,7 @@ PP(pp_substcont)
            SvUPGRADE(sv, SVt_PVMG);
        if (!(mg = mg_find(sv, PERL_MAGIC_regex_global))) {
 #ifdef PERL_OLD_COPY_ON_WRITE
-           if (SvIsCOW(lsv))
+           if (SvIsCOW(sv))
                sv_force_normal_flags(sv, 0);
 #endif
            mg = sv_magicext(sv, NULL, PERL_MAGIC_regex_global, &PL_vtbl_mglob,
@@ -2438,13 +2450,13 @@ PP(pp_goto)
                        SV **ary = AvALLOC(av);
                        if (AvARRAY(av) != ary) {
                            AvMAX(av) += AvARRAY(av) - AvALLOC(av);
-                           SvPV_set(av, (char*)ary);
+                           AvARRAY(av) = ary;
                        }
                        if (items >= AvMAX(av) + 1) {
                            AvMAX(av) = items - 1;
                            Renew(ary,items+1,SV*);
                            AvALLOC(av) = ary;
-                           SvPV_set(av, (char*)ary);
+                           AvARRAY(av) = ary;
                        }
                    }
                    ++mark;
@@ -2463,21 +2475,7 @@ PP(pp_goto)
                    }
                }
                if (PERLDB_SUB) {       /* Checking curstash breaks DProf. */
-                   /*
-                    * We do not care about using sv to call CV;
-                    * it's for informational purposes only.
-                    */
-                   SV * const sv = GvSV(PL_DBsub);
-                   save_item(sv);
-                   if (PERLDB_SUB_NN) {
-                       const int type = SvTYPE(sv);
-                       if (type < SVt_PVIV && type != SVt_IV)
-                           sv_upgrade(sv, SVt_PVIV);
-                       (void)SvIOK_on(sv);
-                       SvIV_set(sv, PTR2IV(cv)); /* Do it the quickest way */
-                   } else {
-                       gv_efullname3(sv, CvGV(cv), NULL);
-                   }
+                   Perl_get_db_sub(aTHX_ NULL, cv);
                    if (PERLDB_GOTO) {
                        CV * const gotocv = get_cv("DB::goto", FALSE);
                        if (gotocv) {
@@ -2914,9 +2912,13 @@ S_doeval(pTHX_ int gimme, OP** startop, CV* outside, U32 seq)
        SAVESPTR(PL_curstash);
        PL_curstash = CopSTASH(PL_curcop);
     }
+    /* XXX:ajgo do we really need to alloc an AV for begin/checkunit */
     SAVESPTR(PL_beginav);
     PL_beginav = newAV();
     SAVEFREESV(PL_beginav);
+    SAVESPTR(PL_unitcheckav);
+    PL_unitcheckav = newAV();
+    SAVEFREESV(PL_unitcheckav);
     SAVEI32(PL_error_count);
 
 #ifdef PERL_MAD
@@ -3010,6 +3012,9 @@ S_doeval(pTHX_ int gimme, OP** startop, CV* outside, U32 seq)
        }
     }
 
+    if (PL_unitcheckav)
+       call_list(PL_scopestack_ix, PL_unitcheckav);
+
     /* compiled okay, so do it */
 
     CvDEPTH(PL_compcv) = 1;
@@ -3145,8 +3150,11 @@ PP(pp_require)
            for (i = 0; i <= AvFILL(ar); i++) {
                SV * const dirsv = *av_fetch(ar, i, TRUE);
 
+               if (SvTIED_mg((SV*)ar, PERL_MAGIC_tied))
+                   mg_get(dirsv);
                if (SvROK(dirsv)) {
                    int count;
+                   SV **svp;
                    SV *loader = dirsv;
 
                    if (SvTYPE(SvRV(loader)) == SVt_PVAV
@@ -3174,6 +3182,11 @@ PP(pp_require)
                        count = call_sv(loader, G_ARRAY);
                    SPAGAIN;
 
+                   /* Adjust file name if the hook has set an %INC entry */
+                   svp = hv_fetch(GvHVn(PL_incgv), name, len, 0);
+                   if (svp)
+                       tryname = SvPVX_const(*svp);
+
                    if (count > 0) {
                        int i = 0;
                        SV *arg;
@@ -3436,8 +3449,6 @@ PP(pp_entereval)
     }
     sv = POPs;
 
-    if (!SvPV_nolen_const(sv))
-       RETPUSHUNDEF;
     TAINT_PROPER("eval");
 
     ENTER;