Update copyrights for files modified in 2006
[p5sagit/p5-mst-13.2.git] / sv.c
diff --git a/sv.c b/sv.c
index b2a2fef..baaba9f 100644 (file)
--- a/sv.c
+++ b/sv.c
@@ -1,7 +1,7 @@
 /*    sv.c
  *
  *    Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
- *    2000, 2001, 2002, 2003, 2004, 2005, by Larry Wall and others
+ *    2000, 2001, 2002, 2003, 2004, 2005, 2006, 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.
@@ -520,7 +520,7 @@ do_clean_all(pTHX_ SV *sv)
     DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning loops: SV at 0x%"UVxf"\n", PTR2UV(sv)) ));
     SvFLAGS(sv) |= SVf_BREAK;
     if (PL_comppad == (AV*)sv) {
-       PL_comppad = Nullav;
+       PL_comppad = NULL;
        PL_curpad = Null(SV**);
     }
     SvREFCNT_dec(sv);
@@ -809,14 +809,14 @@ static const struct body_details bodies_by_type[] = {
     /* 8 bytes on most ILP32 with IEEE doubles */
     {sizeof(xpv_allocated),
      copy_length(XPV, xpv_len)
-     + relative_STRUCT_OFFSET(XPV, xpv_allocated, xpv_cur),
-     - relative_STRUCT_OFFSET(XPV, xpv_allocated, xpv_cur),
+     - relative_STRUCT_OFFSET(xpv_allocated, XPV, xpv_cur),
+     + relative_STRUCT_OFFSET(xpv_allocated, XPV, xpv_cur),
      FALSE, NONV, HASARENA},
     /* 12 */
     {sizeof(xpviv_allocated),
      copy_length(XPVIV, xiv_u)
-     + relative_STRUCT_OFFSET(XPVIV, xpviv_allocated, xpv_cur),
-     - relative_STRUCT_OFFSET(XPVIV, xpviv_allocated, xpv_cur),
+     - relative_STRUCT_OFFSET(xpviv_allocated, XPVIV, xpv_cur),
+     + relative_STRUCT_OFFSET(xpviv_allocated, XPVIV, xpv_cur),
      FALSE, NONV, HASARENA},
     /* 20 */
     {sizeof(XPVNV), copy_length(XPVNV, xiv_u), 0, FALSE, HADNV, HASARENA},
@@ -831,14 +831,14 @@ static const struct body_details bodies_by_type[] = {
     /* 20 */
     {sizeof(xpvav_allocated),
      copy_length(XPVAV, xmg_stash)
-     + relative_STRUCT_OFFSET(XPVAV, xpvav_allocated, xav_fill),
-     - relative_STRUCT_OFFSET(XPVAV, xpvav_allocated, xav_fill),
+     - relative_STRUCT_OFFSET(xpvav_allocated, XPVAV, xav_fill),
+     + relative_STRUCT_OFFSET(xpvav_allocated, XPVAV, xav_fill),
      TRUE, HADNV, HASARENA},
     /* 20 */
     {sizeof(xpvhv_allocated),
      copy_length(XPVHV, xmg_stash)
-     + relative_STRUCT_OFFSET(XPVHV, xpvhv_allocated, xhv_fill),
-     - relative_STRUCT_OFFSET(XPVHV, xpvhv_allocated, xhv_fill),
+     - relative_STRUCT_OFFSET(xpvhv_allocated, XPVHV, xhv_fill),
+     + relative_STRUCT_OFFSET(xpvhv_allocated, XPVHV, xhv_fill),
      TRUE, HADNV, HASARENA},
     /* 76 */
     {sizeof(XPVCV), sizeof(XPVCV), 0, TRUE, HADNV, HASARENA},
@@ -1915,8 +1915,7 @@ Perl_sv_2iv_flags(pTHX_ register SV *sv, I32 flags)
        }
        assert(SvTYPE(sv) >= SVt_PVMG);
        /* This falls through to the report_uninit inside S_sv_2iuv_common.  */
-    }
-    if (SvTHINKFIRST(sv)) {
+    } else if (SvTHINKFIRST(sv)) {
        if (SvROK(sv)) {
        return_rok:
            if (SvAMAGIC(sv)) {
@@ -1989,8 +1988,7 @@ Perl_sv_2uv_flags(pTHX_ register SV *sv, I32 flags)
        }
        assert(SvTYPE(sv) >= SVt_PVMG);
        /* This falls through to the report_uninit inside S_sv_2iuv_common.  */
-    }
-    if (SvTHINKFIRST(sv)) {
+    } else if (SvTHINKFIRST(sv)) {
        if (SvROK(sv)) {
        return_rok:
            if (SvAMAGIC(sv)) {
@@ -2352,7 +2350,6 @@ char *
 Perl_sv_2pv_flags(pTHX_ register SV *sv, STRLEN *lp, I32 flags)
 {
     register char *s;
-    int olderrno;
 
     if (!sv) {
        if (lp)
@@ -2458,7 +2455,7 @@ Perl_sv_2pv_flags(pTHX_ register SV *sv, STRLEN *lp, I32 flags)
                                (SVs_OBJECT|SVf_OK|SVs_GMG|SVs_SMG|SVs_RMG))
                               == (SVs_OBJECT|SVs_SMG))
                           && (mg = mg_find(referent, PERL_MAGIC_qr))) {
-                   return S_stringify_regexp(aTHX_ sv, mg, lp);
+                   return stringify_regexp(sv, mg, lp);
                } else {
                    const char *const typestr = sv_reftype(referent, 0);
 
@@ -2496,10 +2493,7 @@ Perl_sv_2pv_flags(pTHX_ register SV *sv, STRLEN *lp, I32 flags)
 
        if (SvTYPE(sv) < SVt_PVIV)
            sv_upgrade(sv, SVt_PVIV);
-       if (isUIOK)
-           ptr = uiv_2buf(buf, 0, SvUVX(sv), 1, &ebuf);
-       else
-           ptr = uiv_2buf(buf, SvIVX(sv), 0, 0, &ebuf);
+       ptr = uiv_2buf(buf, SvIVX(sv), SvUVX(sv), isUIOK, &ebuf);
        /* inlined from sv_setpvn */
        SvGROW_mutable(sv, (STRLEN)(ebuf - ptr + 1));
        Move(ptr,SvPVX_mutable(sv),ebuf - ptr,char);
@@ -2514,11 +2508,12 @@ Perl_sv_2pv_flags(pTHX_ register SV *sv, STRLEN *lp, I32 flags)
            SvIsUV_on(sv);
     }
     else if (SvNOKp(sv)) {
+       const int olderrno = errno;
        if (SvTYPE(sv) < SVt_PVNV)
            sv_upgrade(sv, SVt_PVNV);
        /* The +20 is pure guesswork.  Configure test needed. --jhi */
        s = SvGROW_mutable(sv, NV_DIG + 20);
-       olderrno = errno;       /* some Xenix systems wipe out errno here */
+       /* some Xenix systems wipe out errno here */
 #ifdef apollo
        if (SvNVX(sv) == 0.0)
            (void)strcpy(s,"0");
@@ -2645,11 +2640,12 @@ Perl_sv_2bool(pTHX_ register SV *sv)
     if (!SvOK(sv))
        return 0;
     if (SvROK(sv)) {
-       SV* tmpsv;
-        if (SvAMAGIC(sv) && (tmpsv=AMG_CALLun(sv,bool_)) &&
-                (!SvROK(tmpsv) || (SvRV(tmpsv) != SvRV(sv))))
-           return (bool)SvTRUE(tmpsv);
-      return SvRV(sv) != 0;
+       if (SvAMAGIC(sv)) {
+           SV * const tmpsv = AMG_CALLun(sv,bool_);
+           if (tmpsv && (!SvROK(tmpsv) || (SvRV(tmpsv) != SvRV(sv))))
+               return (bool)SvTRUE(tmpsv);
+       }
+       return SvRV(sv) != 0;
     }
     if (SvPOKp(sv)) {
        register XPV* const Xpvtmp = (XPV*)SvANY(sv);
@@ -3089,7 +3085,7 @@ Perl_sv_setsv_flags(pTHX_ SV *dstr, register SV *sstr, I32 flags)
        if (dtype >= SVt_PV) {
            if (dtype == SVt_PVGV) {
                SV * const sref = SvREFCNT_inc(SvRV(sstr));
-               SV *dref = 0;
+               SV *dref = NULL;
                const int intro = GvINTRO(dstr);
 
 #ifdef GV_UNIQUE_CHECK
@@ -3149,7 +3145,18 @@ Perl_sv_setsv_flags(pTHX_ SV *dstr, register SV *sstr, I32 flags)
                            {
                                /* Redefining a sub - warning is mandatory if
                                   it was a const and its value changed. */
-                               if (ckWARN(WARN_REDEFINE)
+                               if (CvCONST(cv) && CvCONST((CV*)sref)
+                                   && cv_const_sv(cv)
+                                   == cv_const_sv((CV*)sref)) {
+                                   /* They are 2 constant subroutines
+                                      generated from the same constant.
+                                      This probably means that they are
+                                      really the "same" proxy subroutine
+                                      instantiated in 2 places. Most likely
+                                      this is when a constant is exported
+                                      twice.  Don't warn.  */
+                               }
+                               else if (ckWARN(WARN_REDEFINE)
                                    || (CvCONST(cv)
                                        && (!CvCONST((CV*)sref)
                                            || sv_cmp(cv_const_sv(cv),
@@ -3851,7 +3858,7 @@ void
 Perl_sv_catpvn_flags(pTHX_ register SV *dsv, register const char *sstr, register STRLEN slen, I32 flags)
 {
     STRLEN dlen;
-    const char *dstr = SvPV_force_flags(dsv, dlen, flags);
+    const char * const dstr = SvPV_force_flags(dsv, dlen, flags);
 
     SvGROW(dsv, dlen + slen + 1);
     if (sstr == dstr)
@@ -4298,7 +4305,8 @@ Perl_sv_unmagic(pTHX_ SV *sv, int type)
     }
     if (!SvMAGIC(sv)) {
        SvMAGICAL_off(sv);
-       SvFLAGS(sv) |= (SvFLAGS(sv) & (SVp_NOK|SVp_POK)) >> PRIVSHIFT;
+       SvFLAGS(sv) |= (SvFLAGS(sv) & (SVp_NOK|SVp_POK)) >> PRIVSHIFT;
+       SvMAGIC_set(sv, NULL);
     }
 
     return 0;
@@ -4343,15 +4351,44 @@ void
 Perl_sv_add_backref(pTHX_ SV *tsv, SV *sv)
 {
     AV *av;
-    MAGIC *mg;
-    if (SvMAGICAL(tsv) && (mg = mg_find(tsv, PERL_MAGIC_backref)))
-       av = (AV*)mg->mg_obj;
-    else {
-       av = newAV();
-       sv_magic(tsv, (SV*)av, PERL_MAGIC_backref, NULL, 0);
-       /* av now has a refcnt of 2, which avoids it getting freed
-        * before us during global cleanup. The extra ref is removed
-        * by magic_killbackrefs() when tsv is being freed */
+
+    if (SvTYPE(tsv) == SVt_PVHV) {
+       AV **const avp = Perl_hv_backreferences_p(aTHX_ (HV*)tsv);
+
+       av = *avp;
+       if (!av) {
+           /* There is no AV in the offical place - try a fixup.  */
+           MAGIC *const mg = mg_find(tsv, PERL_MAGIC_backref);
+
+           if (mg) {
+               /* Aha. They've got it stowed in magic.  Bring it back.  */
+               av = (AV*)mg->mg_obj;
+               /* Stop mg_free decreasing the refernce count.  */
+               mg->mg_obj = NULL;
+               /* Stop mg_free even calling the destructor, given that
+                  there's no AV to free up.  */
+               mg->mg_virtual = 0;
+               sv_unmagic(tsv, PERL_MAGIC_backref);
+           } else {
+               av = newAV();
+               AvREAL_off(av);
+               SvREFCNT_inc(av);
+           }
+           *avp = av;
+       }
+    } else {
+       const MAGIC *const mg
+           = SvMAGICAL(tsv) ? mg_find(tsv, PERL_MAGIC_backref) : NULL;
+       if (mg)
+           av = (AV*)mg->mg_obj;
+       else {
+           av = newAV();
+           AvREAL_off(av);
+           sv_magic(tsv, (SV*)av, PERL_MAGIC_backref, NULL, 0);
+           /* av now has a refcnt of 2, which avoids it getting freed
+            * before us during global cleanup. The extra ref is removed
+            * by magic_killbackrefs() when tsv is being freed */
+       }
     }
     if (AvFILLp(av) >= AvMAX(av)) {
         av_extend(av, AvFILLp(av)+1);
@@ -4366,17 +4403,32 @@ Perl_sv_add_backref(pTHX_ SV *tsv, SV *sv)
 STATIC void
 S_sv_del_backref(pTHX_ SV *tsv, SV *sv)
 {
-    AV *av;
+    AV *av = NULL;
     SV **svp;
     I32 i;
-    MAGIC *mg = NULL;
-    if (!SvMAGICAL(tsv) || !(mg = mg_find(tsv, PERL_MAGIC_backref))) {
+
+    if (SvTYPE(tsv) == SVt_PVHV && SvOOK(tsv)) {
+       av = *Perl_hv_backreferences_p(aTHX_ (HV*)tsv);
+       /* We mustn't attempt to "fix up" the hash here by moving the
+          backreference array back to the hv_aux structure, as that is stored
+          in the main HvARRAY(), and hfreentries assumes that no-one
+          reallocates HvARRAY() while it is running.  */
+    }
+    if (!av) {
+       const MAGIC *const mg
+           = SvMAGICAL(tsv) ? mg_find(tsv, PERL_MAGIC_backref) : NULL;
+       if (mg)
+           av = (AV *)mg->mg_obj;
+    }
+    if (!av) {
        if (PL_in_clean_all)
            return;
-    }
-    if (!SvMAGICAL(tsv) || !(mg = mg_find(tsv, PERL_MAGIC_backref)))
        Perl_croak(aTHX_ "panic: del_backref");
-    av = (AV *)mg->mg_obj;
+    }
+
+    if (SvIS_FREED(av))
+       return;
+
     svp = AvARRAY(av);
     /* We shouldn't be in here more than once, but for paranoia reasons lets
        not assume this.  */
@@ -4397,6 +4449,47 @@ S_sv_del_backref(pTHX_ SV *tsv, SV *sv)
     }
 }
 
+int
+Perl_sv_kill_backrefs(pTHX_ SV *sv, AV *av)
+{
+    SV **svp = AvARRAY(av);
+
+    PERL_UNUSED_ARG(sv);
+
+    /* Not sure why the av can get freed ahead of its sv, but somehow it does
+       in ext/B/t/bytecode.t test 15 (involving print <DATA>)  */
+    if (svp && !SvIS_FREED(av)) {
+       SV *const *const last = svp + AvFILLp(av);
+
+       while (svp <= last) {
+           if (*svp) {
+               SV *const referrer = *svp;
+               if (SvWEAKREF(referrer)) {
+                   /* XXX Should we check that it hasn't changed? */
+                   SvRV_set(referrer, 0);
+                   SvOK_off(referrer);
+                   SvWEAKREF_off(referrer);
+               } else if (SvTYPE(referrer) == SVt_PVGV ||
+                          SvTYPE(referrer) == SVt_PVLV) {
+                   /* You lookin' at me?  */
+                   assert(GvSTASH(referrer));
+                   assert(GvSTASH(referrer) == (HV*)sv);
+                   GvSTASH(referrer) = 0;
+               } else {
+                   Perl_croak(aTHX_
+                              "panic: magic_killbackrefs (flags=%"UVxf")",
+                              (UV)SvFLAGS(referrer));
+               }
+
+               *svp = Nullsv;
+           }
+           svp++;
+       }
+    }
+    SvREFCNT_dec(av); /* remove extra count added by sv_add_backref() */
+    return 0;
+}
+
 /*
 =for apidoc sv_insert
 
@@ -4678,6 +4771,7 @@ Perl_sv_clear(pTHX_ register SV *sv)
        cv_undef((CV*)sv);
        goto freescalar;
     case SVt_PVHV:
+       Perl_hv_kill_backrefs(aTHX_ (HV*)sv);
        hv_undef((HV*)sv);
        break;
     case SVt_PVAV:
@@ -5103,15 +5197,13 @@ Perl_sv_pos_u2b(pTHX_ register SV *sv, I32* offsetp, I32* lenp)
     start = (U8*)SvPV_const(sv, len);
     if (len) {
        STRLEN boffset = 0;
-       STRLEN *cache = 0;
+       STRLEN *cache = NULL;
        const U8 *s = start;
        I32 uoffset = *offsetp;
        const U8 * const send = s + len;
-       MAGIC *mg = 0;
-       bool found = FALSE;
+       MAGIC *mg = NULL;
+       bool found = utf8_mg_pos(sv, &mg, &cache, 0, offsetp, *offsetp, &s, start, send);
 
-         if (utf8_mg_pos(sv, &mg, &cache, 0, offsetp, *offsetp, &s, start, send))
-             found = TRUE;
         if (!found && uoffset > 0) {
              while (s < send && uoffset--)
                   s += UTF8SKIP(s);
@@ -5861,7 +5953,7 @@ thats_really_all_folks:
     {
        /*The big, slow, and stupid way. */
 #ifdef USE_HEAP_INSTEAD_OF_STACK       /* Even slower way. */
-       STDCHAR *buf = 0;
+       STDCHAR *buf = NULL;
        Newx(buf, 8192, STDCHAR);
        assert(buf);
 #else
@@ -6268,7 +6360,7 @@ Perl_sv_2mortal(pTHX_ register SV *sv)
 {
     dVAR;
     if (!sv)
-       return sv;
+       return NULL;
     if (SvREADONLY(sv) && SvIMMORTAL(sv))
        return sv;
     EXTEND_MORTAL(1);
@@ -6570,7 +6662,7 @@ Perl_newSVsv(pTHX_ register SV *old)
     register SV *sv;
 
     if (!old)
-       return Nullsv;
+       return NULL;
     if (SvTYPE(old) == SVTYPEMASK) {
         if (ckWARN_d(WARN_INTERNAL))
            Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "semi-panic: attempt to dup freed string");
@@ -6709,7 +6801,7 @@ Perl_sv_2io(pTHX_ SV *sv)
            Perl_croak(aTHX_ PL_no_usym, "filehandle");
        if (SvROK(sv))
            return sv_2io(SvRV(sv));
-       gv = gv_fetchsv(sv, FALSE, SVt_PVIO);
+       gv = gv_fetchsv(sv, 0, SVt_PVIO);
        if (gv)
            io = GvIO(gv);
        else
@@ -6726,6 +6818,7 @@ Perl_sv_2io(pTHX_ SV *sv)
 
 Using various gambits, try to get a CV from an SV; in addition, try if
 possible to set C<*st> and C<*gvp> to the stash and GV associated with it.
+The flags in C<lref> are passed to sv_fetchsv.
 
 =cut
 */
@@ -6738,7 +6831,7 @@ Perl_sv_2cv(pTHX_ SV *sv, HV **st, GV **gvp, I32 lref)
     CV *cv = Nullcv;
 
     if (!sv)
-       return *gvp = Nullgv, Nullcv;
+       return *st = NULL, *gvp = Nullgv, Nullcv;
     switch (SvTYPE(sv)) {
     case SVt_PVCV:
        *st = CvSTASH(sv);
@@ -6746,6 +6839,7 @@ Perl_sv_2cv(pTHX_ SV *sv, HV **st, GV **gvp, I32 lref)
        return (CV*)sv;
     case SVt_PVHV:
     case SVt_PVAV:
+       *st = NULL;
        *gvp = Nullgv;
        return Nullcv;
     case SVt_PVGV:
@@ -6777,8 +6871,15 @@ Perl_sv_2cv(pTHX_ SV *sv, HV **st, GV **gvp, I32 lref)
        else
            gv = gv_fetchsv(sv, lref, SVt_PVCV);
        *gvp = gv;
-       if (!gv)
+       if (!gv) {
+           *st = NULL;
            return Nullcv;
+       }
+       /* Some flags to gv_fetchsv mean don't really create the GV  */
+       if (SvTYPE(gv) != SVt_PVGV) {
+           *st = NULL;
+           return NULL;
+       }
        *st = GvESTASH(gv);
     fix_gv:
        if (lref && !GvCVu(gv)) {
@@ -7261,7 +7362,7 @@ S_sv_unglob(pTHX_ SV *sv)
        gp_free((GV*)sv);
     if (GvSTASH(sv)) {
        sv_del_backref((SV*)GvSTASH(sv), sv);
-       GvSTASH(sv) = Nullhv;
+       GvSTASH(sv) = NULL;
     }
     sv_unmagic(sv, PERL_MAGIC_glob);
     Safefree(GvNAME(sv));
@@ -7607,8 +7708,6 @@ Perl_sv_vsetpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV
     sv_vcatpvfn(sv, pat, patlen, args, svargs, svmax, maybe_tainted);
 }
 
-/* private function for use in sv_vcatpvfn via the EXPECT_NUMBER macro */
-
 STATIC I32
 S_expect_number(pTHX_ char** pattern)
 {
@@ -7627,10 +7726,9 @@ S_expect_number(pTHX_ char** pattern)
     }
     return var;
 }
-#define EXPECT_NUMBER(pattern, var) (var = S_expect_number(aTHX_ &pattern))
 
-static char *
-F0convert(NV nv, char *endbuf, STRLEN *len)
+STATIC char *
+S_F0convert(NV nv, char *endbuf, STRLEN *len)
 {
     const int neg = nv < 0;
     UV uv;
@@ -7779,7 +7877,7 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV
        STRLEN zeros = 0;
        bool has_precis = FALSE;
        STRLEN precis = 0;
-       I32 osvix = svix;
+       const I32 osvix = svix;
        bool is_utf8 = FALSE;  /* is this item utf8?   */
 #ifdef HAS_LDBL_SPRINTF_BUG
        /* This is to try to fix a bug with irix/nonstop-ux/powerux and
@@ -7866,7 +7964,7 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV
            STRLEN n = 0;
            if (*q == '-')
                sv = *q++;
-           EXPECT_NUMBER(q, n);
+           n = expect_number(&q);
            if (*q++ == 'p') {
                if (sv) {                       /* SVf */
                    if (n) {
@@ -7895,7 +7993,7 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV
            q = r; 
        }
 
-       if (EXPECT_NUMBER(q, width)) {
+       if ( (width = expect_number(&q)) ) {
            if (*q == '$') {
                ++q;
                efix = width;
@@ -7936,7 +8034,7 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV
       tryasterisk:
        if (*q == '*') {
            q++;
-           if (EXPECT_NUMBER(q, ewix))
+           if ( (ewix = expect_number(&q)) )
                if (*q++ != '$')
                    goto unknown;
            asterisk = TRUE;
@@ -7958,7 +8056,7 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV
        {
            if( *q == '0' )
                fill = *q++;
-           EXPECT_NUMBER(q, width);
+           width = expect_number(&q);
        }
 
        if (vectorize) {
@@ -8032,7 +8130,7 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV
            q++;
            if (*q == '*') {
                q++;
-               if (EXPECT_NUMBER(q, epix) && *q++ != '$')
+               if ( ((epix = expect_number(&q))) && (*q++ != '$') )
                    goto unknown;
                /* XXX: todo, support specified precision parameter */
                if (epix)
@@ -8980,15 +9078,9 @@ Perl_mg_dup(pTHX_ MAGIC *mg, CLONE_PARAMS* param)
            nmg->mg_obj = (SV*)re_dup((REGEXP*)mg->mg_obj, param);
        }
        else if(mg->mg_type == PERL_MAGIC_backref) {
-           const AV * const av = (AV*) mg->mg_obj;
-           SV **svp;
-           I32 i;
-           (void)SvREFCNT_inc(nmg->mg_obj = (SV*)newAV());
-           svp = AvARRAY(av);
-           for (i = AvFILLp(av); i >= 0; i--) {
-               if (!svp[i]) continue;
-               av_push((AV*)nmg->mg_obj,sv_dup(svp[i],param));
-           }
+           /* The backref AV has its reference count deliberately bumped by
+              1.  */
+           nmg->mg_obj = SvREFCNT_inc(av_dup_inc((AV*) mg->mg_obj, param));
        }
        else if (mg->mg_type == PERL_MAGIC_symtab) {
            nmg->mg_obj = mg->mg_obj;
@@ -9006,7 +9098,7 @@ Perl_mg_dup(pTHX_ MAGIC *mg, CLONE_PARAMS* param)
                if (mg->mg_type == PERL_MAGIC_overload_table &&
                        AMT_AMAGIC((AMT*)mg->mg_ptr))
                {
-                   AMT * const amtp = (AMT*)mg->mg_ptr;
+                   const AMT * const amtp = (AMT*)mg->mg_ptr;
                    AMT * const namtp = (AMT*)nmg->mg_ptr;
                    I32 i;
                    for (i = 1; i < NofAMmeth; i++) {
@@ -9132,7 +9224,7 @@ void
 Perl_ptr_table_clear(pTHX_ PTR_TBL_t *tbl)
 {
     if (tbl && tbl->tbl_items) {
-       register PTR_TBL_ENT_t **array = tbl->tbl_ary;
+       register PTR_TBL_ENT_t * const * const array = tbl->tbl_ary;
        UV riter = tbl->tbl_max;
 
        do {
@@ -9164,7 +9256,7 @@ Perl_ptr_table_free(pTHX_ PTR_TBL_t *tbl)
 
 
 void
-Perl_rvpv_dup(pTHX_ SV *dstr, SV *sstr, CLONE_PARAMS* param)
+Perl_rvpv_dup(pTHX_ SV *dstr, const SV *sstr, CLONE_PARAMS* param)
 {
     if (SvROK(sstr)) {
        SvRV_set(dstr, SvWEAKREF(sstr)
@@ -9210,7 +9302,7 @@ Perl_rvpv_dup(pTHX_ SV *dstr, SV *sstr, CLONE_PARAMS* param)
 /* duplicate an SV of any type (including AV, HV etc) */
 
 SV *
-Perl_sv_dup(pTHX_ SV *sstr, CLONE_PARAMS* param)
+Perl_sv_dup(pTHX_ const SV *sstr, CLONE_PARAMS* param)
 {
     dVAR;
     SV *dstr;
@@ -9225,12 +9317,11 @@ Perl_sv_dup(pTHX_ SV *sstr, CLONE_PARAMS* param)
     if(param->flags & CLONEf_JOIN_IN) {
         /** We are joining here so we don't want do clone
            something that is bad **/
-       const char *hvname;
-
-        if(SvTYPE(sstr) == SVt_PVHV &&
-          (hvname = HvNAME_get(sstr))) {
-           /** don't clone stashes if they already exist **/
-           return (SV*)gv_stashpv(hvname,0);
+       if (SvTYPE(sstr) == SVt_PVHV) {
+           const char * const hvname = HvNAME_get(sstr);
+           if (hvname)
+               /** don't clone stashes if they already exist **/
+               return (SV*)gv_stashpv(hvname,0);
         }
     }
 
@@ -9435,7 +9526,7 @@ Perl_sv_dup(pTHX_ SV *sstr, CLONE_PARAMS* param)
                break;
            case SVt_PVHV:
                {
-                   HEK *hvname = 0;
+                   HEK *hvname = NULL;
 
                    if (HvARRAY((HV*)sstr)) {
                        STRLEN i = 0;
@@ -9468,6 +9559,12 @@ Perl_sv_dup(pTHX_ SV *sstr, CLONE_PARAMS* param)
                            daux->xhv_eiter = saux->xhv_eiter
                                ? he_dup(saux->xhv_eiter,
                                         (bool)!!HvSHAREKEYS(sstr), param) : 0;
+                           daux->xhv_backreferences = saux->xhv_backreferences
+                               ? (AV*) SvREFCNT_inc(
+                                                    sv_dup((SV*)saux->
+                                                           xhv_backreferences,
+                                                           param))
+                               : 0;
                        }
                    }
                    else {
@@ -9535,8 +9632,8 @@ Perl_cx_dup(pTHX_ PERL_CONTEXT *cxs, I32 ix, I32 max, CLONE_PARAMS* param)
     ptr_table_store(PL_ptr_table, cxs, ncxs);
 
     while (ix >= 0) {
-       PERL_CONTEXT *cx = &cxs[ix];
-       PERL_CONTEXT *ncx = &ncxs[ix];
+       PERL_CONTEXT * const cx = &cxs[ix];
+       PERL_CONTEXT * const ncx = &ncxs[ix];
        ncx->cx_type    = cx->cx_type;
        if (CxTYPE(cx) == CXt_SUBST) {
            Perl_croak(aTHX_ "Cloning substitution context is unimplemented");
@@ -9555,7 +9652,7 @@ Perl_cx_dup(pTHX_ PERL_CONTEXT *cxs, I32 ix, I32 max, CLONE_PARAMS* param)
                                           : cv_dup(cx->blk_sub.cv,param));
                ncx->blk_sub.argarray   = (cx->blk_sub.hasargs
                                           ? av_dup_inc(cx->blk_sub.argarray, param)
-                                          : Nullav);
+                                          : NULL);
                ncx->blk_sub.savearray  = av_dup_inc(cx->blk_sub.savearray, param);
                ncx->blk_sub.olddepth   = cx->blk_sub.olddepth;
                ncx->blk_sub.hasargs    = cx->blk_sub.hasargs;
@@ -10237,6 +10334,7 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags,
     PL_minus_p         = proto_perl->Iminus_p;
     PL_minus_l         = proto_perl->Iminus_l;
     PL_minus_a         = proto_perl->Iminus_a;
+    PL_minus_E         = proto_perl->Iminus_E;
     PL_minus_F         = proto_perl->Iminus_F;
     PL_doswitches      = proto_perl->Idoswitches;
     PL_dowarn          = proto_perl->Idowarn;
@@ -10272,20 +10370,20 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags,
     PL_regex_padav = newAV();
     {
        const I32 len = av_len((AV*)proto_perl->Iregex_padav);
-       SV** const regexen = AvARRAY((AV*)proto_perl->Iregex_padav);
+       SV* const * const regexen = AvARRAY((AV*)proto_perl->Iregex_padav);
        IV i;
        av_push(PL_regex_padav,
                sv_dup_inc(regexen[0],param));
        for(i = 1; i <= len; i++) {
-            if(SvREPADTMP(regexen[i])) {
-             av_push(PL_regex_padav, sv_dup_inc(regexen[i], param));
-            } else {
-               av_push(PL_regex_padav,
-                    SvREFCNT_inc(
-                        newSViv(PTR2IV(re_dup(INT2PTR(REGEXP *,
-                             SvIVX(regexen[i])), param)))
-                       ));
-           }
+           const SV * const regex = regexen[i];
+           SV * const sv =
+               SvREPADTMP(regex)
+                   ? sv_dup_inc(regex, param)
+                   : SvREFCNT_inc(
+                       newSViv(PTR2IV(re_dup(
+                               INT2PTR(REGEXP *, SvIVX(regex)), param))))
+               ;
+           av_push(PL_regex_padav, sv);
        }
     }
     PL_regex_pad = AvARRAY(PL_regex_padav);
@@ -10378,6 +10476,14 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags,
     }
     else
        PL_exitlist     = (PerlExitListEntry*)NULL;
+
+    PL_my_cxt_size = proto_perl->Imy_cxt_size;
+    if (PL_my_cxt_size) {
+       Newx(PL_my_cxt_list, PL_my_cxt_size, void *);
+       Copy(proto_perl->Imy_cxt_list, PL_my_cxt_list, PL_my_cxt_size, void *);
+    }
+    else
+       PL_my_cxt_list  = (void**)NULL;
     PL_modglobal       = hv_dup_inc(proto_perl->Imodglobal, param);
     PL_custom_op_names  = hv_dup_inc(proto_perl->Icustom_op_names,param);
     PL_custom_op_descs  = hv_dup_inc(proto_perl->Icustom_op_descs,param);
@@ -10580,7 +10686,7 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags,
 #endif
 
     /* swatch cache */
-    PL_last_swash_hv   = Nullhv;       /* reinits on demand */
+    PL_last_swash_hv   = NULL; /* reinits on demand */
     PL_last_swash_klen = 0;
     PL_last_swash_key[0]= '\0';
     PL_last_swash_tmps = (U8*)NULL;