Missing thingies.

[perl5.git] / pp_hot.c

diff --git a/pp_hot.c b/pp_hot.c
index 461c666..208d89b 100644 (file)
--- a/pp_hot.c
+++ b/pp_hot.c
@@ -1,6 +1,7 @@
 /*    pp_hot.c
  *
 /*    pp_hot.c
  *

- *    Copyright (c) 1991-2002, Larry Wall
+ *    Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
+ *    2000, 2001, 2002, 2003, by Larry Wall and others

  *
  *    You may distribute under the terms of either the GNU General Public
  *    License or the Artistic License, as specified in the README file.
  *
  *    You may distribute under the terms of either the GNU General Public
  *    License or the Artistic License, as specified in the README file.


@@ -136,11 +137,12 @@ PP(pp_concat)
     bool lbyte;
     STRLEN rlen;
     char* rpv = SvPV(right, rlen);     /* mg_get(right) happens here */
     bool lbyte;
     STRLEN rlen;
     char* rpv = SvPV(right, rlen);     /* mg_get(right) happens here */

-    bool rbyte = !SvUTF8(right);
+    bool rbyte = !SvUTF8(right), rcopied = FALSE;

 
     if (TARG == right && right != left) {
        right = sv_2mortal(newSVpvn(rpv, rlen));
 
     if (TARG == right && right != left) {
        right = sv_2mortal(newSVpvn(rpv, rlen));

-       rpv = SvPV(right, rlen);        /* no point setting UTF8 here */
+       rpv = SvPV(right, rlen);        /* no point setting UTF-8 here */
+       rcopied = TRUE;

     }
 
     if (TARG != left) {
     }
 
     if (TARG != left) {


@@ -176,6 +178,8 @@ PP(pp_concat)
        if (lbyte)
            sv_utf8_upgrade_nomg(TARG);
        else {
        if (lbyte)
            sv_utf8_upgrade_nomg(TARG);
        else {

+           if (!rcopied)
+               right = sv_2mortal(newSVpvn(rpv, rlen));

            sv_utf8_upgrade_nomg(right);
            rpv = SvPV(right, rlen);
        }
            sv_utf8_upgrade_nomg(right);
            rpv = SvPV(right, rlen);
        }


@@ -682,6 +686,9 @@ PP(pp_rv2av)
            SETs((SV*)av);
            RETURN;
        }
            SETs((SV*)av);
            RETURN;
        }

+       else if (PL_op->op_flags & OPf_MOD
+               && PL_op->op_private & OPpLVAL_INTRO)
+           Perl_croak(aTHX_ PL_no_localize_ref);

     }
     else {
        if (SvTYPE(sv) == SVt_PVAV) {
     }
     else {
        if (SvTYPE(sv) == SVt_PVAV) {


@@ -788,6 +795,7 @@ PP(pp_rv2hv)
 {
     dSP; dTOPss;
     HV *hv;
 {
     dSP; dTOPss;
     HV *hv;

+    I32 gimme = GIMME_V;

 
     if (SvROK(sv)) {
       wasref:
 
     if (SvROK(sv)) {
       wasref:


@@ -801,11 +809,14 @@ PP(pp_rv2hv)
            RETURN;
        }
        else if (LVRET) {
            RETURN;
        }
        else if (LVRET) {

-           if (GIMME == G_SCALAR)
+           if (gimme != G_ARRAY)

                Perl_croak(aTHX_ "Can't return hash to lvalue scalar context");
            SETs((SV*)hv);
            RETURN;
        }
                Perl_croak(aTHX_ "Can't return hash to lvalue scalar context");
            SETs((SV*)hv);
            RETURN;
        }

+       else if (PL_op->op_flags & OPf_MOD
+               && PL_op->op_private & OPpLVAL_INTRO)
+           Perl_croak(aTHX_ PL_no_localize_ref);

     }
     else {
        if (SvTYPE(sv) == SVt_PVHV) {
     }
     else {
        if (SvTYPE(sv) == SVt_PVHV) {


@@ -815,7 +826,7 @@ PP(pp_rv2hv)
                RETURN;
            }
            else if (LVRET) {
                RETURN;
            }
            else if (LVRET) {

-               if (GIMME == G_SCALAR)
+               if (gimme != G_ARRAY)

                    Perl_croak(aTHX_ "Can't return hash to lvalue"
                               " scalar context");
                SETs((SV*)hv);
                    Perl_croak(aTHX_ "Can't return hash to lvalue"
                               " scalar context");
                SETs((SV*)hv);


@@ -840,7 +851,7 @@ PP(pp_rv2hv)
                        DIE(aTHX_ PL_no_usym, "a HASH");
                    if (ckWARN(WARN_UNINITIALIZED))
                        report_uninit();
                        DIE(aTHX_ PL_no_usym, "a HASH");
                    if (ckWARN(WARN_UNINITIALIZED))
                        report_uninit();

-                   if (GIMME == G_ARRAY) {
+                   if (gimme == G_ARRAY) {

                        SP--;
                        RETURN;
                    }
                        SP--;
                        RETURN;
                    }


@@ -875,7 +886,7 @@ PP(pp_rv2hv)
                RETURN;
            }
            else if (LVRET) {
                RETURN;
            }
            else if (LVRET) {

-               if (GIMME == G_SCALAR)
+               if (gimme != G_ARRAY)

                    Perl_croak(aTHX_ "Can't return hash to lvalue"
                               " scalar context");
                SETs((SV*)hv);
                    Perl_croak(aTHX_ "Can't return hash to lvalue"
                               " scalar context");
                SETs((SV*)hv);


@@ -884,21 +895,16 @@ PP(pp_rv2hv)
        }
     }
 
        }
     }
 

-    if (GIMME == G_ARRAY) { /* array wanted */
+    if (gimme == G_ARRAY) { /* array wanted */

        *PL_stack_sp = (SV*)hv;
        return do_kv();
     }
        *PL_stack_sp = (SV*)hv;
        return do_kv();
     }

-    else {
+    else if (gimme == G_SCALAR) {

        dTARGET;
        dTARGET;

-       if (HvFILL(hv))
-            Perl_sv_setpvf(aTHX_ TARG, "%"IVdf"/%"IVdf,
-                          (IV)HvFILL(hv), (IV)HvMAX(hv) + 1);
-       else
-           sv_setiv(TARG, 0);
-       
+    TARG = Perl_hv_scalar(aTHX_ hv);

        SETTARG;
        SETTARG;

-       RETURN;

     }
     }

+    RETURN;

 }
 
 STATIC void
 }
 
 STATIC void


@@ -952,8 +958,12 @@ PP(pp_aassign)
     HV *hash;
     I32 i;
     int magic;
     HV *hash;
     I32 i;
     int magic;

+    int duplicates = 0;
+    SV **firsthashrelem = 0;   /* "= 0" keeps gcc 2.95 quiet  */
+

 
     PL_delaymagic = DM_DELAY;          /* catch simultaneous items */
 
     PL_delaymagic = DM_DELAY;          /* catch simultaneous items */

+    gimme = GIMME_V;

 
     /* If there's a common identifier on both sides we have to take
      * special care that assigning the identifier on the left doesn't
 
     /* If there's a common identifier on both sides we have to take
      * special care that assigning the identifier on the left doesn't


@@ -1007,6 +1017,7 @@ PP(pp_aassign)
                hash = (HV*)sv;
                magic = SvMAGICAL(hash) != 0;
                hv_clear(hash);
                hash = (HV*)sv;
                magic = SvMAGICAL(hash) != 0;
                hv_clear(hash);

+               firsthashrelem = relem;

 
                while (relem < lastrelem) {     /* gobble up all the rest */
                    HE *didstore;
 
                while (relem < lastrelem) {     /* gobble up all the rest */
                    HE *didstore;


@@ -1018,6 +1029,9 @@ PP(pp_aassign)
                    if (*relem)
                        sv_setsv(tmpstr,*relem);        /* value */
                    *(relem++) = tmpstr;
                    if (*relem)
                        sv_setsv(tmpstr,*relem);        /* value */
                    *(relem++) = tmpstr;

+                   if (gimme != G_VOID && hv_exists_ent(hash, sv, 0))
+                       /* key overwrites an existing entry */
+                       duplicates += 2;

                    didstore = hv_store_ent(hash,sv,tmpstr,0);
                    if (magic) {
                        if (SvSMAGICAL(tmpstr))
                    didstore = hv_store_ent(hash,sv,tmpstr,0);
                    if (magic) {
                        if (SvSMAGICAL(tmpstr))


@@ -1052,10 +1066,13 @@ PP(pp_aassign)
     if (PL_delaymagic & ~DM_DELAY) {
        if (PL_delaymagic & DM_UID) {
 #ifdef HAS_SETRESUID
     if (PL_delaymagic & ~DM_DELAY) {
        if (PL_delaymagic & DM_UID) {
 #ifdef HAS_SETRESUID

-           (void)setresuid(PL_uid,PL_euid,(Uid_t)-1);
+           (void)setresuid((PL_delaymagic & DM_RUID) ? PL_uid  : (Uid_t)-1,
+                           (PL_delaymagic & DM_EUID) ? PL_euid : (Uid_t)-1,
+                           (Uid_t)-1);

 #else
 #  ifdef HAS_SETREUID
 #else
 #  ifdef HAS_SETREUID

-           (void)setreuid(PL_uid,PL_euid);
+           (void)setreuid((PL_delaymagic & DM_RUID) ? PL_uid  : (Uid_t)-1,
+                          (PL_delaymagic & DM_EUID) ? PL_euid : (Uid_t)-1);

 #  else
 #    ifdef HAS_SETRUID
            if ((PL_delaymagic & DM_UID) == DM_RUID) {
 #  else
 #    ifdef HAS_SETRUID
            if ((PL_delaymagic & DM_UID) == DM_RUID) {


@@ -1065,7 +1082,7 @@ PP(pp_aassign)
 #    endif /* HAS_SETRUID */
 #    ifdef HAS_SETEUID
            if ((PL_delaymagic & DM_UID) == DM_EUID) {
 #    endif /* HAS_SETRUID */
 #    ifdef HAS_SETEUID
            if ((PL_delaymagic & DM_UID) == DM_EUID) {

-               (void)seteuid(PL_uid);
+               (void)seteuid(PL_euid);

                PL_delaymagic &= ~DM_EUID;
            }
 #    endif /* HAS_SETEUID */
                PL_delaymagic &= ~DM_EUID;
            }
 #    endif /* HAS_SETEUID */


@@ -1081,10 +1098,13 @@ PP(pp_aassign)
        }
        if (PL_delaymagic & DM_GID) {
 #ifdef HAS_SETRESGID
        }
        if (PL_delaymagic & DM_GID) {
 #ifdef HAS_SETRESGID

-           (void)setresgid(PL_gid,PL_egid,(Gid_t)-1);
+           (void)setresgid((PL_delaymagic & DM_RGID) ? PL_gid  : (Gid_t)-1,
+                           (PL_delaymagic & DM_EGID) ? PL_egid : (Gid_t)-1,
+                           (Gid_t)-1);

 #else
 #  ifdef HAS_SETREGID
 #else
 #  ifdef HAS_SETREGID

-           (void)setregid(PL_gid,PL_egid);
+           (void)setregid((PL_delaymagic & DM_RGID) ? PL_gid  : (Gid_t)-1,
+                          (PL_delaymagic & DM_EGID) ? PL_egid : (Gid_t)-1);

 #  else
 #    ifdef HAS_SETRGID
            if ((PL_delaymagic & DM_GID) == DM_RGID) {
 #  else
 #    ifdef HAS_SETRGID
            if ((PL_delaymagic & DM_GID) == DM_RGID) {


@@ -1094,7 +1114,7 @@ PP(pp_aassign)
 #    endif /* HAS_SETRGID */
 #    ifdef HAS_SETEGID
            if ((PL_delaymagic & DM_GID) == DM_EGID) {
 #    endif /* HAS_SETRGID */
 #    ifdef HAS_SETEGID
            if ((PL_delaymagic & DM_GID) == DM_EGID) {

-               (void)setegid(PL_gid);
+               (void)setegid(PL_egid);

                PL_delaymagic &= ~DM_EGID;
            }
 #    endif /* HAS_SETEGID */
                PL_delaymagic &= ~DM_EGID;
            }
 #    endif /* HAS_SETEGID */


@@ -1112,17 +1132,26 @@ PP(pp_aassign)
     }
     PL_delaymagic = 0;
 
     }
     PL_delaymagic = 0;
 

-    gimme = GIMME_V;

     if (gimme == G_VOID)
        SP = firstrelem - 1;
     else if (gimme == G_SCALAR) {
        dTARGET;
        SP = firstrelem;
     if (gimme == G_VOID)
        SP = firstrelem - 1;
     else if (gimme == G_SCALAR) {
        dTARGET;
        SP = firstrelem;

-       SETi(lastrelem - firstrelem + 1);
+       SETi(lastrelem - firstrelem + 1 - duplicates);

     }
     else {
     }
     else {

-       if (ary || hash)
+       if (ary)
+           SP = lastrelem;
+       else if (hash) {
+           if (duplicates) {
+               /* Removes from the stack the entries which ended up as
+                * duplicated keys in the hash (fix for [perl #24380]) */
+               Move(firsthashrelem + duplicates,
+                       firsthashrelem, duplicates, SV**);
+               lastrelem -= duplicates;
+           }

            SP = lastrelem;
            SP = lastrelem;

+       }

        else
            SP = firstrelem + (lastlelem - firstlelem);
        lelem = firstlelem + (relem - firstrelem);
        else
            SP = firstrelem + (lastlelem - firstlelem);
        lelem = firstlelem + (relem - firstrelem);


@@ -1180,7 +1209,7 @@ PP(pp_match)
                 (PL_tainted && (pm->op_pmflags & PMf_RETAINT)));
     TAINT_NOT;
 
                 (PL_tainted && (pm->op_pmflags & PMf_RETAINT)));
     TAINT_NOT;
 

-    PL_reg_match_utf8 = DO_UTF8(TARG);
+    RX_MATCH_UTF8_set(rx, DO_UTF8(TARG));

 
     /* PMdf_USED is set after a ?? matches once */
     if (pm->op_pmdynflags & PMdf_USED) {
 
     /* PMdf_USED is set after a ?? matches once */
     if (pm->op_pmdynflags & PMdf_USED) {


@@ -1224,7 +1253,7 @@ PP(pp_match)
     if (SvSCREAM(TARG))
        r_flags |= REXEC_SCREAM;
 
     if (SvSCREAM(TARG))
        r_flags |= REXEC_SCREAM;
 

-    if (pm->op_pmflags & (PMf_MULTILINE|PMf_SINGLELINE)) {
+    if ((int)(pm->op_pmflags & PMf_MULTILINE) != PL_multiline) {

        SAVEINT(PL_multiline);
        PL_multiline = pm->op_pmflags & PMf_MULTILINE;
     }
        SAVEINT(PL_multiline);
        PL_multiline = pm->op_pmflags & PMf_MULTILINE;
     }


@@ -1355,7 +1384,7 @@ yup:                                      /* Confirmed by INTUIT */
     if (global) {
        rx->subbeg = truebase;
        rx->startp[0] = s - truebase;
     if (global) {
        rx->subbeg = truebase;
        rx->startp[0] = s - truebase;

-       if (PL_reg_match_utf8) {
+       if (RX_MATCH_UTF8(rx)) {

            char *t = (char*)utf8_hop((U8*)s, rx->minlen);
            rx->endp[0] = t - truebase;
        }
            char *t = (char*)utf8_hop((U8*)s, rx->minlen);
            rx->endp[0] = t - truebase;
        }


@@ -1367,8 +1396,26 @@ yup:                                     /* Confirmed by INTUIT */
     }
     if (PL_sawampersand) {
        I32 off;
     }
     if (PL_sawampersand) {
        I32 off;

+#ifdef PERL_COPY_ON_WRITE
+       if (SvIsCOW(TARG) || (SvFLAGS(TARG) & CAN_COW_MASK) == CAN_COW_FLAGS) {
+           if (DEBUG_C_TEST) {
+               PerlIO_printf(Perl_debug_log,
+                             "Copy on write: pp_match $& capture, type %d, truebase=%p, t=%p, difference %d\n",
+                             (int) SvTYPE(TARG), truebase, t,
+                             (int)(t-truebase));
+           }
+           rx->saved_copy = sv_setsv_cow(rx->saved_copy, TARG);
+           rx->subbeg = SvPVX(rx->saved_copy) + (t - truebase);
+           assert (SvPOKp(rx->saved_copy));
+       } else
+#endif
+       {

 
 

-       rx->subbeg = savepvn(t, strend - t);
+           rx->subbeg = savepvn(t, strend - t);
+#ifdef PERL_COPY_ON_WRITE
+           rx->saved_copy = Nullsv;
+#endif
+       }

        rx->sublen = strend - t;
        RX_MATCH_COPIED_on(rx);
        off = rx->startp[0] = s - t;
        rx->sublen = strend - t;
        RX_MATCH_COPIED_on(rx);
        off = rx->startp[0] = s - t;


@@ -1378,7 +1425,7 @@ yup:                                      /* Confirmed by INTUIT */
        rx->startp[0] = s - truebase;
        rx->endp[0] = s - truebase + rx->minlen;
     }
        rx->startp[0] = s - truebase;
        rx->endp[0] = s - truebase + rx->minlen;
     }

-    rx->nparens = rx->lastparen = 0;   /* used by @- and @+ */
+    rx->nparens = rx->lastparen = rx->lastcloseparen = 0;      /* used by @-, @+, and $^N */

     LEAVE_SCOPE(oldsave);
     RETPUSHYES;
 
     LEAVE_SCOPE(oldsave);
     RETPUSHYES;
 


@@ -1467,8 +1514,10 @@ Perl_do_readline(pTHX)
        }
        if (gimme == G_SCALAR) {
            /* undef TARG, and push that undefined value */
        }
        if (gimme == G_SCALAR) {
            /* undef TARG, and push that undefined value */

-           SV_CHECK_THINKFIRST_COW_DROP(TARG);
-           (void)SvOK_off(TARG);
+           if (type != OP_RCATLINE) {
+               SV_CHECK_THINKFIRST_COW_DROP(TARG);
+               (void)SvOK_off(TARG);
+           }

            PUSHTARG;
        }
        RETURN;
            PUSHTARG;
        }
        RETURN;


@@ -1480,7 +1529,7 @@ Perl_do_readline(pTHX)
            sv_unref(sv);
        (void)SvUPGRADE(sv, SVt_PV);
        tmplen = SvLEN(sv);     /* remember if already alloced */
            sv_unref(sv);
        (void)SvUPGRADE(sv, SVt_PV);
        tmplen = SvLEN(sv);     /* remember if already alloced */

-       if (!tmplen)
+       if (!tmplen && !SvREADONLY(sv))

            Sv_Grow(sv, 80);    /* try short-buffering it */
        offset = 0;
        if (type == OP_RCATLINE && SvOK(sv)) {
            Sv_Grow(sv, 80);    /* try short-buffering it */
        offset = 0;
        if (type == OP_RCATLINE && SvOK(sv)) {


@@ -1511,7 +1560,9 @@ Perl_do_readline(pTHX)
     for (;;) {
        PUTBACK;
        if (!sv_gets(sv, fp, offset)
     for (;;) {
        PUTBACK;
        if (!sv_gets(sv, fp, offset)

-           && (type == OP_GLOB || SNARF_EOF(gimme, PL_rs, io, sv)))
+           && (type == OP_GLOB
+               || SNARF_EOF(gimme, PL_rs, io, sv)
+               || PerlIO_error(fp)))

        {
            PerlIO_clearerr(fp);
            if (IoFLAGS(io) & IOf_ARGV) {
        {
            PerlIO_clearerr(fp);
            if (IoFLAGS(io) & IOf_ARGV) {


@@ -1529,8 +1580,10 @@ Perl_do_readline(pTHX)
                }
            }
            if (gimme == G_SCALAR) {
                }
            }
            if (gimme == G_SCALAR) {

-               SV_CHECK_THINKFIRST_COW_DROP(TARG);
-               (void)SvOK_off(TARG);
+               if (type != OP_RCATLINE) {
+                   SV_CHECK_THINKFIRST_COW_DROP(TARG);
+                   (void)SvOK_off(TARG);
+               }

                SPAGAIN;
                PUSHTARG;
            }
                SPAGAIN;
                PUSHTARG;
            }


@@ -1561,6 +1614,17 @@ Perl_do_readline(pTHX)
                (void)POPs;             /* Unmatched wildcard?  Chuck it... */
                continue;
            }
                (void)POPs;             /* Unmatched wildcard?  Chuck it... */
                continue;
            }

+       } else if (SvUTF8(sv)) { /* OP_READLINE, OP_RCATLINE */
+            U8 *s = (U8*)SvPVX(sv) + offset;
+            STRLEN len = SvCUR(sv) - offset;
+            U8 *f;
+            
+            if (ckWARN(WARN_UTF8) &&
+                !Perl_is_utf8_string_loc(aTHX_ s, len, &f))
+                 /* Emulate :encoding(utf8) warning in the same case. */
+                 Perl_warner(aTHX_ packWARN(WARN_UTF8),
+                             "utf8 \"\\x%02X\" does not map to Unicode",
+                             f < (U8*)SvEND(sv) ? *f : 0);

        }
        if (gimme == G_ARRAY) {
            if (SvLEN(sv) - SvCUR(sv) > 20) {
        }
        if (gimme == G_ARRAY) {
            if (SvLEN(sv) - SvCUR(sv) > 20) {


@@ -1827,6 +1891,11 @@ PP(pp_iter)
     else {
        sv = AvARRAY(av)[++cx->blk_loop.iterix];
     }
     else {
        sv = AvARRAY(av)[++cx->blk_loop.iterix];
     }

+    if (sv && SvREFCNT(sv) == 0) {
+       *itersvp = Nullsv;
+       Perl_croak(aTHX_ "Use of freed value in iteration");
+    }
+

     if (sv)
        SvTEMP_off(sv);
     else
     if (sv)
        SvTEMP_off(sv);
     else


@@ -1880,6 +1949,10 @@ PP(pp_subst)
     I32 oldsave = PL_savestack_ix;
     STRLEN slen;
     bool doutf8 = FALSE;
     I32 oldsave = PL_savestack_ix;
     STRLEN slen;
     bool doutf8 = FALSE;

+#ifdef PERL_COPY_ON_WRITE
+    bool is_cow;
+#endif
+    SV *nsv = Nullsv;

 
     /* known replacement string? */
     dstr = (pm->op_pmflags & PMf_CONST) ? POPs : Nullsv;
 
     /* known replacement string? */
     dstr = (pm->op_pmflags & PMf_CONST) ? POPs : Nullsv;


@@ -1890,11 +1963,21 @@ PP(pp_subst)
        EXTEND(SP,1);
     }
 
        EXTEND(SP,1);
     }
 

+#ifdef PERL_COPY_ON_WRITE
+    /* Awooga. Awooga. "bool" types that are actually char are dangerous,
+       because they make integers such as 256 "false".  */
+    is_cow = SvIsCOW(TARG) ? TRUE : FALSE;
+#else

     if (SvIsCOW(TARG))
        sv_force_normal_flags(TARG,0);
     if (SvIsCOW(TARG))
        sv_force_normal_flags(TARG,0);

-    if (SvREADONLY(TARG)
+#endif
+    if (
+#ifdef PERL_COPY_ON_WRITE
+       !is_cow &&
+#endif
+       (SvREADONLY(TARG)

        || (SvTYPE(TARG) > SVt_PVLV
        || (SvTYPE(TARG) > SVt_PVLV

-           && !(SvTYPE(TARG) == SVt_PVGV && SvFAKE(TARG))))
+           && !(SvTYPE(TARG) == SVt_PVGV && SvFAKE(TARG)))))

        DIE(aTHX_ PL_no_modify);
     PUTBACK;
 
        DIE(aTHX_ PL_no_modify);
     PUTBACK;
 


@@ -1907,14 +1990,14 @@ PP(pp_subst)
        rxtainted |= 2;
     TAINT_NOT;
 
        rxtainted |= 2;
     TAINT_NOT;
 

-    PL_reg_match_utf8 = DO_UTF8(TARG);
+    RX_MATCH_UTF8_set(rx, DO_UTF8(TARG));

 
   force_it:
     if (!pm || !s)
        DIE(aTHX_ "panic: pp_subst");
 
     strend = s + len;
 
   force_it:
     if (!pm || !s)
        DIE(aTHX_ "panic: pp_subst");
 
     strend = s + len;

-    slen = PL_reg_match_utf8 ? utf8_length((U8*)s, (U8*)strend) : len;
+    slen = RX_MATCH_UTF8(rx) ? utf8_length((U8*)s, (U8*)strend) : len;

     maxiters = 2 * slen + 10;  /* We can match twice at each
                                   position, once with zero-length,
                                   second time with non-zero. */
     maxiters = 2 * slen + 10;  /* We can match twice at each
                                   position, once with zero-length,
                                   second time with non-zero. */


@@ -1924,10 +2007,10 @@ PP(pp_subst)
        rx = PM_GETRE(pm);
     }
     r_flags = (rx->nparens || SvTEMP(TARG) || PL_sawampersand)
        rx = PM_GETRE(pm);
     }
     r_flags = (rx->nparens || SvTEMP(TARG) || PL_sawampersand)

-               ? REXEC_COPY_STR : 0;
+              ? REXEC_COPY_STR : 0;

     if (SvSCREAM(TARG))
        r_flags |= REXEC_SCREAM;
     if (SvSCREAM(TARG))
        r_flags |= REXEC_SCREAM;

-    if (pm->op_pmflags & (PMf_MULTILINE|PMf_SINGLELINE)) {
+    if ((int)(pm->op_pmflags & PMf_MULTILINE) != PL_multiline) {

        SAVEINT(PL_multiline);
        PL_multiline = pm->op_pmflags & PMf_MULTILINE;
     }
        SAVEINT(PL_multiline);
        PL_multiline = pm->op_pmflags & PMf_MULTILINE;
     }


@@ -1955,7 +2038,7 @@ PP(pp_subst)
     if (dstr) {
        /* replacement needing upgrading? */
        if (DO_UTF8(TARG) && !doutf8) {
     if (dstr) {
        /* replacement needing upgrading? */
        if (DO_UTF8(TARG) && !doutf8) {

-            SV *nsv = sv_newmortal();
+            nsv = sv_newmortal();

             SvSetSV(nsv, dstr);
             if (PL_encoding)
                  sv_recode_to_utf8(nsv, PL_encoding);
             SvSetSV(nsv, dstr);
             if (PL_encoding)
                  sv_recode_to_utf8(nsv, PL_encoding);


@@ -1975,8 +2058,13 @@ PP(pp_subst)
     }
     
     /* can do inplace substitution? */
     }
     
     /* can do inplace substitution? */

-    if (c && (I32)clen <= rx->minlen && (once || !(r_flags & REXEC_COPY_STR))
-       && !(rx->reganch & ROPT_LOOKBEHIND_SEEN)) {
+    if (c
+#ifdef PERL_COPY_ON_WRITE
+       && !is_cow
+#endif
+       && (I32)clen <= rx->minlen && (once || !(r_flags & REXEC_COPY_STR))
+       && !(rx->reganch & ROPT_LOOKBEHIND_SEEN)
+       && (!doutf8 || SvUTF8(TARG))) {

        if (!CALLREGEXEC(aTHX_ rx, s, strend, orig, 0, TARG, NULL,
                         r_flags | REXEC_CHECKED))
        {
        if (!CALLREGEXEC(aTHX_ rx, s, strend, orig, 0, TARG, NULL,
                         r_flags | REXEC_CHECKED))
        {


@@ -1985,6 +2073,12 @@ PP(pp_subst)
            LEAVE_SCOPE(oldsave);
            RETURN;
        }
            LEAVE_SCOPE(oldsave);
            RETURN;
        }

+#ifdef PERL_COPY_ON_WRITE
+       if (SvIsCOW(TARG)) {
+           assert (!force_on_match);
+           goto have_a_cow;
+       }
+#endif

        if (force_on_match) {
            force_on_match = 0;
            s = SvPV_force(TARG, len);
        if (force_on_match) {
            force_on_match = 0;
            s = SvPV_force(TARG, len);


@@ -2086,6 +2180,9 @@ PP(pp_subst)
            s = SvPV_force(TARG, len);
            goto force_it;
        }
            s = SvPV_force(TARG, len);
            goto force_it;
        }

+#ifdef PERL_COPY_ON_WRITE
+      have_a_cow:
+#endif

        rxtainted |= RX_MATCH_TAINTED(rx);
        dstr = NEWSV(25, len);
        sv_setpvn(dstr, m, s-m);
        rxtainted |= RX_MATCH_TAINTED(rx);
        dstr = NEWSV(25, len);
        sv_setpvn(dstr, m, s-m);


@@ -2095,6 +2192,7 @@ PP(pp_subst)
        if (!c) {
            register PERL_CONTEXT *cx;
            SPAGAIN;
        if (!c) {
            register PERL_CONTEXT *cx;
            SPAGAIN;

+           ReREFCNT_inc(rx);

            PUSHSUBST(cx);
            RETURNOP(cPMOP->op_pmreplroot);
        }
            PUSHSUBST(cx);
            RETURNOP(cPMOP->op_pmreplroot);
        }


@@ -2111,7 +2209,10 @@ PP(pp_subst)
                strend = s + (strend - m);
            }
            m = rx->startp[0] + orig;
                strend = s + (strend - m);
            }
            m = rx->startp[0] + orig;

-           sv_catpvn(dstr, s, m-s);
+           if (doutf8 && !SvUTF8(dstr))
+               sv_catpvn_utf8_upgrade(dstr, s, m - s, nsv);
+            else
+               sv_catpvn(dstr, s, m-s);

            s = rx->endp[0] + orig;
            if (clen)
                sv_catpvn(dstr, c, clen);
            s = rx->endp[0] + orig;
            if (clen)
                sv_catpvn(dstr, c, clen);


@@ -2119,17 +2220,26 @@ PP(pp_subst)
                break;
        } while (CALLREGEXEC(aTHX_ rx, s, strend, orig, s == m,
                             TARG, NULL, r_flags));
                break;
        } while (CALLREGEXEC(aTHX_ rx, s, strend, orig, s == m,
                             TARG, NULL, r_flags));

-       if (doutf8 && !DO_UTF8(dstr)) {
-           SV* nsv = sv_2mortal(newSVpvn(s, strend - s));
-           
-           sv_utf8_upgrade(nsv);
-           sv_catpvn(dstr, SvPVX(nsv), SvCUR(nsv));
-       }
+       if (doutf8 && !DO_UTF8(TARG))
+           sv_catpvn_utf8_upgrade(dstr, s, strend - s, nsv);

        else
            sv_catpvn(dstr, s, strend - s);
 
        else
            sv_catpvn(dstr, s, strend - s);
 

-       (void)SvOOK_off(TARG);
-       Safefree(SvPVX(TARG));
+#ifdef PERL_COPY_ON_WRITE
+       /* The match may make the string COW. If so, brilliant, because that's
+          just saved us one malloc, copy and free - the regexp has donated
+          the old buffer, and we malloc an entirely new one, rather than the
+          regexp malloc()ing a buffer and copying our original, only for
+          us to throw it away here during the substitution.  */
+       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));
        SvPVX(TARG) = SvPVX(dstr);
        SvCUR_set(TARG, SvCUR(dstr));
        SvLEN_set(TARG, SvLEN(dstr));


@@ -2212,6 +2322,7 @@ PP(pp_leavesub)
     SV *sv;
 
     POPBLOCK(cx,newpm);
     SV *sv;
 
     POPBLOCK(cx,newpm);

+    cxstack_ix++; /* temporarily protect top context */

 
     TAINT_NOT;
     if (gimme == G_SCALAR) {
 
     TAINT_NOT;
     if (gimme == G_SCALAR) {


@@ -2249,10 +2360,11 @@ PP(pp_leavesub)
     }
     PUTBACK;
 
     }
     PUTBACK;
 

+    LEAVE;
+    cxstack_ix--;

     POPSUB(cx,sv);     /* Stack values are safe: release CV and @_ ... */
     PL_curpm = newpm;  /* ... and pop $1 et al */
 
     POPSUB(cx,sv);     /* Stack values are safe: release CV and @_ ... */
     PL_curpm = newpm;  /* ... and pop $1 et al */
 

-    LEAVE;

     LEAVESUB(sv);
     return pop_return();
 }
     LEAVESUB(sv);
     return pop_return();
 }


@@ -2270,6 +2382,7 @@ PP(pp_leavesublv)
     SV *sv;
 
     POPBLOCK(cx,newpm);
     SV *sv;
 
     POPBLOCK(cx,newpm);

+    cxstack_ix++; /* temporarily protect top context */

 
     TAINT_NOT;
 
 
     TAINT_NOT;
 


@@ -2305,9 +2418,10 @@ PP(pp_leavesublv)
         * the refcounts so the caller gets a live guy. Cannot set
         * TEMP, so sv_2mortal is out of question. */
        if (!CvLVALUE(cx->blk_sub.cv)) {
         * the refcounts so the caller gets a live guy. Cannot set
         * TEMP, so sv_2mortal is out of question. */
        if (!CvLVALUE(cx->blk_sub.cv)) {

+           LEAVE;
+           cxstack_ix--;

            POPSUB(cx,sv);
            PL_curpm = newpm;
            POPSUB(cx,sv);
            PL_curpm = newpm;

-           LEAVE;

            LEAVESUB(sv);
            DIE(aTHX_ "Can't modify non-lvalue subroutine call");
        }
            LEAVESUB(sv);
            DIE(aTHX_ "Can't modify non-lvalue subroutine call");
        }


@@ -2316,9 +2430,10 @@ PP(pp_leavesublv)
            EXTEND_MORTAL(1);
            if (MARK == SP) {
                if (SvFLAGS(TOPs) & (SVs_TEMP | SVs_PADTMP | SVf_READONLY)) {
            EXTEND_MORTAL(1);
            if (MARK == SP) {
                if (SvFLAGS(TOPs) & (SVs_TEMP | SVs_PADTMP | SVf_READONLY)) {

+                   LEAVE;
+                   cxstack_ix--;

                    POPSUB(cx,sv);
                    PL_curpm = newpm;
                    POPSUB(cx,sv);
                    PL_curpm = newpm;

-                   LEAVE;

                    LEAVESUB(sv);
                    DIE(aTHX_ "Can't return %s from lvalue subroutine",
                        SvREADONLY(TOPs) ? (TOPs == &PL_sv_undef) ? "undef"
                    LEAVESUB(sv);
                    DIE(aTHX_ "Can't return %s from lvalue subroutine",
                        SvREADONLY(TOPs) ? (TOPs == &PL_sv_undef) ? "undef"


@@ -2331,9 +2446,10 @@ PP(pp_leavesublv)
                }
            }
            else {                      /* Should not happen? */
                }
            }
            else {                      /* Should not happen? */

+               LEAVE;
+               cxstack_ix--;

                POPSUB(cx,sv);
                PL_curpm = newpm;
                POPSUB(cx,sv);
                PL_curpm = newpm;

-               LEAVE;

                LEAVESUB(sv);
                DIE(aTHX_ "%s returned from lvalue subroutine in scalar context",
                    (MARK > SP ? "Empty array" : "Array"));
                LEAVESUB(sv);
                DIE(aTHX_ "%s returned from lvalue subroutine in scalar context",
                    (MARK > SP ? "Empty array" : "Array"));


@@ -2347,9 +2463,10 @@ PP(pp_leavesublv)
                    && SvFLAGS(*mark) & (SVs_TEMP | SVs_PADTMP | SVf_READONLY)) {
                    /* Might be flattened array after $#array =  */
                    PUTBACK;
                    && SvFLAGS(*mark) & (SVs_TEMP | SVs_PADTMP | SVf_READONLY)) {
                    /* Might be flattened array after $#array =  */
                    PUTBACK;

+                   LEAVE;
+                   cxstack_ix--;

                    POPSUB(cx,sv);
                    PL_curpm = newpm;
                    POPSUB(cx,sv);
                    PL_curpm = newpm;

-                   LEAVE;

                    LEAVESUB(sv);
                    DIE(aTHX_ "Can't return a %s from lvalue subroutine",
                        SvREADONLY(TOPs) ? "readonly value" : "temporary");
                    LEAVESUB(sv);
                    DIE(aTHX_ "Can't return a %s from lvalue subroutine",
                        SvREADONLY(TOPs) ? "readonly value" : "temporary");


@@ -2401,10 +2518,11 @@ PP(pp_leavesublv)
     }
     PUTBACK;
 
     }
     PUTBACK;
 

+    LEAVE;
+    cxstack_ix--;

     POPSUB(cx,sv);     /* Stack values are safe: release CV and @_ ... */
     PL_curpm = newpm;  /* ... and pop $1 et al */
 
     POPSUB(cx,sv);     /* Stack values are safe: release CV and @_ ... */
     PL_curpm = newpm;  /* ... and pop $1 et al */
 

-    LEAVE;

     LEAVESUB(sv);
     return pop_return();
 }
     LEAVESUB(sv);
     return pop_return();
 }


@@ -2523,6 +2641,9 @@ PP(pp_entersub)
 
     gimme = GIMME_V;
     if ((PL_op->op_private & OPpENTERSUB_DB) && GvCV(PL_DBsub) && !CvNODEBUG(cv)) {
 
     gimme = GIMME_V;
     if ((PL_op->op_private & OPpENTERSUB_DB) && GvCV(PL_DBsub) && !CvNODEBUG(cv)) {

+        if (CvASSERTION(cv) && PL_DBassertion)
+           sv_setiv(PL_DBassertion, 1);
+       

        cv = get_db_sub(&sv, cv);
        if (!cv)
            DIE(aTHX_ "No DBsub routine");
        cv = get_db_sub(&sv, cv);
        if (!cv)
            DIE(aTHX_ "No DBsub routine");


@@ -2817,7 +2938,7 @@ PP(pp_method)
 PP(pp_method_named)
 {
     dSP;
 PP(pp_method_named)
 {
     dSP;

-    SV* sv = cSVOP->op_sv;
+    SV* sv = cSVOP_sv;

     U32 hash = SvUVX(sv);
 
     XPUSHs(method_common(sv, &hash));
     U32 hash = SvUVX(sv);
 
     XPUSHs(method_common(sv, &hash));


@@ -2852,8 +2973,18 @@ S_method_common(pTHX_ SV* meth, U32* hashp)
 
        /* this isn't a reference */
        packname = Nullch;
 
        /* this isn't a reference */
        packname = Nullch;

+
+        if(SvOK(sv) && (packname = SvPV(sv, packlen))) {
+          HE* he;
+         he = hv_fetch_ent(PL_stashcache, sv, 0, 0);
+          if (he) { 
+            stash = INT2PTR(HV*,SvIV(HeVAL(he)));
+            goto fetch;
+          }
+        }
+

        if (!SvOK(sv) ||
        if (!SvOK(sv) ||

-           !(packname = SvPV(sv, packlen)) ||
+           !(packname) ||

            !(iogv = gv_fetchpv(packname, FALSE, SVt_PVIO)) ||
            !(ob=(SV*)GvIO(iogv)))
        {
            !(iogv = gv_fetchpv(packname, FALSE, SVt_PVIO)) ||
            !(ob=(SV*)GvIO(iogv)))
        {


@@ -2872,6 +3003,10 @@ S_method_common(pTHX_ SV* meth, U32* hashp)
            stash = gv_stashpvn(packname, packlen, FALSE);
            if (!stash)
                packsv = sv;
            stash = gv_stashpvn(packname, packlen, FALSE);
            if (!stash)
                packsv = sv;

+            else {
+               SV* ref = newSViv(PTR2IV(stash));
+               hv_store(PL_stashcache, packname, packlen, ref, 0);
+           }

            goto fetch;
        }
        /* it _is_ a filehandle name -- replace with a reference */
            goto fetch;
        }
        /* it _is_ a filehandle name -- replace with a reference */


@@ -2928,7 +3063,11 @@ S_method_common(pTHX_ SV* meth, U32* hashp)
            /* the method name is unqualified or starts with SUPER:: */ 
            packname = sep ? CopSTASHPV(PL_curcop) :
                stash ? HvNAME(stash) : packname;
            /* the method name is unqualified or starts with SUPER:: */ 
            packname = sep ? CopSTASHPV(PL_curcop) :
                stash ? HvNAME(stash) : packname;

-           packlen = strlen(packname);
+           if (!packname)
+               Perl_croak(aTHX_
+                          "Can't use anonymous symbol table for method lookup");
+           else
+               packlen = strlen(packname);

        }
        else {
            /* the method name is qualified */
        }
        else {
            /* the method name is qualified */