Integrate with Sarathy.

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

diff --git a/pp_ctl.c b/pp_ctl.c
index fd725a3..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.
@@ -116,8 +116,6 @@ PP(pp_regcomp)
            pm->op_pmflags = pm->op_pmpermflags;        /* reset case sensitivity */
            if (DO_UTF8(tmpstr))
                pm->op_pmdynflags |= PMdf_UTF8;
-           else
-               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.  */
@@ -304,8 +302,13 @@ PP(pp_formline)
     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);
@@ -2572,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;
@@ -2586,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
@@ -2858,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);
@@ -3157,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;
@@ -3173,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