Integrate with Sarathy.

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

diff --git a/pp_ctl.c b/pp_ctl.c
index af8b947..7b4cbfe 100644 (file)
--- a/pp_ctl.c
+++ b/pp_ctl.c
@@ -1,6 +1,6 @@
 /*    pp_ctl.c
  *
- *    Copyright (c) 1991-1999, Larry Wall
+ *    Copyright (c) 1991-2000, Larry Wall
  *
  *    You may distribute under the terms of either the GNU General Public
  *    License or the Artistic License, as specified in the README file.
@@ -114,6 +114,8 @@ PP(pp_regcomp)
                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_UTF8;
            pm->op_pmregexp = CALLREGCOMP(aTHX_ t, t + len, pm);
            PL_reginterp_cnt = 0;               /* XXXX Be extra paranoid - needed
                                           inside tie/overload accessors.  */
@@ -296,11 +298,17 @@ PP(pp_formline)
     NV value;
     bool gotsome;
     STRLEN len;
-    STRLEN fudge = SvCUR(tmpForm) * (IN_UTF8 ? 3 : 1) + 1;
+    STRLEN fudge = SvCUR(tmpForm) * (IN_BYTE ? 1 : 3) + 1;
+    bool item_is_utf = FALSE;
 
     if (!SvMAGICAL(tmpForm) || !SvCOMPILED(tmpForm)) {
-       SvREADONLY_off(tmpForm);
-       doparseform(tmpForm);
+       if (SvREADONLY(tmpForm)) {
+           SvREADONLY_off(tmpForm);
+           doparseform(tmpForm);
+           SvREADONLY_on(tmpForm);
+       }
+       else
+           doparseform(tmpForm);
     }
 
     SvPV_force(PL_formtarget, len);
@@ -374,7 +382,7 @@ PP(pp_formline)
        case FF_CHECKNL:
            item = s = SvPV(sv, len);
            itemsize = len;
-           if (IN_UTF8) {
+           if (DO_UTF8(sv)) {
                itemsize = sv_len_utf8(sv);
                if (itemsize != len) {
                    I32 itembytes;
@@ -393,11 +401,13 @@ PP(pp_formline)
                            break;
                        s++;
                    }
+                   item_is_utf = TRUE;
                    itemsize = s - item;
                    sv_pos_b2u(sv, &itemsize);
                    break;
                }
            }
+           item_is_utf = FALSE;
            if (itemsize > fieldsize)
                itemsize = fieldsize;
            send = chophere = s + itemsize;
@@ -414,7 +424,7 @@ PP(pp_formline)
        case FF_CHECKCHOP:
            item = s = SvPV(sv, len);
            itemsize = len;
-           if (IN_UTF8) {
+           if (DO_UTF8(sv)) {
                itemsize = sv_len_utf8(sv);
                if (itemsize != len) {
                    I32 itembytes;
@@ -452,9 +462,11 @@ PP(pp_formline)
                        itemsize = chophere - item;
                        sv_pos_b2u(sv, &itemsize);
                    }
+                   item_is_utf = TRUE;
                    break;
                }
            }
+           item_is_utf = FALSE;
            if (itemsize <= fieldsize) {
                send = chophere = s + itemsize;
                while (s < send) {
@@ -510,7 +522,7 @@ PP(pp_formline)
        case FF_ITEM:
            arg = itemsize;
            s = item;
-           if (IN_UTF8) {
+           if (item_is_utf) {
                while (arg--) {
                    if (*s & 0x80) {
                        switch (UTF8SKIP(s)) {
@@ -553,6 +565,7 @@ PP(pp_formline)
        case FF_LINEGLOB:
            item = s = SvPV(sv, len);
            itemsize = len;
+           item_is_utf = FALSE;                /* XXX is this correct? */
            if (itemsize) {
                gotsome = TRUE;
                send = s + itemsize;
@@ -1959,10 +1972,17 @@ PP(pp_next)
     if (cxix < cxstack_ix)
        dounwind(cxix);
 
-    TOPBLOCK(cx);
-    oldsave = PL_scopestack[PL_scopestack_ix - 1];
-    LEAVE_SCOPE(oldsave);
-    return cx->blk_loop.next_op;
+    cx = &cxstack[cxstack_ix];
+    {
+       OP *nextop = cx->blk_loop.next_op;
+       /* clean scope, but only if there's no continue block */
+       if (nextop == cUNOPx(cx->blk_loop.last_op)->op_first->op_next) {
+           TOPBLOCK(cx);
+           oldsave = PL_scopestack[PL_scopestack_ix - 1];
+           LEAVE_SCOPE(oldsave);
+       }
+       return nextop;
+    }
 }
 
 PP(pp_redo)
@@ -2555,7 +2575,8 @@ Perl_sv_compile_2op(pTHX_ SV *sv, OP** startop, char *code, AV** avp)
     I32 optype;
     OP dummy;
     OP *oop = PL_op, *rop;
-    char tmpbuf[TYPE_DIGITS(long) + 12 + 10];
+    char tbuf[TYPE_DIGITS(long) + 12 + 10];
+    char *tmpbuf = tbuf;
     char *safestr;
 
     ENTER;
@@ -2569,7 +2590,15 @@ Perl_sv_compile_2op(pTHX_ SV *sv, OP** startop, char *code, AV** avp)
     }
     SAVECOPFILE(&PL_compiling);
     SAVECOPLINE(&PL_compiling);
-    sprintf(tmpbuf, "_<(%.10s_eval %lu)", code, (unsigned long)++PL_evalseq);
+    if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
+       SV *sv = sv_newmortal();
+       Perl_sv_setpvf(aTHX_ sv, "_<(%.10seval %lu)[%s:%"IVdf"]",
+                      code, (unsigned long)++PL_evalseq,
+                      CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
+       tmpbuf = SvPVX(sv);
+    }
+    else
+       sprintf(tmpbuf, "_<(%.10s_eval %lu)", code, (unsigned long)++PL_evalseq);
     CopFILE_set(&PL_compiling, tmpbuf+2);
     CopLINE_set(&PL_compiling, 1);
     /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
@@ -2841,7 +2870,7 @@ PP(pp_require)
     sv = POPs;
     if (SvNIOKp(sv)) {
        UV rev, ver, sver;
-       if (SvPOKp(sv) && SvUTF8(sv)) {         /* require v5.6.1 */
+       if (SvPOKp(sv)) {               /* require v5.6.1 */
            I32 len;
            U8 *s = (U8*)SvPVX(sv);
            U8 *end = (U8*)SvPVX(sv) + SvCUR(sv);
@@ -3140,7 +3169,8 @@ PP(pp_entereval)
     register PERL_CONTEXT *cx;
     dPOPss;
     I32 gimme = GIMME_V, was = PL_sub_generation;
-    char tmpbuf[TYPE_DIGITS(long) + 12];
+    char tbuf[TYPE_DIGITS(long) + 12];
+    char *tmpbuf = tbuf;
     char *safestr;
     STRLEN len;
     OP *ret;
@@ -3156,7 +3186,15 @@ PP(pp_entereval)
     /* switch to eval mode */
 
     SAVECOPFILE(&PL_compiling);
-    sprintf(tmpbuf, "_<(eval %lu)", (unsigned long)++PL_evalseq);
+    if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
+       SV *sv = sv_newmortal();
+       Perl_sv_setpvf(aTHX_ sv, "_<(eval %lu)[%s:%"IVdf"]",
+                      (unsigned long)++PL_evalseq,
+                      CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
+       tmpbuf = SvPVX(sv);
+    }
+    else
+       sprintf(tmpbuf, "_<(eval %lu)", (unsigned long)++PL_evalseq);
     CopFILE_set(&PL_compiling, tmpbuf+2);
     CopLINE_set(&PL_compiling, 1);
     /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up