Make also the -CAL conditional on locale.

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

diff --git a/pp_ctl.c b/pp_ctl.c
index 4ef44fd..9a807a5 100644 (file)
--- a/pp_ctl.c
+++ b/pp_ctl.c
@@ -158,7 +158,7 @@ PP(pp_substcont)
     register REGEXP *rx = cx->sb_rx;
 
     rxres_restore(&cx->sb_rxres, rx);
-    PL_reg_match_utf8 = SvUTF8(cx->sb_targ) ? 1 : 0;
+    RX_MATCH_UTF8_set(rx, SvUTF8(cx->sb_targ));
 
     if (cx->sb_iters++) {
        I32 saviters = cx->sb_iters;
@@ -181,8 +181,16 @@ PP(pp_substcont)
            sv_catpvn(dstr, s, cx->sb_strend - s);
            cx->sb_rxtainted |= RX_MATCH_TAINTED(rx);
 
-           (void)SvOOK_off(targ);
-           Safefree(SvPVX(targ));
+#ifdef PERL_COPY_ON_WRITE
+           if (SvIsCOW(targ)) {
+               sv_force_normal_flags(targ, SV_COW_DROP_PV);
+           } else
+#endif
+           {
+               (void)SvOOK_off(targ);
+               if (SvLEN(targ))
+                   Safefree(SvPVX(targ));
+           }
            SvPVX(targ) = SvPVX(dstr);
            SvCUR_set(targ, SvCUR(dstr));
            SvLEN_set(targ, SvLEN(dstr));
@@ -243,7 +251,11 @@ Perl_rxres_save(pTHX_ void **rsp, REGEXP *rx)
     U32 i;
 
     if (!p || p[1] < rx->nparens) {
+#ifdef PERL_COPY_ON_WRITE
+       i = 7 + rx->nparens * 2;
+#else
        i = 6 + rx->nparens * 2;
+#endif
        if (!p)
            New(501, p, i, UV);
        else
@@ -254,6 +266,11 @@ Perl_rxres_save(pTHX_ void **rsp, REGEXP *rx)
     *p++ = PTR2UV(RX_MATCH_COPIED(rx) ? rx->subbeg : Nullch);
     RX_MATCH_COPIED_off(rx);
 
+#ifdef PERL_COPY_ON_WRITE
+    *p++ = PTR2UV(rx->saved_copy);
+    rx->saved_copy = Nullsv;
+#endif
+
     *p++ = rx->nparens;
 
     *p++ = PTR2UV(rx->subbeg);
@@ -270,11 +287,17 @@ Perl_rxres_restore(pTHX_ void **rsp, REGEXP *rx)
     UV *p = (UV*)*rsp;
     U32 i;
 
-    if (RX_MATCH_COPIED(rx))
-       Safefree(rx->subbeg);
+    RX_MATCH_COPY_FREE(rx);
     RX_MATCH_COPIED_set(rx, *p);
     *p++ = 0;
 
+#ifdef PERL_COPY_ON_WRITE
+    if (rx->saved_copy)
+       SvREFCNT_dec (rx->saved_copy);
+    rx->saved_copy = INT2PTR(SV*,*p);
+    *p++ = 0;
+#endif
+
     rx->nparens = *p++;
 
     rx->subbeg = INT2PTR(char*,*p++);
@@ -292,6 +315,11 @@ Perl_rxres_free(pTHX_ void **rsp)
 
     if (p) {
        Safefree(INT2PTR(char*,*p));
+#ifdef PERL_COPY_ON_WRITE
+       if (p[1]) {
+           SvREFCNT_dec (INT2PTR(SV*,p[1]));
+       }
+#endif
        Safefree(p);
        *rsp = Null(void*);
     }
@@ -1582,7 +1610,8 @@ PP(pp_dbstate)
     PL_stack_sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;
     FREETMPS;
 
-    if (PL_op->op_private || SvIV(PL_DBsingle) || SvIV(PL_DBsignal) || SvIV(PL_DBtrace))
+    if (PL_op->op_flags & OPf_SPECIAL /* breakpoint */
+           || SvIV(PL_DBsingle) || SvIV(PL_DBsignal) || SvIV(PL_DBtrace))
     {
        dSP;
        register CV *cv;
@@ -1611,7 +1640,7 @@ PP(pp_dbstate)
 
        push_return(PL_op->op_next);
        PUSHBLOCK(cx, CXt_SUB, SP);
-       PUSHSUB(cx);
+       PUSHSUB_DB(cx);
        CvDEPTH(cv)++;
        (void)SvREFCNT_inc(cv);
        PAD_SET_CUR(CvPADLIST(cv),1);
@@ -2013,6 +2042,7 @@ S_dofindlabel(pTHX_ OP *o, char *label, OP **opstack, OP **oplimit)
     if (o->op_type == OP_LEAVE ||
        o->op_type == OP_SCOPE ||
        o->op_type == OP_LEAVELOOP ||
+       o->op_type == OP_LEAVESUB ||
        o->op_type == OP_LEAVETRY)
     {
        *ops++ = cUNOPo->op_first;
@@ -2100,6 +2130,7 @@ PP(pp_goto)
            }
 
            /* First do some returnish stuff. */
+           FREETMPS;
            cxix = dopoptosub(cxstack_ix);
            if (cxix < 0)
                DIE(aTHX_ "Can't goto subroutine outside a subroutine");
@@ -2270,6 +2301,7 @@ PP(pp_goto)
     if (label && *label) {
        OP *gotoprobe = 0;
        bool leaving_eval = FALSE;
+       bool in_block = FALSE;
         PERL_CONTEXT *last_eval_cx = 0;
 
        /* find label */
@@ -2295,9 +2327,10 @@ PP(pp_goto)
            case CXt_SUBST:
                continue;
            case CXt_BLOCK:
-               if (ix)
+               if (ix) {
                    gotoprobe = cx->blk_oldcop->op_sibling;
-               else
+                   in_block = TRUE;
+               } else
                    gotoprobe = PL_main_root;
                break;
            case CXt_SUB:
@@ -2354,7 +2387,8 @@ PP(pp_goto)
 
        if (*enterops && enterops[1]) {
            OP *oldop = PL_op;
-           for (ix = 1; enterops[ix]; ix++) {
+           ix = enterops[1]->op_type == OP_ENTER && in_block ? 2 : 1;
+           for (; enterops[ix]; ix++) {
                PL_op = enterops[ix];
                /* Eventually we may want to stack the needed arguments
                 * for each op.  For now, we punt on the hard ones. */
@@ -2559,7 +2593,7 @@ Perl_sv_compile_2op(pTHX_ SV *sv, OP** startop, char *code, PAD** padp)
     char *tmpbuf = tbuf;
     char *safestr;
     int runtime;
-    CV* runcv;
+    CV* runcv = Nullcv;        /* initialise to avoid compiler warnings */
 
     ENTER;
     lex_start(sv);