Convert ext/ODBM_File/t/odbm.t to Test::More.

[perl5.git] / sv.c

diff --git a/sv.c b/sv.c
index fd8a82a..2cabf7b 100644 (file)
--- a/sv.c
+++ b/sv.c
@@ -123,10 +123,10 @@ called by visit() for each SV]):
     sv_report_used() / do_report_used()
                        dump all remaining SVs (debugging aid)
 
     sv_report_used() / do_report_used()
                        dump all remaining SVs (debugging aid)
 

-    sv_clean_objs() / do_clean_objs(),do_clean_named_objs()
+    sv_clean_objs() / do_clean_objs(),do_clean_named_objs(),
+                     do_clean_named_io_objs()

                        Attempt to free all objects pointed to by RVs,
                        Attempt to free all objects pointed to by RVs,

-                       and, unless DISABLE_DESTRUCTOR_KLUDGE is defined,
-                       try to do the same for all objects indirectly
+                       and try to do the same for all objects indirectly

                        referenced by typeglobs too.  Called once from
                        perl_destruct(), prior to calling sv_clean_all()
                        below.
                        referenced by typeglobs too.  Called once from
                        perl_destruct(), prior to calling sv_clean_all()
                        below.


@@ -147,8 +147,7 @@ Private API to rest of sv.c
 
     new_SV(),  del_SV(),
 
 
     new_SV(),  del_SV(),
 

-    new_XIV(), del_XIV(),
-    new_XNV(), del_XNV(),
+    new_XPVNV(), del_XPVGV(),

     etc
 
 Public API:
     etc
 
 Public API:


@@ -163,26 +162,6 @@ Public API:
  * "A time to plant, and a time to uproot what was planted..."
  */
 
  * "A time to plant, and a time to uproot what was planted..."
  */
 

-void
-Perl_offer_nice_chunk(pTHX_ void *const chunk, const U32 chunk_size)
-{
-    dVAR;
-    void *new_chunk;
-    U32 new_chunk_size;
-
-    PERL_ARGS_ASSERT_OFFER_NICE_CHUNK;
-
-    new_chunk = (void *)(chunk);
-    new_chunk_size = (chunk_size);
-    if (new_chunk_size > PL_nice_chunk_size) {
-       Safefree(PL_nice_chunk);
-       PL_nice_chunk = (char *) new_chunk;
-       PL_nice_chunk_size = new_chunk_size;
-    } else {
-       Safefree(chunk);
-    }
-}
-

 #ifdef PERL_MEM_LOG
 #  define MEM_LOG_NEW_SV(sv, file, line, func) \
            Perl_mem_log_new_sv(sv, file, line, func)
 #ifdef PERL_MEM_LOG
 #  define MEM_LOG_NEW_SV(sv, file, line, func) \
            Perl_mem_log_new_sv(sv, file, line, func)


@@ -255,17 +234,9 @@ S_more_sv(pTHX)
 {
     dVAR;
     SV* sv;
 {
     dVAR;
     SV* sv;

-
-    if (PL_nice_chunk) {
-       sv_add_arena(PL_nice_chunk, PL_nice_chunk_size, 0);
-       PL_nice_chunk = NULL;
-        PL_nice_chunk_size = 0;
-    }
-    else {
-       char *chunk;                /* must use New here to match call to */
-       Newx(chunk,PERL_ARENA_SIZE,char);  /* Safefree() in sv_free_arenas() */
-       sv_add_arena(chunk, PERL_ARENA_SIZE, 0);
-    }
+    char *chunk;                /* must use New here to match call to */
+    Newx(chunk,PERL_ARENA_SIZE,char);  /* Safefree() in sv_free_arenas() */
+    sv_add_arena(chunk, PERL_ARENA_SIZE, 0);

     uproot_SV(sv);
     return sv;
 }
     uproot_SV(sv);
     return sv;
 }


@@ -294,7 +265,7 @@ S_new_SV(pTHX_ const char *file, int line, const char *func)
                    : 0
            );
     sv->sv_debug_inpad = 0;
                    : 0
            );
     sv->sv_debug_inpad = 0;

-    sv->sv_debug_cloned = 0;
+    sv->sv_debug_parent = NULL;

     sv->sv_debug_file = PL_curcop ? savepv(CopFILE(PL_curcop)): NULL;
 
     sv->sv_debug_serial = PL_sv_serial++;
     sv->sv_debug_file = PL_curcop ? savepv(CopFILE(PL_curcop)): NULL;
 
     sv->sv_debug_serial = PL_sv_serial++;


@@ -503,34 +474,73 @@ do_clean_objs(pTHX_ SV *const ref)
     /* XXX Might want to check arrays, etc. */
 }
 
     /* XXX Might want to check arrays, etc. */
 }
 

-/* called by sv_clean_objs() for each live SV */

 
 

-#ifndef DISABLE_DESTRUCTOR_KLUDGE
+/* clear any slots in a GV which hold objects - except IO;
+ * called by sv_clean_objs() for each live GV */
+

 static void
 do_clean_named_objs(pTHX_ SV *const sv)
 {
     dVAR;
 static void
 do_clean_named_objs(pTHX_ SV *const sv)
 {
     dVAR;

+    SV *obj;

     assert(SvTYPE(sv) == SVt_PVGV);
     assert(isGV_with_GP(sv));
     assert(SvTYPE(sv) == SVt_PVGV);
     assert(isGV_with_GP(sv));

-    if (GvGP(sv)) {
-       if ((
-#ifdef PERL_DONT_CREATE_GVSV
-            GvSV(sv) &&
-#endif
-            SvOBJECT(GvSV(sv))) ||
-            (GvAV(sv) && SvOBJECT(GvAV(sv))) ||
-            (GvHV(sv) && SvOBJECT(GvHV(sv))) ||
-            /* In certain rare cases GvIOp(sv) can be NULL, which would make SvOBJECT(GvIO(sv)) dereference NULL. */
-            (GvIO(sv) ? (SvFLAGS(GvIOp(sv)) & SVs_OBJECT) : 0) ||
-            (GvCV(sv) && SvOBJECT(GvCV(sv))) )
-       {
-           DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning named glob object:\n "), sv_dump(sv)));
-           SvFLAGS(sv) |= SVf_BREAK;
-           SvREFCNT_dec(sv);
-       }
+    if (!GvGP(sv))
+       return;
+
+    /* freeing GP entries may indirectly free the current GV;
+     * hold onto it while we mess with the GP slots */
+    SvREFCNT_inc(sv);
+
+    if ( ((obj = GvSV(sv) )) && SvOBJECT(obj)) {
+       DEBUG_D((PerlIO_printf(Perl_debug_log,
+               "Cleaning named glob SV object:\n "), sv_dump(obj)));
+       GvSV(sv) = NULL;
+       SvREFCNT_dec(obj);

     }
     }

+    if ( ((obj = MUTABLE_SV(GvAV(sv)) )) && SvOBJECT(obj)) {
+       DEBUG_D((PerlIO_printf(Perl_debug_log,
+               "Cleaning named glob AV object:\n "), sv_dump(obj)));
+       GvAV(sv) = NULL;
+       SvREFCNT_dec(obj);
+    }
+    if ( ((obj = MUTABLE_SV(GvHV(sv)) )) && SvOBJECT(obj)) {
+       DEBUG_D((PerlIO_printf(Perl_debug_log,
+               "Cleaning named glob HV object:\n "), sv_dump(obj)));
+       GvHV(sv) = NULL;
+       SvREFCNT_dec(obj);
+    }
+    if ( ((obj = MUTABLE_SV(GvCV(sv)) )) && SvOBJECT(obj)) {
+       DEBUG_D((PerlIO_printf(Perl_debug_log,
+               "Cleaning named glob CV object:\n "), sv_dump(obj)));
+       GvCV(sv) = NULL;
+       SvREFCNT_dec(obj);
+    }
+    SvREFCNT_dec(sv); /* undo the inc above */
+}
+
+/* clear any IO slots in a GV which hold objects (except stderr, defout);
+ * called by sv_clean_objs() for each live GV */
+
+static void
+do_clean_named_io_objs(pTHX_ SV *const sv)
+{
+    dVAR;
+    SV *obj;
+    assert(SvTYPE(sv) == SVt_PVGV);
+    assert(isGV_with_GP(sv));
+    if (!GvGP(sv) || sv == (SV*)PL_stderrgv || sv == (SV*)PL_defoutgv)
+       return;
+
+    SvREFCNT_inc(sv);
+    if ( ((obj = MUTABLE_SV(GvIO(sv)) )) && SvOBJECT(obj)) {
+       DEBUG_D((PerlIO_printf(Perl_debug_log,
+               "Cleaning named glob IO object:\n "), sv_dump(obj)));
+       GvIOp(sv) = NULL;
+       SvREFCNT_dec(obj);
+    }
+    SvREFCNT_dec(sv); /* undo the inc above */

 }
 }

-#endif

 
 /*
 =for apidoc sv_clean_objs
 
 /*
 =for apidoc sv_clean_objs


@@ -544,12 +554,23 @@ void
 Perl_sv_clean_objs(pTHX)
 {
     dVAR;
 Perl_sv_clean_objs(pTHX)
 {
     dVAR;

+    GV *olddef, *olderr;

     PL_in_clean_objs = TRUE;
     visit(do_clean_objs, SVf_ROK, SVf_ROK);
     PL_in_clean_objs = TRUE;
     visit(do_clean_objs, SVf_ROK, SVf_ROK);

-#ifndef DISABLE_DESTRUCTOR_KLUDGE
-    /* some barnacles may yet remain, clinging to typeglobs */
+    /* Some barnacles may yet remain, clinging to typeglobs.
+     * Run the non-IO destructors first: they may want to output
+     * error messages, close files etc */

     visit(do_clean_named_objs, SVt_PVGV|SVpgv_GP, SVTYPEMASK|SVp_POK|SVpgv_GP);
     visit(do_clean_named_objs, SVt_PVGV|SVpgv_GP, SVTYPEMASK|SVp_POK|SVpgv_GP);

-#endif
+    visit(do_clean_named_io_objs, SVt_PVGV|SVpgv_GP, SVTYPEMASK|SVp_POK|SVpgv_GP);
+    olddef = PL_defoutgv;
+    PL_defoutgv = NULL; /* disable skip of PL_defoutgv */
+    if (olddef && isGV_with_GP(olddef))
+       do_clean_named_io_objs(aTHX_ MUTABLE_SV(olddef));
+    olderr = PL_stderrgv;
+    PL_stderrgv = NULL; /* disable skip of PL_stderrgv */
+    if (olderr && isGV_with_GP(olderr))
+       do_clean_named_io_objs(aTHX_ MUTABLE_SV(olderr));
+    SvREFCNT_dec(olddef);

     PL_in_clean_objs = FALSE;
 }
 
     PL_in_clean_objs = FALSE;
 }
 


@@ -585,7 +606,6 @@ Perl_sv_clean_all(pTHX)
     I32 cleaned;
     PL_in_clean_all = TRUE;
     cleaned = visit(do_clean_all, 0,0);
     I32 cleaned;
     PL_in_clean_all = TRUE;
     cleaned = visit(do_clean_all, 0,0);

-    PL_in_clean_all = FALSE;

     return cleaned;
 }
 
     return cleaned;
 }
 


@@ -674,9 +694,6 @@ Perl_sv_free_arenas(pTHX)
     while (i--)
        PL_body_roots[i] = 0;
 
     while (i--)
        PL_body_roots[i] = 0;
 

-    Safefree(PL_nice_chunk);
-    PL_nice_chunk = NULL;
-    PL_nice_chunk_size = 0;

     PL_sv_arenaroot = 0;
     PL_sv_root = 0;
 }
     PL_sv_arenaroot = 0;
     PL_sv_root = 0;
 }


@@ -705,61 +722,6 @@ Perl_sv_free_arenas(pTHX)
   are decremented to point at the unused 'ghost' memory, knowing that
   the pointers are used with offsets to the real memory.
 
   are decremented to point at the unused 'ghost' memory, knowing that
   the pointers are used with offsets to the real memory.
 

-  HE, HEK arenas are managed separately, with separate code, but may
-  be merge-able later..
-*/
-
-/* get_arena(size): this creates custom-sized arenas
-   TBD: export properly for hv.c: S_more_he().
-*/
-void*
-Perl_get_arena(pTHX_ const size_t arena_size, const svtype bodytype)
-{
-    dVAR;
-    struct arena_desc* adesc;
-    struct arena_set *aroot = (struct arena_set*) PL_body_arenas;
-    unsigned int curr;
-
-    /* shouldnt need this
-    if (!arena_size)   arena_size = PERL_ARENA_SIZE;
-    */
-
-    /* may need new arena-set to hold new arena */
-    if (!aroot || aroot->curr >= aroot->set_size) {
-       struct arena_set *newroot;
-       Newxz(newroot, 1, struct arena_set);
-       newroot->set_size = ARENAS_PER_SET;
-       newroot->next = aroot;
-       aroot = newroot;
-       PL_body_arenas = (void *) newroot;
-       DEBUG_m(PerlIO_printf(Perl_debug_log, "new arenaset %p\n", (void*)aroot));
-    }
-
-    /* ok, now have arena-set with at least 1 empty/available arena-desc */
-    curr = aroot->curr++;
-    adesc = &(aroot->set[curr]);
-    assert(!adesc->arena);
-    
-    Newx(adesc->arena, arena_size, char);
-    adesc->size = arena_size;
-    adesc->utype = bodytype;
-    DEBUG_m(PerlIO_printf(Perl_debug_log, "arena %d added: %p size %"UVuf"\n", 
-                         curr, (void*)adesc->arena, (UV)arena_size));
-
-    return adesc->arena;
-}
-
-
-/* return a thing to the free list */
-
-#define del_body(thing, root)                  \
-    STMT_START {                               \
-       void ** const thing_copy = (void **)thing;\
-       *thing_copy = *root;                    \
-       *root = (void*)thing_copy;              \
-    } STMT_END
-
-/* 

 
 =head1 SV-Body Allocation
 
 
 =head1 SV-Body Allocation
 


@@ -806,11 +768,11 @@ they are no longer allocated.
 
 In turn, the new_body_* allocators call S_new_body(), which invokes
 new_body_inline macro, which takes a lock, and takes a body off the
 
 In turn, the new_body_* allocators call S_new_body(), which invokes
 new_body_inline macro, which takes a lock, and takes a body off the

-linked list at PL_body_roots[sv_type], calling S_more_bodies() if
+linked list at PL_body_roots[sv_type], calling Perl_more_bodies() if

 necessary to refresh an empty list.  Then the lock is released, and
 the body is returned.
 
 necessary to refresh an empty list.  Then the lock is released, and
 the body is returned.
 

-S_more_bodies calls get_arena(), and carves it up into an array of N
+Perl_more_bodies allocates a new arena, and carves it up into an array of N

 bodies, which it strings into a linked list.  It looks up arena-size
 and body-size from the body_details table described below, thus
 supporting the multiple body-types.
 bodies, which it strings into a linked list.  It looks up arena-size
 and body-size from the body_details table described below, thus
 supporting the multiple body-types.


@@ -818,10 +780,6 @@ supporting the multiple body-types.
 If PURIFY is defined, or PERL_ARENA_SIZE=0, arenas are not used, and
 the (new|del)_X*V macros are mapped directly to malloc/free.
 
 If PURIFY is defined, or PERL_ARENA_SIZE=0, arenas are not used, and
 the (new|del)_X*V macros are mapped directly to malloc/free.
 

-*/
-
-/* 
-

 For each sv-type, struct body_details bodies_by_type[] carries
 parameters which control these aspects of SV handling:
 
 For each sv-type, struct body_details bodies_by_type[] carries
 parameters which control these aspects of SV handling:
 


@@ -899,8 +857,8 @@ struct body_details {
        + sizeof (((type*)SvANY((const SV *)0))->last_member)
 
 static const struct body_details bodies_by_type[] = {
        + sizeof (((type*)SvANY((const SV *)0))->last_member)
 
 static const struct body_details bodies_by_type[] = {

-    { sizeof(HE), 0, 0, SVt_NULL,
-      FALSE, NONV, NOARENA, FIT_ARENA(0, sizeof(HE)) },
+    /* HEs use this offset for their arena.  */
+    { 0, 0, 0, SVt_NULL, FALSE, NONV, NOARENA, 0 },

 
     /* The bind placeholder pretends to be an RV for now.
        Also it's marked as "can't upgrade" to stop anyone using it before it's
 
     /* The bind placeholder pretends to be an RV for now.
        Also it's marked as "can't upgrade" to stop anyone using it before it's


@@ -920,40 +878,25 @@ static const struct body_details bodies_by_type[] = {
       SVt_NV, FALSE, HADNV, HASARENA, FIT_ARENA(0, sizeof(NV)) },
 
     /* 8 bytes on most ILP32 with IEEE doubles */
       SVt_NV, FALSE, HADNV, HASARENA, FIT_ARENA(0, sizeof(NV)) },
 
     /* 8 bytes on most ILP32 with IEEE doubles */

-    { sizeof(XPV),
+    { sizeof(XPV) - STRUCT_OFFSET(XPV, xpv_cur),

       copy_length(XPV, xpv_len) - STRUCT_OFFSET(XPV, xpv_cur),
       + STRUCT_OFFSET(XPV, xpv_cur),
       SVt_PV, FALSE, NONV, HASARENA,
       FIT_ARENA(0, sizeof(XPV) - STRUCT_OFFSET(XPV, xpv_cur)) },
 
       copy_length(XPV, xpv_len) - STRUCT_OFFSET(XPV, xpv_cur),
       + STRUCT_OFFSET(XPV, xpv_cur),
       SVt_PV, FALSE, NONV, HASARENA,
       FIT_ARENA(0, sizeof(XPV) - STRUCT_OFFSET(XPV, xpv_cur)) },
 

-#if 2 *PTRSIZE <= IVSIZE

     /* 12 */
     /* 12 */

-    { sizeof(XPVIV),
+    { sizeof(XPVIV) - STRUCT_OFFSET(XPV, xpv_cur),

       copy_length(XPVIV, xiv_u) - STRUCT_OFFSET(XPV, xpv_cur),
       + STRUCT_OFFSET(XPV, xpv_cur),
       SVt_PVIV, FALSE, NONV, HASARENA,
       FIT_ARENA(0, sizeof(XPVIV) - STRUCT_OFFSET(XPV, xpv_cur)) },
       copy_length(XPVIV, xiv_u) - STRUCT_OFFSET(XPV, xpv_cur),
       + STRUCT_OFFSET(XPV, xpv_cur),
       SVt_PVIV, FALSE, NONV, HASARENA,
       FIT_ARENA(0, sizeof(XPVIV) - STRUCT_OFFSET(XPV, xpv_cur)) },

-    /* 12 */
-#else
-    { sizeof(XPVIV),
-      copy_length(XPVIV, xiv_u),
-      0,
-      SVt_PVIV, FALSE, NONV, HASARENA,
-      FIT_ARENA(0, sizeof(XPVIV)) },
-#endif

 
 

-#if (2 *PTRSIZE <= IVSIZE) && (2 *PTRSIZE <= NVSIZE)

     /* 20 */
     /* 20 */

-    { sizeof(XPVNV),
+    { sizeof(XPVNV) - STRUCT_OFFSET(XPV, xpv_cur),

       copy_length(XPVNV, xnv_u) - STRUCT_OFFSET(XPV, xpv_cur),
       + STRUCT_OFFSET(XPV, xpv_cur),
       SVt_PVNV, FALSE, HADNV, HASARENA,
       FIT_ARENA(0, sizeof(XPVNV) - STRUCT_OFFSET(XPV, xpv_cur)) },
       copy_length(XPVNV, xnv_u) - STRUCT_OFFSET(XPV, xpv_cur),
       + STRUCT_OFFSET(XPV, xpv_cur),
       SVt_PVNV, FALSE, HADNV, HASARENA,
       FIT_ARENA(0, sizeof(XPVNV) - STRUCT_OFFSET(XPV, xpv_cur)) },

-#else
-    /* 20 */
-    { sizeof(XPVNV), copy_length(XPVNV, xnv_u), 0, SVt_PVNV, FALSE, HADNV,
-      HASARENA, FIT_ARENA(0, sizeof(XPVNV)) },
-#endif

 
     /* 28 */
     { sizeof(XPVMG), copy_length(XPVMG, xnv_u), 0, SVt_PVMG, FALSE, HADNV,
 
     /* 28 */
     { sizeof(XPVMG), copy_length(XPVMG, xnv_u), 0, SVt_PVMG, FALSE, HADNV,


@@ -964,7 +907,7 @@ static const struct body_details bodies_by_type[] = {
       sizeof(regexp),
       0,
       SVt_REGEXP, FALSE, NONV, HASARENA,
       sizeof(regexp),
       0,
       SVt_REGEXP, FALSE, NONV, HASARENA,

-      FIT_ARENA(0, sizeof(regexp) - STRUCT_OFFSET(regexp, xpv_cur))
+      FIT_ARENA(0, sizeof(regexp))

     },
 
     /* 48 */
     },
 
     /* 48 */


@@ -982,7 +925,7 @@ static const struct body_details bodies_by_type[] = {
       FIT_ARENA(0, sizeof(XPVAV)) },
 
     { sizeof(XPVHV),
       FIT_ARENA(0, sizeof(XPVAV)) },
 
     { sizeof(XPVHV),

-      copy_length(XPVHV, xhv_keys),
+      copy_length(XPVHV, xhv_max),

       0,
       SVt_PVHV, TRUE, NONV, HASARENA,
       FIT_ARENA(0, sizeof(XPVHV)) },
       0,
       SVt_PVHV, TRUE, NONV, HASARENA,
       FIT_ARENA(0, sizeof(XPVHV)) },


@@ -1012,73 +955,53 @@ static const struct body_details bodies_by_type[] = {
     (void *)((char *)S_new_body(aTHX_ sv_type) \
             - bodies_by_type[sv_type].offset)
 
     (void *)((char *)S_new_body(aTHX_ sv_type) \
             - bodies_by_type[sv_type].offset)
 

-#define del_body_allocated(p, sv_type)         \
-    del_body(p + bodies_by_type[sv_type].offset, &PL_body_roots[sv_type])
-
+/* return a thing to the free list */

 
 

-#define my_safemalloc(s)       (void*)safemalloc(s)
-#define my_safecalloc(s)       (void*)safecalloc(s, 1)
-#define my_safefree(p) safefree((char*)p)
+#define del_body(thing, root)                          \
+    STMT_START {                                       \
+       void ** const thing_copy = (void **)thing;      \
+       *thing_copy = *root;                            \
+       *root = (void*)thing_copy;                      \
+    } STMT_END

 
 #ifdef PURIFY
 
 
 #ifdef PURIFY
 

-#define new_XNV()      my_safemalloc(sizeof(XPVNV))
-#define del_XNV(p)     my_safefree(p)
+#define new_XNV()      safemalloc(sizeof(XPVNV))
+#define new_XPVNV()    safemalloc(sizeof(XPVNV))
+#define new_XPVMG()    safemalloc(sizeof(XPVMG))

 
 

-#define new_XPVNV()    my_safemalloc(sizeof(XPVNV))
-#define del_XPVNV(p)   my_safefree(p)
-
-#define new_XPVAV()    my_safemalloc(sizeof(XPVAV))
-#define del_XPVAV(p)   my_safefree(p)
-
-#define new_XPVHV()    my_safemalloc(sizeof(XPVHV))
-#define del_XPVHV(p)   my_safefree(p)
-
-#define new_XPVMG()    my_safemalloc(sizeof(XPVMG))
-#define del_XPVMG(p)   my_safefree(p)
-
-#define new_XPVGV()    my_safemalloc(sizeof(XPVGV))
-#define del_XPVGV(p)   my_safefree(p)
+#define del_XPVGV(p)   safefree(p)

 
 #else /* !PURIFY */
 
 #define new_XNV()      new_body_allocated(SVt_NV)
 
 #else /* !PURIFY */
 
 #define new_XNV()      new_body_allocated(SVt_NV)

-#define del_XNV(p)     del_body_allocated(p, SVt_NV)
-

 #define new_XPVNV()    new_body_allocated(SVt_PVNV)
 #define new_XPVNV()    new_body_allocated(SVt_PVNV)

-#define del_XPVNV(p)   del_body_allocated(p, SVt_PVNV)
-
-#define new_XPVAV()    new_body_allocated(SVt_PVAV)
-#define del_XPVAV(p)   del_body_allocated(p, SVt_PVAV)
-
-#define new_XPVHV()    new_body_allocated(SVt_PVHV)
-#define del_XPVHV(p)   del_body_allocated(p, SVt_PVHV)
-

 #define new_XPVMG()    new_body_allocated(SVt_PVMG)
 #define new_XPVMG()    new_body_allocated(SVt_PVMG)

-#define del_XPVMG(p)   del_body_allocated(p, SVt_PVMG)

 
 

-#define new_XPVGV()    new_body_allocated(SVt_PVGV)
-#define del_XPVGV(p)   del_body_allocated(p, SVt_PVGV)
+#define del_XPVGV(p)   del_body(p + bodies_by_type[SVt_PVGV].offset,   \
+                                &PL_body_roots[SVt_PVGV])

 
 #endif /* PURIFY */
 
 /* no arena for you! */
 
 #define new_NOARENA(details) \
 
 #endif /* PURIFY */
 
 /* no arena for you! */
 
 #define new_NOARENA(details) \

-       my_safemalloc((details)->body_size + (details)->offset)
+       safemalloc((details)->body_size + (details)->offset)

 #define new_NOARENAZ(details) \
 #define new_NOARENAZ(details) \

-       my_safecalloc((details)->body_size + (details)->offset)
+       safecalloc((details)->body_size + (details)->offset, 1)

 
 

-STATIC void *
-S_more_bodies (pTHX_ const svtype sv_type)
+void *
+Perl_more_bodies (pTHX_ const svtype sv_type, const size_t body_size,
+                 const size_t arena_size)

 {
     dVAR;
     void ** const root = &PL_body_roots[sv_type];
 {
     dVAR;
     void ** const root = &PL_body_roots[sv_type];

-    const struct body_details * const bdp = &bodies_by_type[sv_type];
-    const size_t body_size = bdp->body_size;
+    struct arena_desc *adesc;
+    struct arena_set *aroot = (struct arena_set *) PL_body_arenas;
+    unsigned int curr;

     char *start;
     const char *end;
     char *start;
     const char *end;

-    const size_t arena_size = Perl_malloc_good_size(bdp->arena_size);
+    const size_t good_arena_size = Perl_malloc_good_size(arena_size);

 #if defined(DEBUGGING) && !defined(PERL_GLOBAL_STRUCT_PRIVATE)
     static bool done_sanity_check;
 
 #if defined(DEBUGGING) && !defined(PERL_GLOBAL_STRUCT_PRIVATE)
     static bool done_sanity_check;
 


@@ -1094,37 +1017,68 @@ S_more_bodies (pTHX_ const svtype sv_type)
     }
 #endif
 
     }
 #endif
 

-    assert(bdp->arena_size);
+    assert(arena_size);
+
+    /* may need new arena-set to hold new arena */
+    if (!aroot || aroot->curr >= aroot->set_size) {
+       struct arena_set *newroot;
+       Newxz(newroot, 1, struct arena_set);
+       newroot->set_size = ARENAS_PER_SET;
+       newroot->next = aroot;
+       aroot = newroot;
+       PL_body_arenas = (void *) newroot;
+       DEBUG_m(PerlIO_printf(Perl_debug_log, "new arenaset %p\n", (void*)aroot));
+    }

 
 

-    start = (char*) Perl_get_arena(aTHX_ arena_size, sv_type);
+    /* ok, now have arena-set with at least 1 empty/available arena-desc */
+    curr = aroot->curr++;
+    adesc = &(aroot->set[curr]);
+    assert(!adesc->arena);
+    
+    Newx(adesc->arena, good_arena_size, char);
+    adesc->size = good_arena_size;
+    adesc->utype = sv_type;
+    DEBUG_m(PerlIO_printf(Perl_debug_log, "arena %d added: %p size %"UVuf"\n", 
+                         curr, (void*)adesc->arena, (UV)good_arena_size));

 
 

-    end = start + arena_size - 2 * body_size;
+    start = (char *) adesc->arena;
+
+    /* Get the address of the byte after the end of the last body we can fit.
+       Remember, this is integer division:  */
+    end = start + good_arena_size / body_size * body_size;

 
     /* computed count doesnt reflect the 1st slot reservation */
 #if defined(MYMALLOC) || defined(HAS_MALLOC_GOOD_SIZE)
     DEBUG_m(PerlIO_printf(Perl_debug_log,
                          "arena %p end %p arena-size %d (from %d) type %d "
                          "size %d ct %d\n",
 
     /* computed count doesnt reflect the 1st slot reservation */
 #if defined(MYMALLOC) || defined(HAS_MALLOC_GOOD_SIZE)
     DEBUG_m(PerlIO_printf(Perl_debug_log,
                          "arena %p end %p arena-size %d (from %d) type %d "
                          "size %d ct %d\n",

-                         (void*)start, (void*)end, (int)arena_size,
-                         (int)bdp->arena_size, sv_type, (int)body_size,
-                         (int)arena_size / (int)body_size));
+                         (void*)start, (void*)end, (int)good_arena_size,
+                         (int)arena_size, sv_type, (int)body_size,
+                         (int)good_arena_size / (int)body_size));

 #else
     DEBUG_m(PerlIO_printf(Perl_debug_log,
                          "arena %p end %p arena-size %d type %d size %d ct %d\n",
                          (void*)start, (void*)end,
 #else
     DEBUG_m(PerlIO_printf(Perl_debug_log,
                          "arena %p end %p arena-size %d type %d size %d ct %d\n",
                          (void*)start, (void*)end,

-                         (int)bdp->arena_size, sv_type, (int)body_size,
-                         (int)bdp->arena_size / (int)body_size));
+                         (int)arena_size, sv_type, (int)body_size,
+                         (int)good_arena_size / (int)body_size));

 #endif
     *root = (void *)start;
 
 #endif
     *root = (void *)start;
 

-    while (start <= end) {
+    while (1) {
+       /* Where the next body would start:  */

        char * const next = start + body_size;
        char * const next = start + body_size;

+
+       if (next >= end) {
+           /* This is the last body:  */
+           assert(next == end);
+
+           *(void **)start = 0;
+           return *root;
+       }
+

        *(void**) start = (void *)next;
        start = next;
     }
        *(void**) start = (void *)next;
        start = next;
     }

-    *(void **)start = 0;
-
-    return *root;

 }
 
 /* grab a new thing from the free list, allocating more if necessary.
 }
 
 /* grab a new thing from the free list, allocating more if necessary.


@@ -1135,7 +1089,9 @@ S_more_bodies (pTHX_ const svtype sv_type)
     STMT_START { \
        void ** const r3wt = &PL_body_roots[sv_type]; \
        xpv = (PTR_TBL_ENT_t*) (*((void **)(r3wt))      \
     STMT_START { \
        void ** const r3wt = &PL_body_roots[sv_type]; \
        xpv = (PTR_TBL_ENT_t*) (*((void **)(r3wt))      \

-         ? *((void **)(r3wt)) : more_bodies(sv_type)); \
+         ? *((void **)(r3wt)) : Perl_more_bodies(aTHX_ sv_type, \
+                                            bodies_by_type[sv_type].body_size,\
+                                            bodies_by_type[sv_type].arena_size)); \

        *(r3wt) = *(void**)(xpv); \
     } STMT_END
 
        *(r3wt) = *(void**)(xpv); \
     } STMT_END
 


@@ -1339,13 +1295,6 @@ Perl_sv_upgrade(pTHX_ register SV *const sv, svtype new_type)
            HvSHAREKEYS_on(sv);         /* key-sharing on by default */
 #endif
            HvMAX(sv) = 7; /* (start with 8 buckets) */
            HvSHAREKEYS_on(sv);         /* key-sharing on by default */
 #endif
            HvMAX(sv) = 7; /* (start with 8 buckets) */

-           if (old_type_details->body_size) {
-               HvFILL(sv) = 0;
-           } else {
-               /* It will have been zeroed when the new body was allocated.
-                  Lets not write to it, in case it confuses a write-back
-                  cache.  */
-           }

        }
 
        /* SVt_NULL isn't the only thing upgraded to AV or HV.
        }
 
        /* SVt_NULL isn't the only thing upgraded to AV or HV.


@@ -1452,7 +1401,7 @@ Perl_sv_upgrade(pTHX_ register SV *const sv, svtype new_type)
 
     if (old_type > SVt_IV) {
 #ifdef PURIFY
 
     if (old_type > SVt_IV) {
 #ifdef PURIFY

-       my_safefree(old_body);
+       safefree(old_body);

 #else
        /* Note that there is an assumption that all bodies of types that
           can be upgraded came from arenas. Only the more complex non-
 #else
        /* Note that there is an assumption that all bodies of types that
           can be upgraded came from arenas. Only the more complex non-


@@ -1543,6 +1492,10 @@ Perl_sv_grow(pTHX_ register SV *const sv, register STRLEN newlen)
        s = SvPVX_mutable(sv);
 
     if (newlen > SvLEN(sv)) {          /* need more room? */
        s = SvPVX_mutable(sv);
 
     if (newlen > SvLEN(sv)) {          /* need more room? */

+       STRLEN minlen = SvCUR(sv);
+       minlen += (minlen >> PERL_STRLEN_EXPAND_SHIFT) + 10;
+       if (newlen < minlen)
+           newlen = minlen;

 #ifndef Perl_safesysmalloc_size
        newlen = PERL_STRLEN_ROUNDUP(newlen);
 #endif
 #ifndef Perl_safesysmalloc_size
        newlen = PERL_STRLEN_ROUNDUP(newlen);
 #endif


@@ -2443,7 +2396,7 @@ Perl_sv_2uv_flags(pTHX_ register SV *const sv, const I32 flags)
 }
 
 /*
 }
 
 /*

-=for apidoc sv_2nv
+=for apidoc sv_2nv_flags

 
 Return the num value of an SV, doing any necessary string or integer
 conversion. If flags includes SV_GMAGIC, does an mg_get() first.
 
 Return the num value of an SV, doing any necessary string or integer
 conversion. If flags includes SV_GMAGIC, does an mg_get() first.


@@ -2690,6 +2643,7 @@ Perl_sv_2num(pTHX_ register SV *const sv)
        return sv;
     if (SvAMAGIC(sv)) {
        SV * const tmpsv = AMG_CALLun(sv,numer);
        return sv;
     if (SvAMAGIC(sv)) {
        SV * const tmpsv = AMG_CALLun(sv,numer);

+       TAINT_IF(tmpsv && SvTAINTED(tmpsv));

        if (tmpsv && (!SvROK(tmpsv) || (SvRV(tmpsv) != SvRV(sv))))
            return sv_2num(tmpsv);
     }
        if (tmpsv && (!SvROK(tmpsv) || (SvRV(tmpsv) != SvRV(sv))))
            return sv_2num(tmpsv);
     }


@@ -2773,6 +2727,10 @@ Perl_sv_2pv_flags(pTHX_ register SV *const sv, STRLEN *const lp, const I32 flags
                len = SvIsUV(sv)
                    ? my_snprintf(tbuf, sizeof(tbuf), "%"UVuf, (UV)SvUVX(sv))
                    : my_snprintf(tbuf, sizeof(tbuf), "%"IVdf, (IV)SvIVX(sv));
                len = SvIsUV(sv)
                    ? my_snprintf(tbuf, sizeof(tbuf), "%"UVuf, (UV)SvUVX(sv))
                    : my_snprintf(tbuf, sizeof(tbuf), "%"IVdf, (IV)SvIVX(sv));

+           } else if(SvNVX(sv) == 0.0) {
+                   tbuf[0] = '0';
+                   tbuf[1] = 0;
+                   len = 1;

            } else {
                Gconvert(SvNVX(sv), NV_DIG, 0, tbuf);
                len = strlen(tbuf);
            } else {
                Gconvert(SvNVX(sv), NV_DIG, 0, tbuf);
                len = strlen(tbuf);


@@ -2781,13 +2739,6 @@ Perl_sv_2pv_flags(pTHX_ register SV *const sv, STRLEN *const lp, const I32 flags
            {
                dVAR;
 
            {
                dVAR;
 

-#ifdef FIXNEGATIVEZERO
-               if (len == 2 && tbuf[0] == '-' && tbuf[1] == '0') {
-                   tbuf[0] = '0';
-                   tbuf[1] = 0;
-                   len = 1;
-               }
-#endif

                SvUPGRADE(sv, SVt_PV);
                if (lp)
                    *lp = len;
                SvUPGRADE(sv, SVt_PV);
                if (lp)
                    *lp = len;


@@ -2811,6 +2762,7 @@ Perl_sv_2pv_flags(pTHX_ register SV *const sv, STRLEN *const lp, const I32 flags
                if (flags & SV_SKIP_OVERLOAD)
                    return NULL;
                tmpstr = AMG_CALLun(sv,string);
                if (flags & SV_SKIP_OVERLOAD)
                    return NULL;
                tmpstr = AMG_CALLun(sv,string);

+               TAINT_IF(tmpstr && SvTAINTED(tmpstr));

                if (tmpstr && (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv)))) {
                    /* Unwrap this:  */
                    /* char *pv = lp ? SvPV(tmpstr, *lp) : SvPV_nolen(tmpstr);
                if (tmpstr && (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv)))) {
                    /* Unwrap this:  */
                    /* char *pv = lp ? SvPV(tmpstr, *lp) : SvPV_nolen(tmpstr);


@@ -2958,28 +2910,21 @@ Perl_sv_2pv_flags(pTHX_ register SV *const sv, STRLEN *const lp, const I32 flags
        *s = '\0';
     }
     else if (SvNOKp(sv)) {
        *s = '\0';
     }
     else if (SvNOKp(sv)) {

-       dSAVE_ERRNO;

        if (SvTYPE(sv) < SVt_PVNV)
            sv_upgrade(sv, SVt_PVNV);
        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);
-       /* some Xenix systems wipe out errno here */
-#ifdef apollo
-       if (SvNVX(sv) == 0.0)
-           my_strlcpy(s, "0", SvLEN(sv));
-       else
-#endif /*apollo*/
-       {
+       if (SvNVX(sv) == 0.0) {
+           s = SvGROW_mutable(sv, 2);
+           *s++ = '0';
+           *s = '\0';
+       } else {
+           dSAVE_ERRNO;
+           /* The +20 is pure guesswork.  Configure test needed. --jhi */
+           s = SvGROW_mutable(sv, NV_DIG + 20);
+           /* some Xenix systems wipe out errno here */

            Gconvert(SvNVX(sv), NV_DIG, 0, s);
            Gconvert(SvNVX(sv), NV_DIG, 0, s);

+           RESTORE_ERRNO;
+           while (*s) s++;

        }
        }

-       RESTORE_ERRNO;
-#ifdef FIXNEGATIVEZERO
-        if (*s == '-' && s[1] == '0' && !s[2]) {
-           s[0] = '0';
-           s[1] = 0;
-       }
-#endif
-       while (*s) s++;

 #ifdef hcx
        if (s[-1] == '.')
            *--s = '\0';
 #ifdef hcx
        if (s[-1] == '.')
            *--s = '\0';


@@ -3083,8 +3028,9 @@ Perl_sv_2pvbyte(pTHX_ register SV *const sv, STRLEN *const lp)
 {
     PERL_ARGS_ASSERT_SV_2PVBYTE;
 
 {
     PERL_ARGS_ASSERT_SV_2PVBYTE;
 

+    SvGETMAGIC(sv);

     sv_utf8_downgrade(sv,0);
     sv_utf8_downgrade(sv,0);

-    return lp ? SvPV(sv,*lp) : SvPV_nolen(sv);
+    return lp ? SvPV_nomg(sv,*lp) : SvPV_nomg_nolen(sv);

 }
 
 /*
 }
 
 /*


@@ -3111,20 +3057,28 @@ Perl_sv_2pvutf8(pTHX_ register SV *const sv, STRLEN *const lp)
 /*
 =for apidoc sv_2bool
 
 /*
 =for apidoc sv_2bool
 

-This function is only called on magical items, and is only used by
-sv_true() or its macro equivalent.
+This macro is only used by sv_true() or its macro equivalent, and only if
+the latter's argument is neither SvPOK, SvIOK nor SvNOK.
+It calls sv_2bool_flags with the SV_GMAGIC flag.
+
+=for apidoc sv_2bool_flags
+
+This function is only used by sv_true() and friends,  and only if
+the latter's argument is neither SvPOK, SvIOK nor SvNOK. If the flags
+contain SV_GMAGIC, then it does an mg_get() first.
+

 
 =cut
 */
 
 bool
 
 =cut
 */
 
 bool

-Perl_sv_2bool(pTHX_ register SV *const sv)
+Perl_sv_2bool_flags(pTHX_ register SV *const sv, const I32 flags)

 {
     dVAR;
 
 {
     dVAR;
 

-    PERL_ARGS_ASSERT_SV_2BOOL;
+    PERL_ARGS_ASSERT_SV_2BOOL_FLAGS;

 
 

-    SvGETMAGIC(sv);
+    if(flags & SV_GMAGIC) SvGETMAGIC(sv);

 
     if (!SvOK(sv))
        return 0;
 
     if (!SvOK(sv))
        return 0;


@@ -3527,7 +3481,7 @@ Perl_sv_utf8_encode(pTHX_ register SV *const sv)
         sv_force_normal_flags(sv, 0);
     }
     if (SvREADONLY(sv)) {
         sv_force_normal_flags(sv, 0);
     }
     if (SvREADONLY(sv)) {

-       Perl_croak(aTHX_ "%s", PL_no_modify);
+       Perl_croak_no_modify(aTHX);

     }
     (void) sv_utf8_upgrade(sv);
     SvUTF8_off(sv);
     }
     (void) sv_utf8_upgrade(sv);
     SvUTF8_off(sv);


@@ -3616,11 +3570,12 @@ copy-ish functions and macros use this underneath.
 static void
 S_glob_assign_glob(pTHX_ SV *const dstr, SV *const sstr, const int dtype)
 {
 static void
 S_glob_assign_glob(pTHX_ SV *const dstr, SV *const sstr, const int dtype)
 {

-    I32 mro_changes = 0; /* 1 = method, 2 = isa */
+    I32 mro_changes = 0; /* 1 = method, 2 = isa, 3 = recursive isa */
+    HV *old_stash = NULL;

 
     PERL_ARGS_ASSERT_GLOB_ASSIGN_GLOB;
 
 
     PERL_ARGS_ASSERT_GLOB_ASSIGN_GLOB;
 

-    if (dtype != SVt_PVGV) {
+    if (dtype != SVt_PVGV && !isGV_with_GP(dstr)) {

        const char * const name = GvNAME(sstr);
        const STRLEN len = GvNAMELEN(sstr);
        {
        const char * const name = GvNAME(sstr);
        const STRLEN len = GvNAMELEN(sstr);
        {


@@ -3652,18 +3607,48 @@ S_glob_assign_glob(pTHX_ SV *const dstr, SV *const sstr, const int dtype)
         }
         /* If source has a real method, then a method is
            going to change */
         }
         /* If source has a real method, then a method is
            going to change */

-        else if(GvCV((const GV *)sstr)) {
+        else if(
+         GvCV((const GV *)sstr) && GvSTASH(dstr) && HvENAME(GvSTASH(dstr))
+        ) {

             mro_changes = 1;
         }
     }
 
     /* If dest already had a real method, that's a change as well */
             mro_changes = 1;
         }
     }
 
     /* If dest already had a real method, that's a change as well */

-    if(!mro_changes && GvGP(MUTABLE_GV(dstr)) && GvCVu((const GV *)dstr)) {
+    if(
+        !mro_changes && GvGP(MUTABLE_GV(dstr)) && GvCVu((const GV *)dstr)
+     && GvSTASH(dstr) && HvENAME(GvSTASH(dstr))
+    ) {

         mro_changes = 1;
     }
 
         mro_changes = 1;
     }
 

-    if(strEQ(GvNAME((const GV *)dstr),"ISA"))
-        mro_changes = 2;
+    /* We don’t need to check the name of the destination if it was not a
+       glob to begin with. */
+    if(dtype == SVt_PVGV) {
+        const char * const name = GvNAME((const GV *)dstr);
+        if(
+            strEQ(name,"ISA")
+         /* The stash may have been detached from the symbol table, so
+            check its name. */
+         && GvSTASH(dstr) && HvENAME(GvSTASH(dstr))
+         && GvAV((const GV *)sstr)
+        )
+            mro_changes = 2;
+        else {
+            const STRLEN len = GvNAMELEN(dstr);
+            if (len > 1 && name[len-2] == ':' && name[len-1] == ':') {
+                mro_changes = 3;
+
+                /* Set aside the old stash, so we can reset isa caches on
+                   its subclasses. */
+                if((old_stash = GvHV(dstr)))
+                    /* Make sure we do not lose it early. */
+                    SvREFCNT_inc_simple_void_NN(
+                     sv_2mortal((SV *)old_stash)
+                    );
+            }
+        }
+    }

 
     gp_free(MUTABLE_GV(dstr));
     isGV_with_GP_off(dstr);
 
     gp_free(MUTABLE_GV(dstr));
     isGV_with_GP_off(dstr);


@@ -3679,7 +3664,28 @@ S_glob_assign_glob(pTHX_ SV *const dstr, SV *const sstr, const int dtype)
            GvIMPORTED_on(dstr);
        }
     GvMULTI_on(dstr);
            GvIMPORTED_on(dstr);
        }
     GvMULTI_on(dstr);

-    if(mro_changes == 2) mro_isa_changed_in(GvSTASH(dstr));
+    if(mro_changes == 2) {
+       MAGIC *mg;
+       SV * const sref = (SV *)GvAV((const GV *)dstr);
+       if (SvSMAGICAL(sref) && (mg = mg_find(sref, PERL_MAGIC_isa))) {
+           if (SvTYPE(mg->mg_obj) != SVt_PVAV) {
+               AV * const ary = newAV();
+               av_push(ary, mg->mg_obj); /* takes the refcount */
+               mg->mg_obj = (SV *)ary;
+           }
+           av_push((AV *)mg->mg_obj, SvREFCNT_inc_simple_NN(dstr));
+       }
+       else sv_magic(sref, dstr, PERL_MAGIC_isa, NULL, 0);
+       mro_isa_changed_in(GvSTASH(dstr));
+    }
+    else if(mro_changes == 3) {
+       HV * const stash = GvHV(dstr);
+       if(old_stash ? (HV *)HvENAME_get(old_stash) : stash)
+           mro_package_moved(
+               stash, old_stash,
+               (GV *)dstr, 0
+           );
+    }

     else if(mro_changes) mro_method_changed_in(GvSTASH(dstr));
     return;
 }
     else if(mro_changes) mro_method_changed_in(GvSTASH(dstr));
     return;
 }


@@ -3786,9 +3792,68 @@ S_glob_assign_ref(pTHX_ SV *const dstr, SV *const sstr)
            && CopSTASH_ne(PL_curcop, GvSTASH(dstr))) {
            GvFLAGS(dstr) |= import_flag;
        }
            && CopSTASH_ne(PL_curcop, GvSTASH(dstr))) {
            GvFLAGS(dstr) |= import_flag;
        }

-       if (stype == SVt_PVAV && strEQ(GvNAME((GV*)dstr), "ISA")) {
-           sv_magic(sref, dstr, PERL_MAGIC_isa, NULL, 0);
-           mro_isa_changed_in(GvSTASH(dstr));
+       if (stype == SVt_PVHV) {
+           const char * const name = GvNAME((GV*)dstr);
+           const STRLEN len = GvNAMELEN(dstr);
+           if (
+               len > 1 && name[len-2] == ':' && name[len-1] == ':'
+            && (!dref || HvENAME_get(dref))
+           ) {
+               mro_package_moved(
+                   (HV *)sref, (HV *)dref,
+                   (GV *)dstr, 0
+               );
+           }
+       }
+       else if (
+           stype == SVt_PVAV && sref != dref
+        && strEQ(GvNAME((GV*)dstr), "ISA")
+        /* The stash may have been detached from the symbol table, so
+           check its name before doing anything. */
+        && GvSTASH(dstr) && HvENAME(GvSTASH(dstr))
+       ) {
+           MAGIC *mg;
+           MAGIC * const omg = dref && SvSMAGICAL(dref)
+                                ? mg_find(dref, PERL_MAGIC_isa)
+                                : NULL;
+           if (SvSMAGICAL(sref) && (mg = mg_find(sref, PERL_MAGIC_isa))) {
+               if (SvTYPE(mg->mg_obj) != SVt_PVAV) {
+                   AV * const ary = newAV();
+                   av_push(ary, mg->mg_obj); /* takes the refcount */
+                   mg->mg_obj = (SV *)ary;
+               }
+               if (omg) {
+                   if (SvTYPE(omg->mg_obj) == SVt_PVAV) {
+                       SV **svp = AvARRAY((AV *)omg->mg_obj);
+                       I32 items = AvFILLp((AV *)omg->mg_obj) + 1;
+                       while (items--)
+                           av_push(
+                            (AV *)mg->mg_obj,
+                            SvREFCNT_inc_simple_NN(*svp++)
+                           );
+                   }
+                   else
+                       av_push(
+                        (AV *)mg->mg_obj,
+                        SvREFCNT_inc_simple_NN(omg->mg_obj)
+                       );
+               }
+               else
+                   av_push((AV *)mg->mg_obj,SvREFCNT_inc_simple_NN(dstr));
+           }
+           else
+           {
+               sv_magic(
+                sref, omg ? omg->mg_obj : dstr, PERL_MAGIC_isa, NULL, 0
+               );
+               mg = mg_find(sref, PERL_MAGIC_isa);
+           }
+           /* Since the *ISA assignment could have affected more than
+              one stash, don’t call mro_isa_changed_in directly, but let
+              magic_clearisa do it for us, as it already has the logic for
+              dealing with globs vs arrays of globs. */
+           assert(mg);
+           Perl_magic_clearisa(aTHX_ NULL, mg);

        }
        break;
     }
        }
        break;
     }


@@ -3837,7 +3902,7 @@ Perl_sv_setsv_flags(pTHX_ SV *dstr, register SV* sstr, const I32 flags)
     switch (stype) {
     case SVt_NULL:
       undef_sstr:
     switch (stype) {
     case SVt_NULL:
       undef_sstr:

-       if (dtype != SVt_PVGV) {
+       if (dtype != SVt_PVGV && dtype != SVt_PVLV) {

            (void)SvOK_off(dstr);
            return;
        }
            (void)SvOK_off(dstr);
            return;
        }


@@ -3853,6 +3918,7 @@ Perl_sv_setsv_flags(pTHX_ SV *dstr, register SV* sstr, const I32 flags)
                sv_upgrade(dstr, SVt_PVIV);
                break;
            case SVt_PVGV:
                sv_upgrade(dstr, SVt_PVIV);
                break;
            case SVt_PVGV:

+           case SVt_PVLV:

                goto end_of_first_switch;
            }
            (void)SvIOK_only(dstr);
                goto end_of_first_switch;
            }
            (void)SvIOK_only(dstr);


@@ -3884,6 +3950,7 @@ Perl_sv_setsv_flags(pTHX_ SV *dstr, register SV* sstr, const I32 flags)
                sv_upgrade(dstr, SVt_PVNV);
                break;
            case SVt_PVGV:
                sv_upgrade(dstr, SVt_PVNV);
                break;
            case SVt_PVGV:

+           case SVt_PVLV:

                goto end_of_first_switch;
            }
            SvNV_set(dstr, SvNVX(sstr));
                goto end_of_first_switch;
            }
            SvNV_set(dstr, SvNVX(sstr));


@@ -3936,23 +4003,17 @@ Perl_sv_setsv_flags(pTHX_ SV *dstr, register SV* sstr, const I32 flags)
        /* case SVt_BIND: */
     case SVt_PVLV:
     case SVt_PVGV:
        /* case SVt_BIND: */
     case SVt_PVLV:
     case SVt_PVGV:

-       if (isGV_with_GP(sstr) && dtype <= SVt_PVGV) {
-           glob_assign_glob(dstr, sstr, dtype);
-           return;
-       }

        /* SvVALID means that this PVGV is playing at being an FBM.  */
        /* SvVALID means that this PVGV is playing at being an FBM.  */

-       /*FALLTHROUGH*/

 
     case SVt_PVMG:
        if (SvGMAGICAL(sstr) && (flags & SV_GMAGIC)) {
            mg_get(sstr);
 
     case SVt_PVMG:
        if (SvGMAGICAL(sstr) && (flags & SV_GMAGIC)) {
            mg_get(sstr);

-           if (SvTYPE(sstr) != stype) {
+           if (SvTYPE(sstr) != stype)

                stype = SvTYPE(sstr);
                stype = SvTYPE(sstr);

-               if (isGV_with_GP(sstr) && stype == SVt_PVGV && dtype <= SVt_PVGV) {
+       }
+       if (isGV_with_GP(sstr) && dtype <= SVt_PVLV) {

                    glob_assign_glob(dstr, sstr, dtype);
                    return;
                    glob_assign_glob(dstr, sstr, dtype);
                    return;

-               }
-           }

        }
        if (stype == SVt_PVLV)
            SvUPGRADE(dstr, SVt_PVNV);
        }
        if (stype == SVt_PVLV)
            SvUPGRADE(dstr, SVt_PVNV);


@@ -3986,7 +4047,7 @@ Perl_sv_setsv_flags(pTHX_ SV *dstr, register SV* sstr, const I32 flags)
        else
            Perl_croak(aTHX_ "Cannot copy to %s", type);
     } else if (sflags & SVf_ROK) {
        else
            Perl_croak(aTHX_ "Cannot copy to %s", type);
     } else if (sflags & SVf_ROK) {

-       if (isGV_with_GP(dstr) && dtype == SVt_PVGV
+       if (isGV_with_GP(dstr)

            && SvTYPE(SvRV(sstr)) == SVt_PVGV && isGV_with_GP(SvRV(sstr))) {
            sstr = SvRV(sstr);
            if (sstr == dstr) {
            && SvTYPE(SvRV(sstr)) == SVt_PVGV && isGV_with_GP(SvRV(sstr))) {
            sstr = SvRV(sstr);
            if (sstr == dstr) {


@@ -4003,7 +4064,7 @@ Perl_sv_setsv_flags(pTHX_ SV *dstr, register SV* sstr, const I32 flags)
        }
 
        if (dtype >= SVt_PV) {
        }
 
        if (dtype >= SVt_PV) {

-           if (dtype == SVt_PVGV && isGV_with_GP(dstr)) {
+           if (isGV_with_GP(dstr)) {

                glob_assign_ref(dstr, sstr);
                return;
            }
                glob_assign_ref(dstr, sstr);
                return;
            }


@@ -4021,7 +4082,7 @@ Perl_sv_setsv_flags(pTHX_ SV *dstr, register SV* sstr, const I32 flags)
        assert(!(sflags & SVf_NOK));
        assert(!(sflags & SVf_IOK));
     }
        assert(!(sflags & SVf_NOK));
        assert(!(sflags & SVf_IOK));
     }

-    else if (dtype == SVt_PVGV && isGV_with_GP(dstr)) {
+    else if (isGV_with_GP(dstr)) {

        if (!(sflags & SVf_OK)) {
            Perl_ck_warner(aTHX_ packWARN(WARN_MISC),
                           "Undefined value assigned to typeglob");
        if (!(sflags & SVf_OK)) {
            Perl_ck_warner(aTHX_ packWARN(WARN_MISC),
                           "Undefined value assigned to typeglob");


@@ -4029,9 +4090,36 @@ Perl_sv_setsv_flags(pTHX_ SV *dstr, register SV* sstr, const I32 flags)
        else {
            GV *gv = gv_fetchsv(sstr, GV_ADD, SVt_PVGV);
            if (dstr != (const SV *)gv) {
        else {
            GV *gv = gv_fetchsv(sstr, GV_ADD, SVt_PVGV);
            if (dstr != (const SV *)gv) {

+               const char * const name = GvNAME((const GV *)dstr);
+               const STRLEN len = GvNAMELEN(dstr);
+               HV *old_stash = NULL;
+               bool reset_isa = FALSE;
+               if (len > 1 && name[len-2] == ':' && name[len-1] == ':') {
+                   /* Set aside the old stash, so we can reset isa caches
+                      on its subclasses. */
+                   if((old_stash = GvHV(dstr))) {
+                       /* Make sure we do not lose it early. */
+                       SvREFCNT_inc_simple_void_NN(
+                        sv_2mortal((SV *)old_stash)
+                       );
+                   }
+                   reset_isa = TRUE;
+               }
+

                if (GvGP(dstr))
                    gp_free(MUTABLE_GV(dstr));
                GvGP(dstr) = gp_ref(GvGP(gv));
                if (GvGP(dstr))
                    gp_free(MUTABLE_GV(dstr));
                GvGP(dstr) = gp_ref(GvGP(gv));

+
+               if (reset_isa) {
+                   HV * const stash = GvHV(dstr);
+                   if(
+                       old_stash ? (HV *)HvENAME_get(old_stash) : stash
+                   )
+                       mro_package_moved(
+                        stash, old_stash,
+                        (GV *)dstr, 0
+                       );
+               }

            }
        }
     }
            }
        }
     }


@@ -4600,7 +4688,7 @@ Perl_sv_force_normal_flags(pTHX_ register SV *const sv, const U32 flags)
             }
        }
        else if (IN_PERL_RUNTIME)
             }
        }
        else if (IN_PERL_RUNTIME)

-           Perl_croak(aTHX_ "%s", PL_no_modify);
+           Perl_croak_no_modify(aTHX);

     }
 #else
     if (SvREADONLY(sv)) {
     }
 #else
     if (SvREADONLY(sv)) {


@@ -4617,12 +4705,12 @@ Perl_sv_force_normal_flags(pTHX_ register SV *const sv, const U32 flags)
            unshare_hek(SvSHARED_HEK_FROM_PV(pvx));
        }
        else if (IN_PERL_RUNTIME)
            unshare_hek(SvSHARED_HEK_FROM_PV(pvx));
        }
        else if (IN_PERL_RUNTIME)

-           Perl_croak(aTHX_ "%s", PL_no_modify);
+           Perl_croak_no_modify(aTHX);

     }
 #endif
     if (SvROK(sv))
        sv_unref_flags(sv, flags);
     }
 #endif
     if (SvROK(sv))
        sv_unref_flags(sv, flags);

-    else if (SvFAKE(sv) && SvTYPE(sv) == SVt_PVGV)
+    else if (SvFAKE(sv) && isGV_with_GP(sv))

        sv_unglob(sv);
     else if (SvFAKE(sv) && SvTYPE(sv) == SVt_REGEXP) {
        /* Need to downgrade the REGEXP to a simple(r) scalar. This is analagous
        sv_unglob(sv);
     else if (SvFAKE(sv) && SvTYPE(sv) == SVt_REGEXP) {
        /* Need to downgrade the REGEXP to a simple(r) scalar. This is analagous


@@ -4820,7 +4908,7 @@ Perl_sv_catsv_flags(pTHX_ SV *const dsv, register SV *const ssv, const I32 flags
 
    if (ssv) {
        STRLEN slen;
 
    if (ssv) {
        STRLEN slen;

-       const char *spv = SvPV_const(ssv, slen);
+       const char *spv = SvPV_flags_const(ssv, slen, flags);

        if (spv) {
            /*  sutf8 and dutf8 were type bool, but under USE_ITHREADS,
                gcc version 2.95.2 20000220 (Debian GNU/Linux) for
        if (spv) {
            /*  sutf8 and dutf8 were type bool, but under USE_ITHREADS,
                gcc version 2.95.2 20000220 (Debian GNU/Linux) for


@@ -4888,6 +4976,24 @@ Perl_sv_catpv(pTHX_ register SV *const sv, register const char *ptr)
 }
 
 /*
 }
 
 /*

+=for apidoc sv_catpv_flags
+
+Concatenates the string onto the end of the string which is in the SV.
+If the SV has the UTF-8 status set, then the bytes appended should
+be valid UTF-8.  If C<flags> has C<SV_GMAGIC> bit set, will C<mg_get>
+on the SVs if appropriate, else not.
+
+=cut
+*/
+
+void
+Perl_sv_catpv_flags(pTHX_ SV *dstr, const char *sstr, const I32 flags)
+{
+    PERL_ARGS_ASSERT_SV_CATPV_FLAGS;
+    sv_catpvn_flags(dstr, sstr, strlen(sstr), flags);
+}
+
+/*

 =for apidoc sv_catpv_mg
 
 Like C<sv_catpv>, but also handles 'set' magic.
 =for apidoc sv_catpv_mg
 
 Like C<sv_catpv>, but also handles 'set' magic.


@@ -5070,7 +5176,7 @@ Perl_sv_magic(pTHX_ register SV *const sv, SV *const obj, const int how,
            && how != PERL_MAGIC_backref
           )
        {
            && how != PERL_MAGIC_backref
           )
        {

-           Perl_croak(aTHX_ "%s", PL_no_modify);
+           Perl_croak_no_modify(aTHX);

        }
     }
     if (SvMAGICAL(sv) || (how == PERL_MAGIC_taint && SvTYPE(sv) >= SVt_PVMG)) {
        }
     }
     if (SvMAGICAL(sv) || (how == PERL_MAGIC_taint && SvTYPE(sv) >= SVt_PVMG)) {


@@ -5172,6 +5278,7 @@ Perl_sv_magic(pTHX_ register SV *const sv, SV *const obj, const int how,
     case PERL_MAGIC_rhash:
     case PERL_MAGIC_symtab:
     case PERL_MAGIC_vstring:
     case PERL_MAGIC_rhash:
     case PERL_MAGIC_symtab:
     case PERL_MAGIC_vstring:

+    case PERL_MAGIC_checkcall:

        vtable = NULL;
        break;
     case PERL_MAGIC_utf8:
        vtable = NULL;
        break;
     case PERL_MAGIC_utf8:


@@ -5223,31 +5330,23 @@ Perl_sv_magic(pTHX_ register SV *const sv, SV *const obj, const int how,
     }
 }
 
     }
 }
 

-/*
-=for apidoc sv_unmagic
-
-Removes all magic of type C<type> from an SV.
-
-=cut
-*/
-

 int
 int

-Perl_sv_unmagic(pTHX_ SV *const sv, const int type)
+S_sv_unmagicext_flags(pTHX_ SV *const sv, const int type, MGVTBL *vtbl, const U32 flags)

 {
     MAGIC* mg;
     MAGIC** mgp;
 
 {
     MAGIC* mg;
     MAGIC** mgp;
 

-    PERL_ARGS_ASSERT_SV_UNMAGIC;
+    assert(flags <= 1);

 
     if (SvTYPE(sv) < SVt_PVMG || !SvMAGIC(sv))
        return 0;
     mgp = &(((XPVMG*) SvANY(sv))->xmg_u.xmg_magic);
     for (mg = *mgp; mg; mg = *mgp) {
 
     if (SvTYPE(sv) < SVt_PVMG || !SvMAGIC(sv))
        return 0;
     mgp = &(((XPVMG*) SvANY(sv))->xmg_u.xmg_magic);
     for (mg = *mgp; mg; mg = *mgp) {

-       if (mg->mg_type == type) {
-            const MGVTBL* const vtbl = mg->mg_virtual;
+       const MGVTBL* const virt = mg->mg_virtual;
+       if (mg->mg_type == type && (!flags || virt == vtbl)) {

            *mgp = mg->mg_moremagic;
            *mgp = mg->mg_moremagic;

-           if (vtbl && vtbl->svt_free)
-               CALL_FPTR(vtbl->svt_free)(aTHX_ sv, mg);
+           if (virt && virt->svt_free)
+               virt->svt_free(aTHX_ sv, mg);

            if (mg->mg_ptr && mg->mg_type != PERL_MAGIC_regex_global) {
                if (mg->mg_len > 0)
                    Safefree(mg->mg_ptr);
            if (mg->mg_ptr && mg->mg_type != PERL_MAGIC_regex_global) {
                if (mg->mg_len > 0)
                    Safefree(mg->mg_ptr);


@@ -5275,6 +5374,36 @@ Perl_sv_unmagic(pTHX_ SV *const sv, const int type)
 }
 
 /*
 }
 
 /*

+=for apidoc sv_unmagic
+
+Removes all magic of type C<type> from an SV.
+
+=cut
+*/
+
+int
+Perl_sv_unmagic(pTHX_ SV *const sv, const int type)
+{
+    PERL_ARGS_ASSERT_SV_UNMAGIC;
+    return S_sv_unmagicext_flags(aTHX_ sv, type, NULL, 0);
+}
+
+/*
+=for apidoc sv_unmagicext
+
+Removes all magic of type C<type> with the specified C<vtbl> from an SV.
+
+=cut
+*/
+
+int
+Perl_sv_unmagicext(pTHX_ SV *const sv, const int type, MGVTBL *vtbl)
+{
+    PERL_ARGS_ASSERT_SV_UNMAGICEXT;
+    return S_sv_unmagicext_flags(aTHX_ sv, type, vtbl, 1);
+}
+
+/*

 =for apidoc sv_rvweaken
 
 Weaken a reference: set the C<SvWEAKREF> flag on this RV; give the
 =for apidoc sv_rvweaken
 
 Weaken a reference: set the C<SvWEAKREF> flag on this RV; give the


@@ -5310,6 +5439,13 @@ Perl_sv_rvweaken(pTHX_ SV *const sv)
 
 /* Give tsv backref magic if it hasn't already got it, then push a
  * back-reference to sv onto the array associated with the backref magic.
 
 /* Give tsv backref magic if it hasn't already got it, then push a
  * back-reference to sv onto the array associated with the backref magic.

+ *
+ * As an optimisation, if there's only one backref and it's not an AV,
+ * store it directly in the HvAUX or mg_obj slot, avoiding the need to
+ * allocate an AV. (Whether the slot holds an AV tells us whether this is
+ * active.)
+ *
+ * If an HV's backref is stored in magic, it is moved back to HvAUX.

  */
 
 /* A discussion about the backreferences array and its refcount:
  */
 
 /* A discussion about the backreferences array and its refcount:


@@ -5319,61 +5455,86 @@ Perl_sv_rvweaken(pTHX_ SV *const sv)
  * structure, from the xhv_backreferences field. (A HV without hv_aux will
  * have the standard magic instead.) The array is created with a refcount
  * of 2. This means that if during global destruction the array gets
  * structure, from the xhv_backreferences field. (A HV without hv_aux will
  * have the standard magic instead.) The array is created with a refcount
  * of 2. This means that if during global destruction the array gets

- * picked on first to have its refcount decremented by the random zapper,
- * it won't actually be freed, meaning it's still theere for when its
- * parent gets freed.
- * When the parent SV is freed, in the case of magic, the magic is freed,
- * Perl_magic_killbackrefs is called which decrements one refcount, then
- * mg_obj is freed which kills the second count.
- * In the vase of a HV being freed, one ref is removed by
- * Perl_hv_kill_backrefs, the other by Perl_sv_kill_backrefs, which it
- * calls.
+ * picked on before its parent to have its refcount decremented by the
+ * random zapper, it won't actually be freed, meaning it's still there for
+ * when its parent gets freed.
+ *
+ * When the parent SV is freed, the extra ref is killed by
+ * Perl_sv_kill_backrefs.  The other ref is killed, in the case of magic,
+ * by mg_free() / MGf_REFCOUNTED, or for a hash, by Perl_hv_kill_backrefs.
+ *
+ * When a single backref SV is stored directly, it is not reference
+ * counted.

  */
 
 void
 Perl_sv_add_backref(pTHX_ SV *const tsv, SV *const sv)
 {
     dVAR;
  */
 
 void
 Perl_sv_add_backref(pTHX_ SV *const tsv, SV *const sv)
 {
     dVAR;

-    AV *av;
+    SV **svp;
+    AV *av = NULL;
+    MAGIC *mg = NULL;

 
     PERL_ARGS_ASSERT_SV_ADD_BACKREF;
 
 
     PERL_ARGS_ASSERT_SV_ADD_BACKREF;
 

-    if (SvTYPE(tsv) == SVt_PVHV) {
-       AV **const avp = Perl_hv_backreferences_p(aTHX_ MUTABLE_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);
+    /* find slot to store array or singleton backref */

 
 

-           if (mg) {
-               /* Aha. They've got it stowed in magic.  Bring it back.  */
-               av = MUTABLE_AV(mg->mg_obj);
-               /* Stop mg_free decreasing the refernce count.  */
+    if (SvTYPE(tsv) == SVt_PVHV) {
+       svp = (SV**)Perl_hv_backreferences_p(aTHX_ MUTABLE_HV(tsv));
+
+       if (!*svp) {
+           if ((mg = mg_find(tsv, PERL_MAGIC_backref))) {
+               /* Aha. They've got it stowed in magic instead.
+                * Move it back to xhv_backreferences */
+               *svp = mg->mg_obj;
+               /* Stop mg_free decreasing the reference 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);
                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_simple_void(av); /* see discussion above */
+               mg = NULL;

            }
            }

-           *avp = av;

        }
     } else {
        }
     } else {

-       const MAGIC *const mg
-           = SvMAGICAL(tsv) ? mg_find(tsv, PERL_MAGIC_backref) : NULL;
-       if (mg)
-           av = MUTABLE_AV(mg->mg_obj);
-       else {
-           av = newAV();
-           AvREAL_off(av);
-           sv_magic(tsv, MUTABLE_SV(av), PERL_MAGIC_backref, NULL, 0);
-           /* av now has a refcnt of 2; see discussion above */
+       if (! ((mg =
+           (SvMAGICAL(tsv) ? mg_find(tsv, PERL_MAGIC_backref) : NULL))))
+       {
+           sv_magic(tsv, NULL, PERL_MAGIC_backref, NULL, 0);
+           mg = mg_find(tsv, PERL_MAGIC_backref);

        }
        }

+       svp = &(mg->mg_obj);

     }
     }

+
+    /* create or retrieve the array */
+
+    if (   (!*svp && SvTYPE(sv) == SVt_PVAV)
+       || (*svp && SvTYPE(*svp) != SVt_PVAV)
+    ) {
+       /* create array */
+       av = newAV();
+       AvREAL_off(av);
+       SvREFCNT_inc_simple_void(av);
+       /* av now has a refcnt of 2; see discussion above */
+       if (*svp) {
+           /* move single existing backref to the array */
+           av_extend(av, 1);
+           AvARRAY(av)[++AvFILLp(av)] = *svp; /* av_push() */
+       }
+       *svp = (SV*)av;
+       if (mg)
+           mg->mg_flags |= MGf_REFCOUNTED;
+    }
+    else
+       av = MUTABLE_AV(*svp);
+
+    if (!av) {
+       /* optimisation: store single backref directly in HvAUX or mg_obj */
+       *svp = sv;
+       return;
+    }
+    /* push new backref */
+    assert(SvTYPE(av) == SVt_PVAV);

     if (AvFILLp(av) >= AvMAX(av)) {
         av_extend(av, AvFILLp(av)+1);
     }
     if (AvFILLp(av) >= AvMAX(av)) {
         av_extend(av, AvFILLp(av)+1);
     }


@@ -5384,95 +5545,162 @@ Perl_sv_add_backref(pTHX_ SV *const tsv, SV *const sv)
  * with the SV we point to.
  */
 
  * with the SV we point to.
  */
 

-STATIC void
-S_sv_del_backref(pTHX_ SV *const tsv, SV *const sv)
+void
+Perl_sv_del_backref(pTHX_ SV *const tsv, SV *const sv)

 {
     dVAR;
 {
     dVAR;

-    AV *av = NULL;
-    SV **svp;
-    I32 i;
+    SV **svp = NULL;

 
     PERL_ARGS_ASSERT_SV_DEL_BACKREF;
 
     if (SvTYPE(tsv) == SVt_PVHV && SvOOK(tsv)) {
 
     PERL_ARGS_ASSERT_SV_DEL_BACKREF;
 
     if (SvTYPE(tsv) == SVt_PVHV && SvOOK(tsv)) {

-       av = *Perl_hv_backreferences_p(aTHX_ MUTABLE_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.  */
+       svp = (SV**)Perl_hv_backreferences_p(aTHX_ MUTABLE_HV(tsv));

     }
     }

-    if (!av) {
-       const MAGIC *const mg
+    if (!svp || !*svp) {
+       MAGIC *const mg

            = SvMAGICAL(tsv) ? mg_find(tsv, PERL_MAGIC_backref) : NULL;
            = SvMAGICAL(tsv) ? mg_find(tsv, PERL_MAGIC_backref) : NULL;

-       if (mg)
-           av = MUTABLE_AV(mg->mg_obj);
+       svp =  mg ? &(mg->mg_obj) : NULL;

     }
 
     }
 

-    if (!av)
+    if (!svp || !*svp)

        Perl_croak(aTHX_ "panic: del_backref");
 
        Perl_croak(aTHX_ "panic: del_backref");
 

-    assert(!SvIS_FREED(av));
-
-    svp = AvARRAY(av);
-    /* We shouldn't be in here more than once, but for paranoia reasons lets
-       not assume this.  */
-    for (i = AvFILLp(av); i >= 0; i--) {
-       if (svp[i] == sv) {
-           const SSize_t fill = AvFILLp(av);
-           if (i != fill) {
-               /* We weren't the last entry.
-                  An unordered list has this property that you can take the
-                  last element off the end to fill the hole, and it's still
-                  an unordered list :-)
-               */
-               svp[i] = svp[fill];
+    if (SvTYPE(*svp) == SVt_PVAV) {
+#ifdef DEBUGGING
+       int count = 1;
+#endif
+       AV * const av = (AV*)*svp;
+       SSize_t fill;
+       assert(!SvIS_FREED(av));
+       fill = AvFILLp(av);
+       assert(fill > -1);
+       svp = AvARRAY(av);
+       /* for an SV with N weak references to it, if all those
+        * weak refs are deleted, then sv_del_backref will be called
+        * N times and O(N^2) compares will be done within the backref
+        * array. To ameliorate this potential slowness, we:
+        * 1) make sure this code is as tight as possible;
+        * 2) when looking for SV, look for it at both the head and tail of the
+        *    array first before searching the rest, since some create/destroy
+        *    patterns will cause the backrefs to be freed in order.
+        */
+       if (*svp == sv) {
+           AvARRAY(av)++;
+           AvMAX(av)--;
+       }
+       else {
+           SV **p = &svp[fill];
+           SV *const topsv = *p;
+           if (topsv != sv) {
+#ifdef DEBUGGING
+               count = 0;
+#endif
+               while (--p > svp) {
+                   if (*p == sv) {
+                       /* We weren't the last entry.
+                          An unordered list has this property that you
+                          can take the last element off the end to fill
+                          the hole, and it's still an unordered list :-)
+                       */
+                       *p = topsv;
+#ifdef DEBUGGING
+                       count++;
+#else
+                       break; /* should only be one */
+#endif
+                   }
+               }

            }
            }

-           svp[fill] = NULL;
-           AvFILLp(av) = fill - 1;

        }
        }

+       assert(count ==1);
+       AvFILLp(av) = fill-1;
+    }
+    else {
+       /* optimisation: only a single backref, stored directly */
+       if (*svp != sv)
+           Perl_croak(aTHX_ "panic: del_backref");
+       *svp = NULL;

     }
     }

+

 }
 
 }
 

-int
+void

 Perl_sv_kill_backrefs(pTHX_ SV *const sv, AV *const av)
 {
 Perl_sv_kill_backrefs(pTHX_ SV *const sv, AV *const av)
 {

-    SV **svp = AvARRAY(av);
+    SV **svp;
+    SV **last;
+    bool is_array;

 
     PERL_ARGS_ASSERT_SV_KILL_BACKREFS;
 
     PERL_ARGS_ASSERT_SV_KILL_BACKREFS;

-    PERL_UNUSED_ARG(sv);

 
 

-    assert(!svp || !SvIS_FREED(av));
-    if (svp) {
-       SV *const *const last = svp + AvFILLp(av);
+    if (!av)
+       return;
+
+    is_array = (SvTYPE(av) == SVt_PVAV);
+    if (is_array) {
+       assert(!SvIS_FREED(av));
+       svp = AvARRAY(av);
+       if (svp)
+           last = svp + AvFILLp(av);
+    }
+    else {
+       /* optimisation: only a single backref, stored directly */
+       svp = (SV**)&av;
+       last = svp;
+    }

 
 

+    if (svp) {

        while (svp <= last) {
            if (*svp) {
                SV *const referrer = *svp;
                if (SvWEAKREF(referrer)) {
                    /* XXX Should we check that it hasn't changed? */
        while (svp <= last) {
            if (*svp) {
                SV *const referrer = *svp;
                if (SvWEAKREF(referrer)) {
                    /* XXX Should we check that it hasn't changed? */

+                   assert(SvROK(referrer));

                    SvRV_set(referrer, 0);
                    SvOK_off(referrer);
                    SvWEAKREF_off(referrer);
                    SvSETMAGIC(referrer);
                } else if (SvTYPE(referrer) == SVt_PVGV ||
                           SvTYPE(referrer) == SVt_PVLV) {
                    SvRV_set(referrer, 0);
                    SvOK_off(referrer);
                    SvWEAKREF_off(referrer);
                    SvSETMAGIC(referrer);
                } else if (SvTYPE(referrer) == SVt_PVGV ||
                           SvTYPE(referrer) == SVt_PVLV) {

+                   assert(SvTYPE(sv) == SVt_PVHV); /* stash backref */

                    /* You lookin' at me?  */
                    assert(GvSTASH(referrer));
                    assert(GvSTASH(referrer) == (const HV *)sv);
                    GvSTASH(referrer) = 0;
                    /* You lookin' at me?  */
                    assert(GvSTASH(referrer));
                    assert(GvSTASH(referrer) == (const HV *)sv);
                    GvSTASH(referrer) = 0;

+               } else if (SvTYPE(referrer) == SVt_PVCV ||
+                          SvTYPE(referrer) == SVt_PVFM) {
+                   if (SvTYPE(sv) == SVt_PVHV) { /* stash backref */
+                       /* You lookin' at me?  */
+                       assert(CvSTASH(referrer));
+                       assert(CvSTASH(referrer) == (const HV *)sv);
+                       SvANY(MUTABLE_CV(referrer))->xcv_stash = 0;
+                   }
+                   else {
+                       assert(SvTYPE(sv) == SVt_PVGV);
+                       /* You lookin' at me?  */
+                       assert(CvGV(referrer));
+                       assert(CvGV(referrer) == (const GV *)sv);
+                       anonymise_cv_maybe(MUTABLE_GV(sv),
+                                               MUTABLE_CV(referrer));
+                   }
+

                } else {
                    Perl_croak(aTHX_
                               "panic: magic_killbackrefs (flags=%"UVxf")",
                               (UV)SvFLAGS(referrer));
                }
 
                } else {
                    Perl_croak(aTHX_
                               "panic: magic_killbackrefs (flags=%"UVxf")",
                               (UV)SvFLAGS(referrer));
                }
 

-               *svp = NULL;
+               if (is_array)
+                   *svp = NULL;

            }
            svp++;
        }
     }
            }
            svp++;
        }
     }

-    SvREFCNT_dec(av); /* remove extra count added by sv_add_backref() */
-    return 0;
+    if (is_array) {
+       AvFILLp(av) = -1;
+       SvREFCNT_dec(av); /* remove extra count added by sv_add_backref() */
+    }
+    return;

 }
 
 /*
 }
 
 /*


@@ -5653,6 +5881,45 @@ Perl_sv_replace(pTHX_ register SV *const sv, register SV *const nsv)
     del_SV(nsv);
 }
 
     del_SV(nsv);
 }
 

+/* We're about to free a GV which has a CV that refers back to us.
+ * If that CV will outlive us, make it anonymous (i.e. fix up its CvGV
+ * field) */
+
+STATIC void
+S_anonymise_cv_maybe(pTHX_ GV *gv, CV* cv)
+{
+    char *stash;
+    SV *gvname;
+    GV *anongv;
+
+    PERL_ARGS_ASSERT_ANONYMISE_CV_MAYBE;
+
+    /* be assertive! */
+    assert(SvREFCNT(gv) == 0);
+    assert(isGV(gv) && isGV_with_GP(gv));
+    assert(GvGP(gv));
+    assert(!CvANON(cv));
+    assert(CvGV(cv) == gv);
+
+    /* will the CV shortly be freed by gp_free() ? */
+    if (GvCV(gv) == cv && GvGP(gv)->gp_refcnt < 2 && SvREFCNT(cv) < 2) {
+       SvANY(cv)->xcv_gv = NULL;
+       return;
+    }
+
+    /* if not, anonymise: */
+    stash  = GvSTASH(gv) ? HvNAME(GvSTASH(gv)) : NULL;
+    gvname = Perl_newSVpvf(aTHX_ "%s::__ANON__",
+                                       stash ? stash : "__ANON__");
+    anongv = gv_fetchsv(gvname, GV_ADDMULTI, SVt_PVCV);
+    SvREFCNT_dec(gvname);
+
+    CvANON_on(cv);
+    CvCVGV_RC_on(cv);
+    SvANY(cv)->xcv_gv = MUTABLE_GV(SvREFCNT_inc(anongv));
+}
+
+

 /*
 =for apidoc sv_clear
 
 /*
 =for apidoc sv_clear
 


@@ -5668,224 +5935,323 @@ instead.
 */
 
 void
 */
 
 void

-Perl_sv_clear(pTHX_ register SV *const sv)
+Perl_sv_clear(pTHX_ SV *const orig_sv)

 {
     dVAR;
 {
     dVAR;

-    const U32 type = SvTYPE(sv);
-    const struct body_details *const sv_type_details
-       = bodies_by_type + type;

     HV *stash;
     HV *stash;

+    U32 type;
+    const struct body_details *sv_type_details;
+    SV* iter_sv = NULL;
+    SV* next_sv = NULL;
+    register SV *sv = orig_sv;

 
     PERL_ARGS_ASSERT_SV_CLEAR;
 
     PERL_ARGS_ASSERT_SV_CLEAR;

-    assert(SvREFCNT(sv) == 0);
-    assert(SvTYPE(sv) != SVTYPEMASK);

 
 

-    if (type <= SVt_IV) {
-       /* See the comment in sv.h about the collusion between this early
-          return and the overloading of the NULL slots in the size table.  */
-       if (SvROK(sv))
-           goto free_rv;
-       SvFLAGS(sv) &= SVf_BREAK;
-       SvFLAGS(sv) |= SVTYPEMASK;
-       return;
-    }
+    /* within this loop, sv is the SV currently being freed, and
+     * iter_sv is the most recent AV or whatever that's being iterated
+     * over to provide more SVs */

 
 

-    if (SvOBJECT(sv)) {
-       if (PL_defstash &&      /* Still have a symbol table? */
-           SvDESTROYABLE(sv))
-       {
-           dSP;
-           HV* stash;
-           do {        
-               CV* destructor;
-               stash = SvSTASH(sv);
-               destructor = StashHANDLER(stash,DESTROY);
-               if (destructor
+    while (sv) {
+
+       type = SvTYPE(sv);
+
+       assert(SvREFCNT(sv) == 0);
+       assert(SvTYPE(sv) != SVTYPEMASK);
+
+       if (type <= SVt_IV) {
+           /* See the comment in sv.h about the collusion between this
+            * early return and the overloading of the NULL slots in the
+            * size table.  */
+           if (SvROK(sv))
+               goto free_rv;
+           SvFLAGS(sv) &= SVf_BREAK;
+           SvFLAGS(sv) |= SVTYPEMASK;
+           goto free_head;
+       }
+
+       if (SvOBJECT(sv)) {
+           if (PL_defstash &&  /* Still have a symbol table? */
+               SvDESTROYABLE(sv))
+           {
+               dSP;
+               HV* stash;
+               do {
+                   CV* destructor;
+                   stash = SvSTASH(sv);
+                   destructor = StashHANDLER(stash,DESTROY);
+                   if (destructor

                        /* A constant subroutine can have no side effects, so
                           don't bother calling it.  */
                        && !CvCONST(destructor)
                        /* Don't bother calling an empty destructor */
                        && (CvISXSUB(destructor)
                        || (CvSTART(destructor)
                        /* A constant subroutine can have no side effects, so
                           don't bother calling it.  */
                        && !CvCONST(destructor)
                        /* Don't bother calling an empty destructor */
                        && (CvISXSUB(destructor)
                        || (CvSTART(destructor)

-                           && (CvSTART(destructor)->op_next->op_type != OP_LEAVESUB))))
-               {
-                   SV* const tmpref = newRV(sv);
-                   SvREADONLY_on(tmpref);   /* DESTROY() could be naughty */
-                   ENTER;
-                   PUSHSTACKi(PERLSI_DESTROY);
-                   EXTEND(SP, 2);
-                   PUSHMARK(SP);
-                   PUSHs(tmpref);
-                   PUTBACK;
-                   call_sv(MUTABLE_SV(destructor), G_DISCARD|G_EVAL|G_KEEPERR|G_VOID);
-               
-               
-                   POPSTACK;
-                   SPAGAIN;
-                   LEAVE;
-                   if(SvREFCNT(tmpref) < 2) {
-                       /* tmpref is not kept alive! */
-                       SvREFCNT(sv)--;
-                       SvRV_set(tmpref, NULL);
-                       SvROK_off(tmpref);
+                           && (CvSTART(destructor)->op_next->op_type
+                                               != OP_LEAVESUB))))
+                   {
+                       SV* const tmpref = newRV(sv);
+                       SvREADONLY_on(tmpref); /* DESTROY() could be naughty */
+                       ENTER;
+                       PUSHSTACKi(PERLSI_DESTROY);
+                       EXTEND(SP, 2);
+                       PUSHMARK(SP);
+                       PUSHs(tmpref);
+                       PUTBACK;
+                       call_sv(MUTABLE_SV(destructor),
+                                   G_DISCARD|G_EVAL|G_KEEPERR|G_VOID);
+                       POPSTACK;
+                       SPAGAIN;
+                       LEAVE;
+                       if(SvREFCNT(tmpref) < 2) {
+                           /* tmpref is not kept alive! */
+                           SvREFCNT(sv)--;
+                           SvRV_set(tmpref, NULL);
+                           SvROK_off(tmpref);
+                       }
+                       SvREFCNT_dec(tmpref);

                    }
                    }

-                   SvREFCNT_dec(tmpref);
-               }
-           } while (SvOBJECT(sv) && SvSTASH(sv) != stash);
+               } while (SvOBJECT(sv) && SvSTASH(sv) != stash);

 
 
 
 

-           if (SvREFCNT(sv)) {
-               if (PL_in_clean_objs)
-                   Perl_croak(aTHX_ "DESTROY created new reference to dead object '%s'",
-                         HvNAME_get(stash));
-               /* DESTROY gave object new lease on life */
-               return;
+               if (SvREFCNT(sv)) {
+                   if (PL_in_clean_objs)
+                       Perl_croak(aTHX_
+                           "DESTROY created new reference to dead object '%s'",
+                           HvNAME_get(stash));
+                   /* DESTROY gave object new lease on life */
+                   goto get_next_sv;
+               }

            }
            }

-       }

 
 

-       if (SvOBJECT(sv)) {
-           SvREFCNT_dec(SvSTASH(sv));  /* possibly of changed persuasion */
-           SvOBJECT_off(sv);   /* Curse the object. */
-           if (type != SVt_PVIO)
-               --PL_sv_objcount;       /* XXX Might want something more general */
-       }
-    }
-    if (type >= SVt_PVMG) {
-       if (type == SVt_PVMG && SvPAD_OUR(sv)) {
-           SvREFCNT_dec(SvOURSTASH(sv));
-       } else if (SvMAGIC(sv))
-           mg_free(sv);
-       if (type == SVt_PVMG && SvPAD_TYPED(sv))
-           SvREFCNT_dec(SvSTASH(sv));
-    }
-    switch (type) {
-       /* case SVt_BIND: */
-    case SVt_PVIO:
-       if (IoIFP(sv) &&
-           IoIFP(sv) != PerlIO_stdin() &&
-           IoIFP(sv) != PerlIO_stdout() &&
-           IoIFP(sv) != PerlIO_stderr())
-       {
-           io_close(MUTABLE_IO(sv), FALSE);
-       }
-       if (IoDIRP(sv) && !(IoFLAGS(sv) & IOf_FAKE_DIRP))
-           PerlDir_close(IoDIRP(sv));
-       IoDIRP(sv) = (DIR*)NULL;
-       Safefree(IoTOP_NAME(sv));
-       Safefree(IoFMT_NAME(sv));
-       Safefree(IoBOTTOM_NAME(sv));
-       goto freescalar;
-    case SVt_REGEXP:
-       /* FIXME for plugins */
-       pregfree2((REGEXP*) sv);
-       goto freescalar;
-    case SVt_PVCV:
-    case SVt_PVFM:
-       cv_undef(MUTABLE_CV(sv));
-       goto freescalar;
-    case SVt_PVHV:
-       if (PL_last_swash_hv == (const HV *)sv) {
-           PL_last_swash_hv = NULL;
-       }
-       Perl_hv_kill_backrefs(aTHX_ MUTABLE_HV(sv));
-       hv_undef(MUTABLE_HV(sv));
-       break;
-    case SVt_PVAV:
-       if (PL_comppad == MUTABLE_AV(sv)) {
-           PL_comppad = NULL;
-           PL_curpad = NULL;
+           if (SvOBJECT(sv)) {
+               SvREFCNT_dec(SvSTASH(sv)); /* possibly of changed persuasion */
+               SvOBJECT_off(sv);       /* Curse the object. */
+               if (type != SVt_PVIO)
+                   --PL_sv_objcount;/* XXX Might want something more general */
+           }

        }
        }

-       av_undef(MUTABLE_AV(sv));
-       break;
-    case SVt_PVLV:
-       if (LvTYPE(sv) == 'T') { /* for tie: return HE to pool */
-           SvREFCNT_dec(HeKEY_sv((HE*)LvTARG(sv)));
-           HeNEXT((HE*)LvTARG(sv)) = PL_hv_fetch_ent_mh;
-           PL_hv_fetch_ent_mh = (HE*)LvTARG(sv);
+       if (type >= SVt_PVMG) {
+           if (type == SVt_PVMG && SvPAD_OUR(sv)) {
+               SvREFCNT_dec(SvOURSTASH(sv));
+           } else if (SvMAGIC(sv))
+               mg_free(sv);
+           if (type == SVt_PVMG && SvPAD_TYPED(sv))
+               SvREFCNT_dec(SvSTASH(sv));

        }
        }

-       else if (LvTYPE(sv) != 't') /* unless tie: unrefcnted fake SV**  */
-           SvREFCNT_dec(LvTARG(sv));
-    case SVt_PVGV:
-       if (isGV_with_GP(sv)) {
-            if(GvCVu((const GV *)sv) && (stash = GvSTASH(MUTABLE_GV(sv)))
-              && HvNAME_get(stash))
-                mro_method_changed_in(stash);
-           gp_free(MUTABLE_GV(sv));
-           if (GvNAME_HEK(sv))
-               unshare_hek(GvNAME_HEK(sv));
-           /* If we're in a stash, we don't own a reference to it. However it does
-              have a back reference to us, which needs to be cleared.  */
-           if (!SvVALID(sv) && (stash = GvSTASH(sv)))
-                   sv_del_backref(MUTABLE_SV(stash), sv);
-       }
-       /* FIXME. There are probably more unreferenced pointers to SVs in the
-          interpreter struct that we should check and tidy in a similar
-          fashion to this:  */
-       if ((const GV *)sv == PL_last_in_gv)
-           PL_last_in_gv = NULL;
-    case SVt_PVMG:
-    case SVt_PVNV:
-    case SVt_PVIV:
-    case SVt_PV:
-      freescalar:
-       /* Don't bother with SvOOK_off(sv); as we're only going to free it.  */
-       if (SvOOK(sv)) {
-           STRLEN offset;
-           SvOOK_offset(sv, offset);
-           SvPV_set(sv, SvPVX_mutable(sv) - offset);
-           /* Don't even bother with turning off the OOK flag.  */
-       }
-       if (SvROK(sv)) {
-       free_rv:
+       switch (type) {
+           /* case SVt_BIND: */
+       case SVt_PVIO:
+           if (IoIFP(sv) &&
+               IoIFP(sv) != PerlIO_stdin() &&
+               IoIFP(sv) != PerlIO_stdout() &&
+               IoIFP(sv) != PerlIO_stderr() &&
+               !(IoFLAGS(sv) & IOf_FAKE_DIRP))

            {
            {

-               SV * const target = SvRV(sv);
-               if (SvWEAKREF(sv))
-                   sv_del_backref(target, sv);
-               else
-                   SvREFCNT_dec(target);
+               io_close(MUTABLE_IO(sv), FALSE);
+           }
+           if (IoDIRP(sv) && !(IoFLAGS(sv) & IOf_FAKE_DIRP))
+               PerlDir_close(IoDIRP(sv));
+           IoDIRP(sv) = (DIR*)NULL;
+           Safefree(IoTOP_NAME(sv));
+           Safefree(IoFMT_NAME(sv));
+           Safefree(IoBOTTOM_NAME(sv));
+           goto freescalar;
+       case SVt_REGEXP:
+           /* FIXME for plugins */
+           pregfree2((REGEXP*) sv);
+           goto freescalar;
+       case SVt_PVCV:
+       case SVt_PVFM:
+           cv_undef(MUTABLE_CV(sv));
+           /* If we're in a stash, we don't own a reference to it.
+            * However it does have a back reference to us, which needs to
+            * be cleared.  */
+           if ((stash = CvSTASH(sv)))
+               sv_del_backref(MUTABLE_SV(stash), sv);
+           goto freescalar;
+       case SVt_PVHV:
+           if (PL_last_swash_hv == (const HV *)sv) {
+               PL_last_swash_hv = NULL;
+           }
+           Perl_hv_kill_backrefs(aTHX_ MUTABLE_HV(sv));
+           Perl_hv_undef_flags(aTHX_ MUTABLE_HV(sv), HV_NAME_SETALL);
+           break;
+       case SVt_PVAV:
+           {
+               AV* av = MUTABLE_AV(sv);
+               if (PL_comppad == av) {
+                   PL_comppad = NULL;
+                   PL_curpad = NULL;
+               }
+               if (AvREAL(av) && AvFILLp(av) > -1) {
+                   next_sv = AvARRAY(av)[AvFILLp(av)--];
+                   /* save old iter_sv in top-most slot of AV,
+                    * and pray that it doesn't get wiped in the meantime */
+                   AvARRAY(av)[AvMAX(av)] = iter_sv;
+                   iter_sv = sv;
+                   goto get_next_sv; /* process this new sv */
+               }
+               Safefree(AvALLOC(av));
+           }
+
+           break;
+       case SVt_PVLV:
+           if (LvTYPE(sv) == 'T') { /* for tie: return HE to pool */
+               SvREFCNT_dec(HeKEY_sv((HE*)LvTARG(sv)));
+               HeNEXT((HE*)LvTARG(sv)) = PL_hv_fetch_ent_mh;
+               PL_hv_fetch_ent_mh = (HE*)LvTARG(sv);
+           }
+           else if (LvTYPE(sv) != 't') /* unless tie: unrefcnted fake SV**  */
+               SvREFCNT_dec(LvTARG(sv));
+       case SVt_PVGV:
+           if (isGV_with_GP(sv)) {
+               if(GvCVu((const GV *)sv) && (stash = GvSTASH(MUTABLE_GV(sv)))
+                  && HvENAME_get(stash))
+                   mro_method_changed_in(stash);
+               gp_free(MUTABLE_GV(sv));
+               if (GvNAME_HEK(sv))
+                   unshare_hek(GvNAME_HEK(sv));
+               /* If we're in a stash, we don't own a reference to it.
+                * However it does have a back reference to us, which
+                * needs to be cleared.  */
+               if (!SvVALID(sv) && (stash = GvSTASH(sv)))
+                       sv_del_backref(MUTABLE_SV(stash), sv);
+           }
+           /* FIXME. There are probably more unreferenced pointers to SVs
+            * in the interpreter struct that we should check and tidy in
+            * a similar fashion to this:  */
+           if ((const GV *)sv == PL_last_in_gv)
+               PL_last_in_gv = NULL;
+       case SVt_PVMG:
+       case SVt_PVNV:
+       case SVt_PVIV:
+       case SVt_PV:
+         freescalar:
+           /* Don't bother with SvOOK_off(sv); as we're only going to
+            * free it.  */
+           if (SvOOK(sv)) {
+               STRLEN offset;
+               SvOOK_offset(sv, offset);
+               SvPV_set(sv, SvPVX_mutable(sv) - offset);
+               /* Don't even bother with turning off the OOK flag.  */
+           }
+           if (SvROK(sv)) {
+           free_rv:
+               {
+                   SV * const target = SvRV(sv);
+                   if (SvWEAKREF(sv))
+                       sv_del_backref(target, sv);
+                   else
+                       next_sv = target;
+               }

            }
            }

-       }

 #ifdef PERL_OLD_COPY_ON_WRITE
 #ifdef PERL_OLD_COPY_ON_WRITE

-       else if (SvPVX_const(sv)) {
-            if (SvIsCOW(sv)) {
-                if (DEBUG_C_TEST) {
-                    PerlIO_printf(Perl_debug_log, "Copy on write: clear\n");
-                    sv_dump(sv);
-                }
-               if (SvLEN(sv)) {
-                   sv_release_COW(sv, SvPVX_const(sv), SV_COW_NEXT_SV(sv));
-               } else {
-                   unshare_hek(SvSHARED_HEK_FROM_PV(SvPVX_const(sv)));
+           else if (SvPVX_const(sv)
+                    && !(SvTYPE(sv) == SVt_PVIO
+                    && !(IoFLAGS(sv) & IOf_FAKE_DIRP)))
+           {
+               if (SvIsCOW(sv)) {
+                   if (DEBUG_C_TEST) {
+                       PerlIO_printf(Perl_debug_log, "Copy on write: clear\n");
+                       sv_dump(sv);
+                   }
+                   if (SvLEN(sv)) {
+                       sv_release_COW(sv, SvPVX_const(sv), SV_COW_NEXT_SV(sv));
+                   } else {
+                       unshare_hek(SvSHARED_HEK_FROM_PV(SvPVX_const(sv)));
+                   }
+
+                   SvFAKE_off(sv);
+               } else if (SvLEN(sv)) {
+                   Safefree(SvPVX_const(sv));

                }
                }

+           }
+#else
+           else if (SvPVX_const(sv) && SvLEN(sv)
+                    && !(SvTYPE(sv) == SVt_PVIO
+                    && !(IoFLAGS(sv) & IOf_FAKE_DIRP)))
+               Safefree(SvPVX_mutable(sv));
+           else if (SvPVX_const(sv) && SvREADONLY(sv) && SvFAKE(sv)) {
+               unshare_hek(SvSHARED_HEK_FROM_PV(SvPVX_const(sv)));
+               SvFAKE_off(sv);
+           }
+#endif
+           break;
+       case SVt_NV:
+           break;
+       }

 
 

-                SvFAKE_off(sv);
-            } else if (SvLEN(sv)) {
-                Safefree(SvPVX_const(sv));
-            }
+      free_body:
+
+       SvFLAGS(sv) &= SVf_BREAK;
+       SvFLAGS(sv) |= SVTYPEMASK;
+
+       sv_type_details = bodies_by_type + type;
+       if (sv_type_details->arena) {
+           del_body(((char *)SvANY(sv) + sv_type_details->offset),
+                    &PL_body_roots[type]);

        }
        }

-#else
-       else if (SvPVX_const(sv) && SvLEN(sv))
-           Safefree(SvPVX_mutable(sv));
-       else if (SvPVX_const(sv) && SvREADONLY(sv) && SvFAKE(sv)) {
-           unshare_hek(SvSHARED_HEK_FROM_PV(SvPVX_const(sv)));
-           SvFAKE_off(sv);
+       else if (sv_type_details->body_size) {
+           safefree(SvANY(sv));

        }
        }

-#endif
-       break;
-    case SVt_NV:
-       break;
-    }

 
 

-    SvFLAGS(sv) &= SVf_BREAK;
-    SvFLAGS(sv) |= SVTYPEMASK;
+      free_head:
+       /* caller is responsible for freeing the head of the original sv */
+       if (sv != orig_sv && !SvREFCNT(sv))
+           del_SV(sv);

 
 

-    if (sv_type_details->arena) {
-       del_body(((char *)SvANY(sv) + sv_type_details->offset),
-                &PL_body_roots[type]);
-    }
-    else if (sv_type_details->body_size) {
-       my_safefree(SvANY(sv));
-    }
+       /* grab and free next sv, if any */
+      get_next_sv:
+       while (1) {
+           sv = NULL;
+           if (next_sv) {
+               sv = next_sv;
+               next_sv = NULL;
+           }
+           else if (!iter_sv) {
+               break;
+           } else if (SvTYPE(iter_sv) == SVt_PVAV) {
+               AV *const av = (AV*)iter_sv;
+               if (AvFILLp(av) > -1) {
+                   sv = AvARRAY(av)[AvFILLp(av)--];
+               }
+               else { /* no more elements of current AV to free */
+                   sv = iter_sv;
+                   type = SvTYPE(sv);
+                   /* restore previous value, squirrelled away */
+                   iter_sv = AvARRAY(av)[AvMAX(av)];
+                   Safefree(AvALLOC(av));
+                   goto free_body;
+               }
+           }
+
+           /* unrolled SvREFCNT_dec and sv_free2 follows: */
+
+           if (!sv)
+               continue;
+           if (!SvREFCNT(sv)) {
+               sv_free(sv);
+               continue;
+           }
+           if (--(SvREFCNT(sv)))
+               continue;
+#ifdef DEBUGGING
+           if (SvTEMP(sv)) {
+               Perl_ck_warner_d(aTHX_ packWARN(WARN_DEBUGGING),
+                        "Attempt to free temp prematurely: SV 0x%"UVxf
+                        pTHX__FORMAT, PTR2UV(sv) pTHX__VALUE);
+               continue;
+           }
+#endif
+           if (SvREADONLY(sv) && SvIMMORTAL(sv)) {
+               /* make sure SvREFCNT(sv)==0 happens very seldom */
+               SvREFCNT(sv) = (~(U32)0)/2;
+               continue;
+           }
+           break;
+       } /* while 1 */
+
+    } /* while sv */

 }
 
 /*
 }
 
 /*


@@ -6049,37 +6415,26 @@ Perl_sv_len_utf8(pTHX_ register SV *const sv)
            STRLEN ulen;
            MAGIC *mg = SvMAGICAL(sv) ? mg_find(sv, PERL_MAGIC_utf8) : NULL;
 
            STRLEN ulen;
            MAGIC *mg = SvMAGICAL(sv) ? mg_find(sv, PERL_MAGIC_utf8) : NULL;
 

-           if (mg && mg->mg_len != -1) {
-               ulen = mg->mg_len;
+           if (mg && (mg->mg_len != -1 || mg->mg_ptr)) {
+               if (mg->mg_len != -1)
+                   ulen = mg->mg_len;
+               else {
+                   /* We can use the offset cache for a headstart.
+                      The longer value is stored in the first pair.  */
+                   STRLEN *cache = (STRLEN *) mg->mg_ptr;
+
+                   ulen = cache[0] + Perl_utf8_length(aTHX_ s + cache[1],
+                                                      s + len);
+               }
+               

                if (PL_utf8cache < 0) {
                    const STRLEN real = Perl_utf8_length(aTHX_ s, s + len);
                if (PL_utf8cache < 0) {
                    const STRLEN real = Perl_utf8_length(aTHX_ s, s + len);

-                   if (real != ulen) {
-                       /* Need to turn the assertions off otherwise we may
-                          recurse infinitely while printing error messages.
-                       */
-                       SAVEI8(PL_utf8cache);
-                       PL_utf8cache = 0;
-                       Perl_croak(aTHX_ "panic: sv_len_utf8 cache %"UVuf
-                                  " real %"UVuf" for %"SVf,
-                                  (UV) ulen, (UV) real, SVfARG(sv));
-                   }
+                   assert_uft8_cache_coherent("sv_len_utf8", ulen, real, sv);

                }
            }
            else {
                ulen = Perl_utf8_length(aTHX_ s, s + len);
                }
            }
            else {
                ulen = Perl_utf8_length(aTHX_ s, s + len);

-               if (!SvREADONLY(sv)) {
-                   if (!mg && (SvTYPE(sv) < SVt_PVMG ||
-                               !(mg = mg_find(sv, PERL_MAGIC_utf8)))) {
-                       mg = sv_magicext(sv, 0, PERL_MAGIC_utf8,
-                                        &PL_vtbl_utf8, 0, 0);
-                   }
-                   assert(mg);
-                   mg->mg_len = ulen;
-                   /* For now, treat "overflowed" as "still unknown".
-                      See RT #72924.  */
-                   if (ulen != (STRLEN) mg->mg_len)
-                       mg->mg_len = -1;
-               }
+               utf8_mg_len_cache_update(sv, &mg, ulen);

            }
            return ulen;
        }
            }
            return ulen;
        }


@@ -6091,19 +6446,27 @@ Perl_sv_len_utf8(pTHX_ register SV *const sv)
    offset.  */
 static STRLEN
 S_sv_pos_u2b_forwards(const U8 *const start, const U8 *const send,
    offset.  */
 static STRLEN
 S_sv_pos_u2b_forwards(const U8 *const start, const U8 *const send,

-                     STRLEN uoffset)
+                     STRLEN *const uoffset_p, bool *const at_end)

 {
     const U8 *s = start;
 {
     const U8 *s = start;

+    STRLEN uoffset = *uoffset_p;

 
     PERL_ARGS_ASSERT_SV_POS_U2B_FORWARDS;
 
 
     PERL_ARGS_ASSERT_SV_POS_U2B_FORWARDS;
 

-    while (s < send && uoffset--)
+    while (s < send && uoffset) {
+       --uoffset;

        s += UTF8SKIP(s);
        s += UTF8SKIP(s);

-    if (s > send) {
+    }
+    if (s == send) {
+       *at_end = TRUE;
+    }
+    else if (s > send) {
+       *at_end = TRUE;

        /* This is the existing behaviour. Possibly it should be a croak, as
           it's actually a bounds error  */
        s = send;
     }
        /* This is the existing behaviour. Possibly it should be a croak, as
           it's actually a bounds error  */
        s = send;
     }

+    *uoffset_p -= uoffset;

     return s - start;
 }
 
     return s - start;
 }
 


@@ -6112,7 +6475,7 @@ S_sv_pos_u2b_forwards(const U8 *const start, const U8 *const send,
    the passed in UTF-8 offset.  */
 static STRLEN
 S_sv_pos_u2b_midway(const U8 *const start, const U8 *send,
    the passed in UTF-8 offset.  */
 static STRLEN
 S_sv_pos_u2b_midway(const U8 *const start, const U8 *send,

-                     const STRLEN uoffset, const STRLEN uend)
+                   STRLEN uoffset, const STRLEN uend)

 {
     STRLEN backw = uend - uoffset;
 
 {
     STRLEN backw = uend - uoffset;
 


@@ -6122,7 +6485,14 @@ S_sv_pos_u2b_midway(const U8 *const start, const U8 *send,
        /* The assumption is that going forwards is twice the speed of going
           forward (that's where the 2 * backw comes from).
           (The real figure of course depends on the UTF-8 data.)  */
        /* The assumption is that going forwards is twice the speed of going
           forward (that's where the 2 * backw comes from).
           (The real figure of course depends on the UTF-8 data.)  */

-       return sv_pos_u2b_forwards(start, send, uoffset);
+       const U8 *s = start;
+
+       while (s < send && uoffset--)
+           s += UTF8SKIP(s);
+       assert (s <= send);
+       if (s > send)
+           s = send;
+       return s - start;

     }
 
     while (backw--) {
     }
 
     while (backw--) {


@@ -6143,16 +6513,20 @@ S_sv_pos_u2b_midway(const U8 *const start, const U8 *send,
    created if necessary, and the found value offered to it for update.  */
 static STRLEN
 S_sv_pos_u2b_cached(pTHX_ SV *const sv, MAGIC **const mgp, const U8 *const start,
    created if necessary, and the found value offered to it for update.  */
 static STRLEN
 S_sv_pos_u2b_cached(pTHX_ SV *const sv, MAGIC **const mgp, const U8 *const start,

-                   const U8 *const send, const STRLEN uoffset,
+                   const U8 *const send, STRLEN uoffset,

                    STRLEN uoffset0, STRLEN boffset0)
 {
     STRLEN boffset = 0; /* Actually always set, but let's keep gcc happy.  */
     bool found = FALSE;
                    STRLEN uoffset0, STRLEN boffset0)
 {
     STRLEN boffset = 0; /* Actually always set, but let's keep gcc happy.  */
     bool found = FALSE;

+    bool at_end = FALSE;

 
     PERL_ARGS_ASSERT_SV_POS_U2B_CACHED;
 
     assert (uoffset >= uoffset0);
 
 
     PERL_ARGS_ASSERT_SV_POS_U2B_CACHED;
 
     assert (uoffset >= uoffset0);
 

+    if (!uoffset)
+       return 0;
+

     if (!SvREADONLY(sv)
        && PL_utf8cache
        && (*mgp || (SvTYPE(sv) >= SVt_PVMG &&
     if (!SvREADONLY(sv)
        && PL_utf8cache
        && (*mgp || (SvTYPE(sv) >= SVt_PVMG &&


@@ -6182,9 +6556,11 @@ S_sv_pos_u2b_cached(pTHX_ SV *const sv, MAGIC **const mgp, const U8 *const start
                                              uoffset - uoffset0,
                                              (*mgp)->mg_len - uoffset0);
                } else {
                                              uoffset - uoffset0,
                                              (*mgp)->mg_len - uoffset0);
                } else {

+                   uoffset -= uoffset0;

                    boffset = boffset0
                        + sv_pos_u2b_forwards(start + boffset0,
                    boffset = boffset0
                        + sv_pos_u2b_forwards(start + boffset0,

-                                               send, uoffset - uoffset0);
+                                             send, &uoffset, &at_end);
+                   uoffset += uoffset0;

                }
            }
            else if (cache[2] < uoffset) {
                }
            }
            else if (cache[2] < uoffset) {


@@ -6222,26 +6598,24 @@ S_sv_pos_u2b_cached(pTHX_ SV *const sv, MAGIC **const mgp, const U8 *const start
     }
 
     if (!found || PL_utf8cache < 0) {
     }
 
     if (!found || PL_utf8cache < 0) {

-       const STRLEN real_boffset
-           = boffset0 + sv_pos_u2b_forwards(start + boffset0,
-                                              send, uoffset - uoffset0);
-
-       if (found && PL_utf8cache < 0) {
-           if (real_boffset != boffset) {
-               /* Need to turn the assertions off otherwise we may recurse
-                  infinitely while printing error messages.  */
-               SAVEI8(PL_utf8cache);
-               PL_utf8cache = 0;
-               Perl_croak(aTHX_ "panic: sv_pos_u2b_cache cache %"UVuf
-                          " real %"UVuf" for %"SVf,
-                          (UV) boffset, (UV) real_boffset, SVfARG(sv));
-           }
-       }
+       STRLEN real_boffset;
+       uoffset -= uoffset0;
+       real_boffset = boffset0 + sv_pos_u2b_forwards(start + boffset0,
+                                                     send, &uoffset, &at_end);
+       uoffset += uoffset0;
+
+       if (found && PL_utf8cache < 0)
+           assert_uft8_cache_coherent("sv_pos_u2b_cache", boffset,
+                                      real_boffset, sv);

        boffset = real_boffset;
     }
 
        boffset = real_boffset;
     }
 

-    if (PL_utf8cache)
-       utf8_mg_pos_cache_update(sv, mgp, boffset, uoffset, send - start);
+    if (PL_utf8cache) {
+       if (at_end)
+           utf8_mg_len_cache_update(sv, mgp, uoffset);
+       else
+           utf8_mg_pos_cache_update(sv, mgp, boffset, uoffset, send - start);
+    }

     return boffset;
 }
 
     return boffset;
 }
 


@@ -6282,7 +6656,9 @@ Perl_sv_pos_u2b_flags(pTHX_ SV *const sv, STRLEN uoffset, STRLEN *const lenp,
        MAGIC *mg = NULL;
        boffset = sv_pos_u2b_cached(sv, &mg, start, send, uoffset, 0, 0);
 
        MAGIC *mg = NULL;
        boffset = sv_pos_u2b_cached(sv, &mg, start, send, uoffset, 0, 0);
 

-       if (lenp) {
+       if (lenp
+           && *lenp /* don't bother doing work for 0, as its bytes equivalent
+                       is 0, and *lenp is already set to that.  */) {

            /* Convert the relative offset to absolute.  */
            const STRLEN uoffset2 = uoffset + *lenp;
            const STRLEN boffset2
            /* Convert the relative offset to absolute.  */
            const STRLEN uoffset2 = uoffset + *lenp;
            const STRLEN boffset2


@@ -6340,6 +6716,26 @@ Perl_sv_pos_u2b(pTHX_ register SV *const sv, I32 *const offsetp, I32 *const lenp
     }
 }
 
     }
 }
 

+static void
+S_utf8_mg_len_cache_update(pTHX_ SV *const sv, MAGIC **const mgp,
+                          const STRLEN ulen)
+{
+    PERL_ARGS_ASSERT_UTF8_MG_LEN_CACHE_UPDATE;
+    if (SvREADONLY(sv))
+       return;
+
+    if (!*mgp && (SvTYPE(sv) < SVt_PVMG ||
+                 !(*mgp = mg_find(sv, PERL_MAGIC_utf8)))) {
+       *mgp = sv_magicext(sv, 0, PERL_MAGIC_utf8, &PL_vtbl_utf8, 0, 0);
+    }
+    assert(*mgp);
+
+    (*mgp)->mg_len = ulen;
+    /* For now, treat "overflowed" as "still unknown". See RT #72924.  */
+    if (ulen != (STRLEN) (*mgp)->mg_len)
+       (*mgp)->mg_len = -1;
+}
+

 /* Create and update the UTF8 magic offset cache, with the proffered utf8/
    byte length pairing. The (byte) length of the total SV is passed in too,
    as blen, because for some (more esoteric) SVs, the call to SvPV_const()
 /* Create and update the UTF8 magic offset cache, with the proffered utf8/
    byte length pairing. The (byte) length of the total SV is passed in too,
    as blen, because for some (more esoteric) SVs, the call to SvPV_const()


@@ -6398,14 +6794,8 @@ S_utf8_mg_pos_cache_update(pTHX_ SV *const sv, MAGIC **const mgp, const STRLEN b
        const U8 *start = (const U8 *) SvPVX_const(sv);
        const STRLEN realutf8 = utf8_length(start, start + byte);
 
        const U8 *start = (const U8 *) SvPVX_const(sv);
        const STRLEN realutf8 = utf8_length(start, start + byte);
 

-       if (realutf8 != utf8) {
-           /* Need to turn the assertions off otherwise we may recurse
-              infinitely while printing error messages.  */
-           SAVEI8(PL_utf8cache);
-           PL_utf8cache = 0;
-           Perl_croak(aTHX_ "panic: utf8_mg_pos_cache_update cache %"UVuf
-                      " real %"UVuf" for %"SVf, (UV) utf8, (UV) realutf8, SVfARG(sv));
-       }
+       assert_uft8_cache_coherent("utf8_mg_pos_cache_update", utf8, realutf8,
+                                  sv);

     }
 
     /* Cache is held with the later position first, to simplify the code
     }
 
     /* Cache is held with the later position first, to simplify the code


@@ -6626,23 +7016,37 @@ Perl_sv_pos_b2u(pTHX_ register SV *const sv, I32 *const offsetp)
     if (!found || PL_utf8cache < 0) {
        const STRLEN real_len = utf8_length(s, send);
 
     if (!found || PL_utf8cache < 0) {
        const STRLEN real_len = utf8_length(s, send);
 

-       if (found && PL_utf8cache < 0) {
-           if (len != real_len) {
-               /* Need to turn the assertions off otherwise we may recurse
-                  infinitely while printing error messages.  */
-               SAVEI8(PL_utf8cache);
-               PL_utf8cache = 0;
-               Perl_croak(aTHX_ "panic: sv_pos_b2u cache %"UVuf
-                          " real %"UVuf" for %"SVf,
-                          (UV) len, (UV) real_len, SVfARG(sv));
-           }
-       }
+       if (found && PL_utf8cache < 0)
+           assert_uft8_cache_coherent("sv_pos_b2u", len, real_len, sv);

        len = real_len;
     }
     *offsetp = len;
 
        len = real_len;
     }
     *offsetp = len;
 

-    if (PL_utf8cache)
-       utf8_mg_pos_cache_update(sv, &mg, byte, len, blen);
+    if (PL_utf8cache) {
+       if (blen == byte)
+           utf8_mg_len_cache_update(sv, &mg, len);
+       else
+           utf8_mg_pos_cache_update(sv, &mg, byte, len, blen);
+    }
+}
+
+static void
+S_assert_uft8_cache_coherent(pTHX_ const char *const func, STRLEN from_cache,
+                            STRLEN real, SV *const sv)
+{
+    PERL_ARGS_ASSERT_ASSERT_UFT8_CACHE_COHERENT;
+
+    /* As this is debugging only code, save space by keeping this test here,
+       rather than inlining it in all the callers.  */
+    if (from_cache == real)
+       return;
+
+    /* Need to turn the assertions off otherwise we may recurse infinitely
+       while printing error messages.  */
+    SAVEI8(PL_utf8cache);
+    PL_utf8cache = 0;
+    Perl_croak(aTHX_ "panic: %s cache %"UVuf" real %"UVuf" for %"SVf,
+              func, (UV) from_cache, (UV) real, SVfARG(sv));

 }
 
 /*
 }
 
 /*


@@ -6652,11 +7056,17 @@ Returns a boolean indicating whether the strings in the two SVs are
 identical. Is UTF-8 and 'use bytes' aware, handles get magic, and will
 coerce its args to strings if necessary.
 
 identical. Is UTF-8 and 'use bytes' aware, handles get magic, and will
 coerce its args to strings if necessary.
 

+=for apidoc sv_eq_flags
+
+Returns a boolean indicating whether the strings in the two SVs are
+identical. Is UTF-8 and 'use bytes' aware and coerces its args to strings
+if necessary. If the flags include SV_GMAGIC, it handles get-magic, too.
+

 =cut
 */
 
 I32
 =cut
 */
 
 I32

-Perl_sv_eq(pTHX_ register SV *sv1, register SV *sv2)
+Perl_sv_eq_flags(pTHX_ register SV *sv1, register SV *sv2, const U32 flags)

 {
     dVAR;
     const char *pv1;
 {
     dVAR;
     const char *pv1;


@@ -6673,12 +7083,14 @@ Perl_sv_eq(pTHX_ register SV *sv1, register SV *sv2)
     }
     else {
        /* if pv1 and pv2 are the same, second SvPV_const call may
     }
     else {
        /* if pv1 and pv2 are the same, second SvPV_const call may

-        * invalidate pv1, so we may need to make a copy */
-       if (sv1 == sv2 && (SvTHINKFIRST(sv1) || SvGMAGICAL(sv1))) {
+        * invalidate pv1 (if we are handling magic), so we may need to
+        * make a copy */
+       if (sv1 == sv2 && flags & SV_GMAGIC
+        && (SvTHINKFIRST(sv1) || SvGMAGICAL(sv1))) {

            pv1 = SvPV_const(sv1, cur1);
            sv1 = newSVpvn_flags(pv1, cur1, SVs_TEMP | SvUTF8(sv2));
        }
            pv1 = SvPV_const(sv1, cur1);
            sv1 = newSVpvn_flags(pv1, cur1, SVs_TEMP | SvUTF8(sv2));
        }

-       pv1 = SvPV_const(sv1, cur1);
+       pv1 = SvPV_flags_const(sv1, cur1, flags);

     }
 
     if (!sv2){
     }
 
     if (!sv2){


@@ -6686,7 +7098,7 @@ Perl_sv_eq(pTHX_ register SV *sv1, register SV *sv2)
        cur2 = 0;
     }
     else
        cur2 = 0;
     }
     else

-       pv2 = SvPV_const(sv2, cur2);
+       pv2 = SvPV_flags_const(sv2, cur2, flags);

 
     if (cur1 && cur2 && SvUTF8(sv1) != SvUTF8(sv2) && !IN_BYTES) {
         /* Differing utf8ness.
 
     if (cur1 && cur2 && SvUTF8(sv1) != SvUTF8(sv2) && !IN_BYTES) {
         /* Differing utf8ness.


@@ -6709,28 +7121,15 @@ Perl_sv_eq(pTHX_ register SV *sv1, register SV *sv2)
              }
         }
         else {
              }
         }
         else {

-             bool is_utf8 = TRUE;
-

              if (SvUTF8(sv1)) {
              if (SvUTF8(sv1)) {

-                  /* sv1 is the UTF-8 one,
-                   * if is equal it must be downgrade-able */
-                  char * const pv = (char*)bytes_from_utf8((const U8*)pv1,
-                                                    &cur1, &is_utf8);
-                  if (pv != pv1)
-                       pv1 = tpv = pv;
+                 /* sv1 is the UTF-8 one  */
+                 return bytes_cmp_utf8((const U8*)pv2, cur2,
+                                       (const U8*)pv1, cur1) == 0;

              }
              else {
              }
              else {

-                  /* sv2 is the UTF-8 one,
-                   * if is equal it must be downgrade-able */
-                  char * const pv = (char *)bytes_from_utf8((const U8*)pv2,
-                                                     &cur2, &is_utf8);
-                  if (pv != pv2)
-                       pv2 = tpv = pv;
-             }
-             if (is_utf8) {
-                  /* Downgrade not possible - cannot be eq */
-                  assert (tpv == 0);
-                  return FALSE;
+                 /* sv2 is the UTF-8 one  */
+                 return bytes_cmp_utf8((const U8*)pv1, cur1,
+                                       (const U8*)pv2, cur2) == 0;

              }
         }
     }
              }
         }
     }


@@ -6753,12 +7152,27 @@ string in C<sv1> is less than, equal to, or greater than the string in
 C<sv2>. Is UTF-8 and 'use bytes' aware, handles get magic, and will
 coerce its args to strings if necessary.  See also C<sv_cmp_locale>.
 
 C<sv2>. Is UTF-8 and 'use bytes' aware, handles get magic, and will
 coerce its args to strings if necessary.  See also C<sv_cmp_locale>.
 

+=for apidoc sv_cmp_flags
+
+Compares the strings in two SVs.  Returns -1, 0, or 1 indicating whether the
+string in C<sv1> is less than, equal to, or greater than the string in
+C<sv2>. Is UTF-8 and 'use bytes' aware and will coerce its args to strings
+if necessary. If the flags include SV_GMAGIC, it handles get magic. See
+also C<sv_cmp_locale_flags>.
+

 =cut
 */
 
 I32
 Perl_sv_cmp(pTHX_ register SV *const sv1, register SV *const sv2)
 {
 =cut
 */
 
 I32
 Perl_sv_cmp(pTHX_ register SV *const sv1, register SV *const sv2)
 {

+    return sv_cmp_flags(sv1, sv2, SV_GMAGIC);
+}
+
+I32
+Perl_sv_cmp_flags(pTHX_ register SV *const sv1, register SV *const sv2,
+                 const U32 flags)
+{

     dVAR;
     STRLEN cur1, cur2;
     const char *pv1, *pv2;
     dVAR;
     STRLEN cur1, cur2;
     const char *pv1, *pv2;


@@ -6771,14 +7185,14 @@ Perl_sv_cmp(pTHX_ register SV *const sv1, register SV *const sv2)
        cur1 = 0;
     }
     else
        cur1 = 0;
     }
     else

-       pv1 = SvPV_const(sv1, cur1);
+       pv1 = SvPV_flags_const(sv1, cur1, flags);

 
     if (!sv2) {
        pv2 = "";
        cur2 = 0;
     }
     else
 
     if (!sv2) {
        pv2 = "";
        cur2 = 0;
     }
     else

-       pv2 = SvPV_const(sv2, cur2);
+       pv2 = SvPV_flags_const(sv2, cur2, flags);

 
     if (cur1 && cur2 && SvUTF8(sv1) != SvUTF8(sv2) && !IN_BYTES) {
         /* Differing utf8ness.
 
     if (cur1 && cur2 && SvUTF8(sv1) != SvUTF8(sv2) && !IN_BYTES) {
         /* Differing utf8ness.


@@ -6790,7 +7204,9 @@ Perl_sv_cmp(pTHX_ register SV *const sv1, register SV *const sv2)
                 pv2 = SvPV_const(svrecode, cur2);
            }
            else {
                 pv2 = SvPV_const(svrecode, cur2);
            }
            else {

-                pv2 = tpv = (char*)bytes_to_utf8((const U8*)pv2, &cur2);
+               const int retval = -bytes_cmp_utf8((const U8*)pv2, cur2,
+                                                  (const U8*)pv1, cur1);
+               return retval ? retval < 0 ? -1 : +1 : 0;

            }
        }
        else {
            }
        }
        else {


@@ -6800,7 +7216,9 @@ Perl_sv_cmp(pTHX_ register SV *const sv1, register SV *const sv2)
                 pv1 = SvPV_const(svrecode, cur1);
            }
            else {
                 pv1 = SvPV_const(svrecode, cur1);
            }
            else {

-                pv1 = tpv = (char*)bytes_to_utf8((const U8*)pv1, &cur1);
+               const int retval = bytes_cmp_utf8((const U8*)pv1, cur1,
+                                                 (const U8*)pv2, cur2);
+               return retval ? retval < 0 ? -1 : +1 : 0;

            }
        }
     }
            }
        }
     }


@@ -6835,12 +7253,25 @@ Compares the strings in two SVs in a locale-aware manner. Is UTF-8 and
 'use bytes' aware, handles get magic, and will coerce its args to strings
 if necessary.  See also C<sv_cmp>.
 
 'use bytes' aware, handles get magic, and will coerce its args to strings
 if necessary.  See also C<sv_cmp>.
 

+=for apidoc sv_cmp_locale_flags
+
+Compares the strings in two SVs in a locale-aware manner. Is UTF-8 and
+'use bytes' aware and will coerce its args to strings if necessary. If the
+flags contain SV_GMAGIC, it handles get magic. See also C<sv_cmp_flags>.
+

 =cut
 */
 
 I32
 Perl_sv_cmp_locale(pTHX_ register SV *const sv1, register SV *const sv2)
 {
 =cut
 */
 
 I32
 Perl_sv_cmp_locale(pTHX_ register SV *const sv1, register SV *const sv2)
 {

+    return sv_cmp_locale_flags(sv1, sv2, SV_GMAGIC);
+}
+
+I32
+Perl_sv_cmp_locale_flags(pTHX_ register SV *const sv1, register SV *const sv2,
+                        const U32 flags)
+{

     dVAR;
 #ifdef USE_LOCALE_COLLATE
 
     dVAR;
 #ifdef USE_LOCALE_COLLATE
 


@@ -6852,9 +7283,9 @@ Perl_sv_cmp_locale(pTHX_ register SV *const sv1, register SV *const sv2)
        goto raw_compare;
 
     len1 = 0;
        goto raw_compare;
 
     len1 = 0;

-    pv1 = sv1 ? sv_collxfrm(sv1, &len1) : (char *) NULL;
+    pv1 = sv1 ? sv_collxfrm_flags(sv1, &len1, flags) : (char *) NULL;

     len2 = 0;
     len2 = 0;

-    pv2 = sv2 ? sv_collxfrm(sv2, &len2) : (char *) NULL;
+    pv2 = sv2 ? sv_collxfrm_flags(sv2, &len2, flags) : (char *) NULL;

 
     if (!pv1 || !len1) {
        if (pv2 && len2)
 
     if (!pv1 || !len1) {
        if (pv2 && len2)


@@ -6893,7 +7324,13 @@ Perl_sv_cmp_locale(pTHX_ register SV *const sv1, register SV *const sv2)
 /*
 =for apidoc sv_collxfrm
 
 /*
 =for apidoc sv_collxfrm
 

-Add Collate Transform magic to an SV if it doesn't already have it.
+This calls C<sv_collxfrm_flags> with the SV_GMAGIC flag. See
+C<sv_collxfrm_flags>.
+
+=for apidoc sv_collxfrm_flags
+
+Add Collate Transform magic to an SV if it doesn't already have it. If the
+flags contain SV_GMAGIC, it handles get-magic.

 
 Any scalar variable may carry PERL_MAGIC_collxfrm magic that contains the
 scalar data of the variable, but transformed to such a format that a normal
 
 Any scalar variable may carry PERL_MAGIC_collxfrm magic that contains the
 scalar data of the variable, but transformed to such a format that a normal


@@ -6904,12 +7341,12 @@ settings.
 */
 
 char *
 */
 
 char *

-Perl_sv_collxfrm(pTHX_ SV *const sv, STRLEN *const nxp)
+Perl_sv_collxfrm_flags(pTHX_ SV *const sv, STRLEN *const nxp, const I32 flags)

 {
     dVAR;
     MAGIC *mg;
 
 {
     dVAR;
     MAGIC *mg;
 

-    PERL_ARGS_ASSERT_SV_COLLXFRM;
+    PERL_ARGS_ASSERT_SV_COLLXFRM_FLAGS;

 
     mg = SvMAGICAL(sv) ? mg_find(sv, PERL_MAGIC_collxfrm) : (MAGIC *) NULL;
     if (!mg || !mg->mg_ptr || *(U32*)mg->mg_ptr != PL_collation_ix) {
 
     mg = SvMAGICAL(sv) ? mg_find(sv, PERL_MAGIC_collxfrm) : (MAGIC *) NULL;
     if (!mg || !mg->mg_ptr || *(U32*)mg->mg_ptr != PL_collation_ix) {


@@ -6919,7 +7356,7 @@ Perl_sv_collxfrm(pTHX_ SV *const sv, STRLEN *const nxp)
 
        if (mg)
            Safefree(mg->mg_ptr);
 
        if (mg)
            Safefree(mg->mg_ptr);

-       s = SvPV_const(sv, len);
+       s = SvPV_flags_const(sv, len, flags);

        if ((xf = mem_collxfrm(s, len, &xlen))) {
            if (! mg) {
 #ifdef PERL_OLD_COPY_ON_WRITE
        if ((xf = mem_collxfrm(s, len, &xlen))) {
            if (! mg) {
 #ifdef PERL_OLD_COPY_ON_WRITE


@@ -6952,6 +7389,55 @@ Perl_sv_collxfrm(pTHX_ SV *const sv, STRLEN *const nxp)
 
 #endif /* USE_LOCALE_COLLATE */
 
 
 #endif /* USE_LOCALE_COLLATE */
 

+static char *
+S_sv_gets_append_to_utf8(pTHX_ SV *const sv, PerlIO *const fp, I32 append)
+{
+    SV * const tsv = newSV(0);
+    ENTER;
+    SAVEFREESV(tsv);
+    sv_gets(tsv, fp, 0);
+    sv_utf8_upgrade_nomg(tsv);
+    SvCUR_set(sv,append);
+    sv_catsv(sv,tsv);
+    LEAVE;
+    return (SvCUR(sv) - append) ? SvPVX(sv) : NULL;
+}
+
+static char *
+S_sv_gets_read_record(pTHX_ SV *const sv, PerlIO *const fp, I32 append)
+{
+    I32 bytesread;
+    const U32 recsize = SvUV(SvRV(PL_rs)); /* RsRECORD() guarantees > 0. */
+      /* Grab the size of the record we're getting */
+    char *const buffer = SvGROW(sv, (STRLEN)(recsize + append + 1)) + append;
+#ifdef VMS
+    int fd;
+#endif
+
+    /* Go yank in */
+#ifdef VMS
+    /* VMS wants read instead of fread, because fread doesn't respect */
+    /* RMS record boundaries. This is not necessarily a good thing to be */
+    /* doing, but we've got no other real choice - except avoid stdio
+       as implementation - perhaps write a :vms layer ?
+    */
+    fd = PerlIO_fileno(fp);
+    if (fd != -1) {
+       bytesread = PerlLIO_read(fd, buffer, recsize);
+    }
+    else /* in-memory file from PerlIO::Scalar */
+#endif
+    {
+       bytesread = PerlIO_read(fp, buffer, recsize);
+    }
+
+    if (bytesread < 0)
+       bytesread = 0;
+    SvCUR_set(sv, bytesread + append);
+    buffer[bytesread] = '\0';
+    return (SvCUR(sv) - append) ? SvPVX(sv) : NULL;
+}
+

 /*
 =for apidoc sv_gets
 
 /*
 =for apidoc sv_gets
 


@@ -6993,17 +7479,14 @@ Perl_sv_gets(pTHX_ register SV *const sv, register PerlIO *const fp, I32 append)
                sv_pos_u2b(sv,&append,0);
            }
        } else if (SvUTF8(sv)) {
                sv_pos_u2b(sv,&append,0);
            }
        } else if (SvUTF8(sv)) {

-           SV * const tsv = newSV(0);
-           sv_gets(tsv, fp, 0);
-           sv_utf8_upgrade_nomg(tsv);
-           SvCUR_set(sv,append);
-           sv_catsv(sv,tsv);
-           sv_free(tsv);
-           goto return_string_or_null;
+           return S_sv_gets_append_to_utf8(aTHX_ sv, fp, append);

        }
     }
 
     SvPOK_only(sv);
        }
     }
 
     SvPOK_only(sv);

+    if (!append) {
+        SvCUR_set(sv,0);
+    }

     if (PerlIO_isutf8(fp))
        SvUTF8_on(sv);
 
     if (PerlIO_isutf8(fp))
        SvUTF8_on(sv);
 


@@ -7029,38 +7512,7 @@ Perl_sv_gets(pTHX_ register SV *const sv, register PerlIO *const fp, I32 append)
        rslen = 0;
     }
     else if (RsRECORD(PL_rs)) {
        rslen = 0;
     }
     else if (RsRECORD(PL_rs)) {

-      I32 bytesread;
-      char *buffer;
-      U32 recsize;
-#ifdef VMS
-      int fd;
-#endif
-
-      /* Grab the size of the record we're getting */
-      recsize = SvUV(SvRV(PL_rs)); /* RsRECORD() guarantees > 0. */
-      buffer = SvGROW(sv, (STRLEN)(recsize + append + 1)) + append;
-      /* Go yank in */
-#ifdef VMS
-      /* VMS wants read instead of fread, because fread doesn't respect */
-      /* RMS record boundaries. This is not necessarily a good thing to be */
-      /* doing, but we've got no other real choice - except avoid stdio
-         as implementation - perhaps write a :vms layer ?
-       */
-      fd = PerlIO_fileno(fp);
-      if (fd == -1) { /* in-memory file from PerlIO::Scalar */
-          bytesread = PerlIO_read(fp, buffer, recsize);
-      }
-      else {
-          bytesread = PerlLIO_read(fd, buffer, recsize);
-      }
-#else
-      bytesread = PerlIO_read(fp, buffer, recsize);
-#endif
-      if (bytesread < 0)
-         bytesread = 0;
-      SvCUR_set(sv, bytesread + append);
-      buffer[bytesread] = '\0';
-      goto return_string_or_null;
+       return S_sv_gets_read_record(aTHX_ sv, fp, append);

     }
     else if (RsPARA(PL_rs)) {
        rsptr = "\n\n";
     }
     else if (RsPARA(PL_rs)) {
        rsptr = "\n\n";


@@ -7170,6 +7622,8 @@ Perl_sv_gets(pTHX_ register SV *const sv, register PerlIO *const fp, I32 append)
                bp += cnt;                           /* screams  |  dust */
                ptr += cnt;                          /* louder   |  sed :-) */
                cnt = 0;
                bp += cnt;                           /* screams  |  dust */
                ptr += cnt;                          /* louder   |  sed :-) */
                cnt = 0;

+               assert (!shortbuffered);
+               goto cannot_be_shortbuffered;

            }
        }
        
            }
        }
        


@@ -7183,26 +7637,27 @@ Perl_sv_gets(pTHX_ register SV *const sv, register PerlIO *const fp, I32 append)
            continue;
        }
 
            continue;
        }
 

+    cannot_be_shortbuffered:

        DEBUG_P(PerlIO_printf(Perl_debug_log,
                              "Screamer: going to getc, ptr=%"UVuf", cnt=%ld\n",
                              PTR2UV(ptr),(long)cnt));
        PerlIO_set_ptrcnt(fp, (STDCHAR*)ptr, cnt); /* deregisterize cnt and ptr */
        DEBUG_P(PerlIO_printf(Perl_debug_log,
                              "Screamer: going to getc, ptr=%"UVuf", cnt=%ld\n",
                              PTR2UV(ptr),(long)cnt));
        PerlIO_set_ptrcnt(fp, (STDCHAR*)ptr, cnt); /* deregisterize cnt and ptr */

-#if 0
-       DEBUG_P(PerlIO_printf(Perl_debug_log,
+
+       DEBUG_Pv(PerlIO_printf(Perl_debug_log,

            "Screamer: pre: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
            PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
            PTR2UV(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0)));
            "Screamer: pre: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
            PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
            PTR2UV(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0)));

-#endif
+

        /* This used to call 'filbuf' in stdio form, but as that behaves like
           getc when cnt <= 0 we use PerlIO_getc here to avoid introducing
           another abstraction.  */
        i   = PerlIO_getc(fp);          /* get more characters */
        /* This used to call 'filbuf' in stdio form, but as that behaves like
           getc when cnt <= 0 we use PerlIO_getc here to avoid introducing
           another abstraction.  */
        i   = PerlIO_getc(fp);          /* get more characters */

-#if 0
-       DEBUG_P(PerlIO_printf(Perl_debug_log,
+
+       DEBUG_Pv(PerlIO_printf(Perl_debug_log,

            "Screamer: post: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
            PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
            PTR2UV(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0)));
            "Screamer: post: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
            PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
            PTR2UV(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0)));

-#endif
+

        cnt = PerlIO_get_cnt(fp);
        ptr = (STDCHAR*)PerlIO_get_ptr(fp);     /* reregisterize cnt and ptr */
        DEBUG_P(PerlIO_printf(Perl_debug_log,
        cnt = PerlIO_get_cnt(fp);
        ptr = (STDCHAR*)PerlIO_get_ptr(fp);     /* reregisterize cnt and ptr */
        DEBUG_P(PerlIO_printf(Perl_debug_log,


@@ -7315,7 +7770,6 @@ screamer2:
        }
     }
 
        }
     }
 

-return_string_or_null:

     return (SvCUR(sv) - append) ? SvPVX(sv) : NULL;
 }
 
     return (SvCUR(sv) - append) ? SvPVX(sv) : NULL;
 }
 


@@ -7323,7 +7777,7 @@ return_string_or_null:
 =for apidoc sv_inc
 
 Auto-increment of the value in the SV, doing string to numeric conversion
 =for apidoc sv_inc
 
 Auto-increment of the value in the SV, doing string to numeric conversion

-if necessary. Handles 'get' magic.
+if necessary. Handles 'get' magic and operator overloading.

 
 =cut
 */
 
 =cut
 */


@@ -7331,19 +7785,36 @@ if necessary. Handles 'get' magic.
 void
 Perl_sv_inc(pTHX_ register SV *const sv)
 {
 void
 Perl_sv_inc(pTHX_ register SV *const sv)
 {

+    if (!sv)
+       return;
+    SvGETMAGIC(sv);
+    sv_inc_nomg(sv);
+}
+
+/*
+=for apidoc sv_inc_nomg
+
+Auto-increment of the value in the SV, doing string to numeric conversion
+if necessary. Handles operator overloading. Skips handling 'get' magic.
+
+=cut
+*/
+
+void
+Perl_sv_inc_nomg(pTHX_ register SV *const sv)
+{

     dVAR;
     register char *d;
     int flags;
 
     if (!sv)
        return;
     dVAR;
     register char *d;
     int flags;
 
     if (!sv)
        return;

-    SvGETMAGIC(sv);

     if (SvTHINKFIRST(sv)) {
        if (SvIsCOW(sv))
            sv_force_normal_flags(sv, 0);
        if (SvREADONLY(sv)) {
            if (IN_PERL_RUNTIME)
     if (SvTHINKFIRST(sv)) {
        if (SvIsCOW(sv))
            sv_force_normal_flags(sv, 0);
        if (SvREADONLY(sv)) {
            if (IN_PERL_RUNTIME)

-               Perl_croak(aTHX_ "%s", PL_no_modify);
+               Perl_croak_no_modify(aTHX);

        }
        if (SvROK(sv)) {
            IV i;
        }
        if (SvROK(sv)) {
            IV i;


@@ -7487,7 +7958,7 @@ Perl_sv_inc(pTHX_ register SV *const sv)
 =for apidoc sv_dec
 
 Auto-decrement of the value in the SV, doing string to numeric conversion
 =for apidoc sv_dec
 
 Auto-decrement of the value in the SV, doing string to numeric conversion

-if necessary. Handles 'get' magic.
+if necessary. Handles 'get' magic and operator overloading.

 
 =cut
 */
 
 =cut
 */


@@ -7496,17 +7967,35 @@ void
 Perl_sv_dec(pTHX_ register SV *const sv)
 {
     dVAR;
 Perl_sv_dec(pTHX_ register SV *const sv)
 {
     dVAR;

+    if (!sv)
+       return;
+    SvGETMAGIC(sv);
+    sv_dec_nomg(sv);
+}
+
+/*
+=for apidoc sv_dec_nomg
+
+Auto-decrement of the value in the SV, doing string to numeric conversion
+if necessary. Handles operator overloading. Skips handling 'get' magic.
+
+=cut
+*/
+
+void
+Perl_sv_dec_nomg(pTHX_ register SV *const sv)
+{
+    dVAR;

     int flags;
 
     if (!sv)
        return;
     int flags;
 
     if (!sv)
        return;

-    SvGETMAGIC(sv);

     if (SvTHINKFIRST(sv)) {
        if (SvIsCOW(sv))
            sv_force_normal_flags(sv, 0);
        if (SvREADONLY(sv)) {
            if (IN_PERL_RUNTIME)
     if (SvTHINKFIRST(sv)) {
        if (SvIsCOW(sv))
            sv_force_normal_flags(sv, 0);
        if (SvREADONLY(sv)) {
            if (IN_PERL_RUNTIME)

-               Perl_croak(aTHX_ "%s", PL_no_modify);
+               Perl_croak_no_modify(aTHX);

        }
        if (SvROK(sv)) {
            IV i;
        }
        if (SvROK(sv)) {
            IV i;


@@ -7676,7 +8165,7 @@ SV is set to 1.  Note that if C<len> is zero, Perl will create a zero length
 string.  You are responsible for ensuring that the source string is at least
 C<len> bytes long.  If the C<s> argument is NULL the new SV will be undefined.
 Currently the only flag bits accepted are C<SVf_UTF8> and C<SVs_TEMP>.
 string.  You are responsible for ensuring that the source string is at least
 C<len> bytes long.  If the C<s> argument is NULL the new SV will be undefined.
 Currently the only flag bits accepted are C<SVf_UTF8> and C<SVs_TEMP>.

-If C<SVs_TEMP> is set, then C<sv2mortal()> is called on the result before
+If C<SVs_TEMP> is set, then C<sv_2mortal()> is called on the result before

 returning. If C<SVf_UTF8> is set, C<s> is considered to be in UTF-8 and the
 C<SVf_UTF8> flag will be set on the new SV.
 C<newSVpvn_utf8()> is a convenience wrapper for this function, defined as
 returning. If C<SVf_UTF8> is set, C<s> is considered to be in UTF-8 and the
 C<SVf_UTF8> flag will be set on the new SV.
 C<newSVpvn_utf8()> is a convenience wrapper for this function, defined as


@@ -7814,11 +8303,11 @@ Perl_newSVhek(pTHX_ const HEK *const hek)
               Andreas would like keys he put in as utf8 to come back as utf8
            */
            STRLEN utf8_len = HEK_LEN(hek);
               Andreas would like keys he put in as utf8 to come back as utf8
            */
            STRLEN utf8_len = HEK_LEN(hek);

-           const U8 *as_utf8 = bytes_to_utf8 ((U8*)HEK_KEY(hek), &utf8_len);
-           SV * const sv = newSVpvn ((const char*)as_utf8, utf8_len);
-
+           SV * const sv = newSV_type(SVt_PV);
+           char *as_utf8 = (char *)bytes_to_utf8 ((U8*)HEK_KEY(hek), &utf8_len);
+           /* bytes_to_utf8() allocates a new string, which we can repurpose: */
+           sv_usepvn_flags(sv, as_utf8, utf8_len, SV_HAS_TRAILING_NUL);

            SvUTF8_on (sv);
            SvUTF8_on (sv);

-           Safefree (as_utf8); /* bytes_to_utf8() allocates a new string */

            return sv;
        } else if (flags & (HVhek_REHASH|HVhek_UNSHARED)) {
            /* We don't have a pointer to the hv, so we have to replicate the
            return sv;
        } else if (flags & (HVhek_REHASH|HVhek_UNSHARED)) {
            /* We don't have a pointer to the hv, so we have to replicate the


@@ -7904,6 +8393,20 @@ Perl_newSVpvn_share(pTHX_ const char *src, I32 len, U32 hash)
     return sv;
 }
 
     return sv;
 }
 

+/*
+=for apidoc newSVpv_share
+
+Like C<newSVpvn_share>, but takes a nul-terminated string instead of a
+string/length pair.
+
+=cut
+*/
+
+SV *
+Perl_newSVpv_share(pTHX_ const char *src, U32 hash)
+{
+    return newSVpvn_share(src, strlen(src), hash);
+}

 
 #if defined(PERL_IMPLICIT_CONTEXT)
 
 
 #if defined(PERL_IMPLICIT_CONTEXT)
 


@@ -8237,6 +8740,7 @@ Perl_sv_2io(pTHX_ SV *const sv)
        io = MUTABLE_IO(sv);
        break;
     case SVt_PVGV:
        io = MUTABLE_IO(sv);
        break;
     case SVt_PVGV:

+    case SVt_PVLV:

        if (isGV_with_GP(sv)) {
            gv = MUTABLE_GV(sv);
            io = GvIO(gv);
        if (isGV_with_GP(sv)) {
            gv = MUTABLE_GV(sv);
            io = GvIO(gv);


@@ -8307,9 +8811,10 @@ Perl_sv_2cv(pTHX_ SV *sv, HV **const st, GV **const gvp, const I32 lref)
 
     default:
        if (SvROK(sv)) {
 
     default:
        if (SvROK(sv)) {

-           SV * const *sp = &sv;       /* Used in tryAMAGICunDEREF macro. */

            SvGETMAGIC(sv);
            SvGETMAGIC(sv);

-           tryAMAGICunDEREF(to_cv);
+           sv = amagic_deref_call(sv, to_cv_amg);
+           /* At this point I'd like to do SPAGAIN, but really I need to
+              force it upon my callers. Hmmm. This is a mess... */

 
            sv = SvRV(sv);
            if (SvTYPE(sv) == SVt_PVCV) {
 
            sv = SvRV(sv);
            if (SvTYPE(sv) == SVt_PVCV) {


@@ -8555,7 +9060,7 @@ Perl_sv_reftype(pTHX_ const SV *const sv, const int ob)
        case SVt_PVFM:          return "FORMAT";
        case SVt_PVIO:          return "IO";
        case SVt_BIND:          return "BIND";
        case SVt_PVFM:          return "FORMAT";
        case SVt_PVIO:          return "IO";
        case SVt_BIND:          return "BIND";

-       case SVt_REGEXP:        return "REGEXP"; 
+       case SVt_REGEXP:        return "REGEXP";

        default:                return "UNKNOWN";
        }
     }
        default:                return "UNKNOWN";
        }
     }


@@ -8813,7 +9318,7 @@ Perl_sv_bless(pTHX_ SV *const sv, HV *const stash)
        if (SvIsCOW(tmpRef))
            sv_force_normal_flags(tmpRef, 0);
        if (SvREADONLY(tmpRef))
        if (SvIsCOW(tmpRef))
            sv_force_normal_flags(tmpRef, 0);
        if (SvREADONLY(tmpRef))

-           Perl_croak(aTHX_ "%s", PL_no_modify);
+           Perl_croak_no_modify(aTHX);

        if (SvOBJECT(tmpRef)) {
            if (SvTYPE(tmpRef) != SVt_PVIO)
                --PL_sv_objcount;
        if (SvOBJECT(tmpRef)) {
            if (SvTYPE(tmpRef) != SVt_PVIO)
                --PL_sv_objcount;


@@ -8840,7 +9345,8 @@ Perl_sv_bless(pTHX_ SV *const sv, HV *const stash)
     return sv;
 }
 
     return sv;
 }
 

-/* Downgrades a PVGV to a PVMG.
+/* Downgrades a PVGV to a PVMG. If it’s actually a PVLV, we leave the type
+ * as it is after unglobbing it.

  */
 
 STATIC void
  */
 
 STATIC void


@@ -8853,7 +9359,7 @@ S_sv_unglob(pTHX_ SV *const sv)
 
     PERL_ARGS_ASSERT_SV_UNGLOB;
 
 
     PERL_ARGS_ASSERT_SV_UNGLOB;
 

-    assert(SvTYPE(sv) == SVt_PVGV);
+    assert(SvTYPE(sv) == SVt_PVGV || SvTYPE(sv) == SVt_PVLV);

     SvFAKE_off(sv);
     gv_efullname3(temp, MUTABLE_GV(sv), "*");
 
     SvFAKE_off(sv);
     gv_efullname3(temp, MUTABLE_GV(sv), "*");
 


@@ -8873,14 +9379,16 @@ S_sv_unglob(pTHX_ SV *const sv)
     }
     isGV_with_GP_off(sv);
 
     }
     isGV_with_GP_off(sv);
 

-    /* need to keep SvANY(sv) in the right arena */
-    xpvmg = new_XPVMG();
-    StructCopy(SvANY(sv), xpvmg, XPVMG);
-    del_XPVGV(SvANY(sv));
-    SvANY(sv) = xpvmg;
+    if(SvTYPE(sv) == SVt_PVGV) {
+       /* need to keep SvANY(sv) in the right arena */
+       xpvmg = new_XPVMG();
+       StructCopy(SvANY(sv), xpvmg, XPVMG);
+       del_XPVGV(SvANY(sv));
+       SvANY(sv) = xpvmg;

 
 

-    SvFLAGS(sv) &= ~SVTYPEMASK;
-    SvFLAGS(sv) |= SVt_PVMG;
+       SvFLAGS(sv) &= ~SVTYPEMASK;
+       SvFLAGS(sv) |= SVt_PVMG;
+    }

 
     /* Intentionally not calling any local SET magic, as this isn't so much a
        set operation as merely an internal storage change.  */
 
     /* Intentionally not calling any local SET magic, as this isn't so much a
        set operation as merely an internal storage change.  */


@@ -10463,18 +10971,17 @@ ptr_table_* functions.
    that currently av_dup, gv_dup and hv_dup are the same as sv_dup.
    If this changes, please unmerge ss_dup.
    Likewise, sv_dup_inc_multiple() relies on this fact.  */
    that currently av_dup, gv_dup and hv_dup are the same as sv_dup.
    If this changes, please unmerge ss_dup.
    Likewise, sv_dup_inc_multiple() relies on this fact.  */

-#define sv_dup_inc(s,t)        SvREFCNT_inc(sv_dup(s,t))
-#define sv_dup_inc_NN(s,t)     SvREFCNT_inc_NN(sv_dup(s,t))
+#define sv_dup_inc_NN(s,t)     SvREFCNT_inc_NN(sv_dup_inc(s,t))

 #define av_dup(s,t)    MUTABLE_AV(sv_dup((const SV *)s,t))
 #define av_dup(s,t)    MUTABLE_AV(sv_dup((const SV *)s,t))

-#define av_dup_inc(s,t)        MUTABLE_AV(SvREFCNT_inc(sv_dup((const SV *)s,t)))
+#define av_dup_inc(s,t)        MUTABLE_AV(sv_dup_inc((const SV *)s,t))

 #define hv_dup(s,t)    MUTABLE_HV(sv_dup((const SV *)s,t))
 #define hv_dup(s,t)    MUTABLE_HV(sv_dup((const SV *)s,t))

-#define hv_dup_inc(s,t)        MUTABLE_HV(SvREFCNT_inc(sv_dup((const SV *)s,t)))
+#define hv_dup_inc(s,t)        MUTABLE_HV(sv_dup_inc((const SV *)s,t))

 #define cv_dup(s,t)    MUTABLE_CV(sv_dup((const SV *)s,t))
 #define cv_dup(s,t)    MUTABLE_CV(sv_dup((const SV *)s,t))

-#define cv_dup_inc(s,t)        MUTABLE_CV(SvREFCNT_inc(sv_dup((const SV *)s,t)))
+#define cv_dup_inc(s,t)        MUTABLE_CV(sv_dup_inc((const SV *)s,t))

 #define io_dup(s,t)    MUTABLE_IO(sv_dup((const SV *)s,t))
 #define io_dup(s,t)    MUTABLE_IO(sv_dup((const SV *)s,t))

-#define io_dup_inc(s,t)        MUTABLE_IO(SvREFCNT_inc(sv_dup((const SV *)s,t)))
+#define io_dup_inc(s,t)        MUTABLE_IO(sv_dup_inc((const SV *)s,t))

 #define gv_dup(s,t)    MUTABLE_GV(sv_dup((const SV *)s,t))
 #define gv_dup(s,t)    MUTABLE_GV(sv_dup((const SV *)s,t))

-#define gv_dup_inc(s,t)        MUTABLE_GV(SvREFCNT_inc(sv_dup((const SV *)s,t)))
+#define gv_dup_inc(s,t)        MUTABLE_GV(sv_dup_inc((const SV *)s,t))

 #define SAVEPV(p)      ((p) ? savepv(p) : NULL)
 #define SAVEPVN(p,n)   ((p) ? savepvn(p,n) : NULL)
 
 #define SAVEPV(p)      ((p) ? savepv(p) : NULL)
 #define SAVEPVN(p,n)   ((p) ? savepvn(p,n) : NULL)
 


@@ -10499,9 +11006,6 @@ Perl_parser_dup(pTHX_ const yy_parser *const proto, CLONE_PARAMS *const param)
     Newxz(parser, 1, yy_parser);
     ptr_table_store(PL_ptr_table, proto, parser);
 
     Newxz(parser, 1, yy_parser);
     ptr_table_store(PL_ptr_table, proto, parser);
 

-    parser->yyerrstatus = 0;
-    parser->yychar = YYEMPTY;          /* Cause a token to be read.  */
-

     /* XXX these not yet duped */
     parser->old_parser = NULL;
     parser->stack = NULL;
     /* XXX these not yet duped */
     parser->old_parser = NULL;
     parser->stack = NULL;


@@ -10628,13 +11132,112 @@ Perl_fp_dup(pTHX_ PerlIO *const fp, const char type, CLONE_PARAMS *const param)
 /* duplicate a directory handle */
 
 DIR *
 /* duplicate a directory handle */
 
 DIR *

-Perl_dirp_dup(pTHX_ DIR *const dp)
+Perl_dirp_dup(pTHX_ DIR *const dp, CLONE_PARAMS *const param)

 {
 {

+    DIR *ret;
+
+#ifdef HAS_FCHDIR
+    DIR *pwd;
+    register const Direntry_t *dirent;
+    char smallbuf[256];
+    char *name = NULL;
+    STRLEN len = -1;
+    long pos;
+#endif
+

     PERL_UNUSED_CONTEXT;
     PERL_UNUSED_CONTEXT;

+    PERL_ARGS_ASSERT_DIRP_DUP;
+

     if (!dp)
        return (DIR*)NULL;
     if (!dp)
        return (DIR*)NULL;

-    /* XXX TODO */
-    return dp;
+
+    /* look for it in the table first */
+    ret = (DIR*)ptr_table_fetch(PL_ptr_table, dp);
+    if (ret)
+       return ret;
+
+#ifdef HAS_FCHDIR
+
+    PERL_UNUSED_ARG(param);
+
+    /* create anew */
+
+    /* open the current directory (so we can switch back) */
+    if (!(pwd = PerlDir_open("."))) return (DIR *)NULL;
+
+    /* chdir to our dir handle and open the present working directory */
+    if (fchdir(my_dirfd(dp)) < 0 || !(ret = PerlDir_open("."))) {
+       PerlDir_close(pwd);
+       return (DIR *)NULL;
+    }
+    /* Now we should have two dir handles pointing to the same dir. */
+
+    /* Be nice to the calling code and chdir back to where we were. */
+    fchdir(my_dirfd(pwd)); /* If this fails, then what? */
+
+    /* We have no need of the pwd handle any more. */
+    PerlDir_close(pwd);
+
+#ifdef DIRNAMLEN
+# define d_namlen(d) (d)->d_namlen
+#else
+# define d_namlen(d) strlen((d)->d_name)
+#endif
+    /* Iterate once through dp, to get the file name at the current posi-
+       tion. Then step back. */
+    pos = PerlDir_tell(dp);
+    if ((dirent = PerlDir_read(dp))) {
+       len = d_namlen(dirent);
+       if (len <= sizeof smallbuf) name = smallbuf;
+       else Newx(name, len, char);
+       Move(dirent->d_name, name, len, char);
+    }
+    PerlDir_seek(dp, pos);
+
+    /* Iterate through the new dir handle, till we find a file with the
+       right name. */
+    if (!dirent) /* just before the end */
+       for(;;) {
+           pos = PerlDir_tell(ret);
+           if (PerlDir_read(ret)) continue; /* not there yet */
+           PerlDir_seek(ret, pos); /* step back */
+           break;
+       }
+    else {
+       const long pos0 = PerlDir_tell(ret);
+       for(;;) {
+           pos = PerlDir_tell(ret);
+           if ((dirent = PerlDir_read(ret))) {
+               if (len == d_namlen(dirent)
+                && memEQ(name, dirent->d_name, len)) {
+                   /* found it */
+                   PerlDir_seek(ret, pos); /* step back */
+                   break;
+               }
+               /* else we are not there yet; keep iterating */
+           }
+           else { /* This is not meant to happen. The best we can do is
+                     reset the iterator to the beginning. */
+               PerlDir_seek(ret, pos0);
+               break;
+           }
+       }
+    }
+#undef d_namlen
+
+    if (name && name != smallbuf)
+       Safefree(name);
+#endif
+
+#ifdef WIN32
+    ret = win32_dirp_dup(dp, param);
+#endif
+
+    /* pop it in the pointer table */
+    if (ret)
+       ptr_table_store(PL_ptr_table, dp, ret);
+
+    return ret;

 }
 
 /* duplicate a typeglob */
 }
 
 /* duplicate a typeglob */


@@ -10685,6 +11288,13 @@ Perl_mg_dup(pTHX_ MAGIC *mg, CLONE_PARAMS *const param)
 
     for (; mg; mg = mg->mg_moremagic) {
        MAGIC *nmg;
 
     for (; mg; mg = mg->mg_moremagic) {
        MAGIC *nmg;

+
+       if ((param->flags & CLONEf_JOIN_IN)
+               && mg->mg_type == PERL_MAGIC_backref)
+           /* when joining, we let the individual SVs add themselves to
+            * backref as needed. */
+           continue;
+

        Newx(nmg, 1, MAGIC);
        *mgprev_p = nmg;
        mgprev_p = &(nmg->mg_moremagic);
        Newx(nmg, 1, MAGIC);
        *mgprev_p = nmg;
        mgprev_p = &(nmg->mg_moremagic);


@@ -10702,17 +11312,14 @@ Perl_mg_dup(pTHX_ MAGIC *mg, CLONE_PARAMS *const param)
        }
        else
        */
        }
        else
        */

-       if(nmg->mg_type == PERL_MAGIC_backref) {
-           /* The backref AV has its reference count deliberately bumped by
-              1.  */
-           nmg->mg_obj
-               = SvREFCNT_inc(av_dup_inc((const AV *) nmg->mg_obj, param));
-       }
-       else {
-           nmg->mg_obj = (nmg->mg_flags & MGf_REFCOUNTED)
-                             ? sv_dup_inc(nmg->mg_obj, param)
-                             : sv_dup(nmg->mg_obj, param);
-       }
+       nmg->mg_obj = (nmg->mg_flags & MGf_REFCOUNTED)
+                         ? nmg->mg_type == PERL_MAGIC_backref
+                               /* The backref AV has its reference
+                                * count deliberately bumped by 1 */
+                               ? SvREFCNT_inc(av_dup_inc((const AV *)
+                                                   nmg->mg_obj, param))
+                               : sv_dup_inc(nmg->mg_obj, param)
+                         : sv_dup(nmg->mg_obj, param);

 
        if (nmg->mg_ptr && nmg->mg_type != PERL_MAGIC_regex_global) {
            if (nmg->mg_len > 0) {
 
        if (nmg->mg_ptr && nmg->mg_type != PERL_MAGIC_regex_global) {
            if (nmg->mg_len > 0) {


@@ -10729,7 +11336,7 @@ Perl_mg_dup(pTHX_ MAGIC *mg, CLONE_PARAMS *const param)
                nmg->mg_ptr = (char*)sv_dup_inc((const SV *)nmg->mg_ptr, param);
        }
        if ((nmg->mg_flags & MGf_DUP) && nmg->mg_virtual && nmg->mg_virtual->svt_dup) {
                nmg->mg_ptr = (char*)sv_dup_inc((const SV *)nmg->mg_ptr, param);
        }
        if ((nmg->mg_flags & MGf_DUP) && nmg->mg_virtual && nmg->mg_virtual->svt_dup) {

-           CALL_FPTR(nmg->mg_virtual->svt_dup)(aTHX_ nmg, param);
+           nmg->mg_virtual->svt_dup(aTHX_ nmg, param);

        }
     }
     return mgret;
        }
     }
     return mgret;


@@ -10848,20 +11455,22 @@ Perl_ptr_table_split(pTHX_ PTR_TBL_t *const tbl)
     tbl->tbl_max = --newsize;
     tbl->tbl_ary = ary;
     for (i=0; i < oldsize; i++, ary++) {
     tbl->tbl_max = --newsize;
     tbl->tbl_ary = ary;
     for (i=0; i < oldsize; i++, ary++) {

-       PTR_TBL_ENT_t **curentp, **entp, *ent;
-       if (!*ary)
+       PTR_TBL_ENT_t **entp = ary;
+       PTR_TBL_ENT_t *ent = *ary;
+       PTR_TBL_ENT_t **curentp;
+       if (!ent)

            continue;
        curentp = ary + oldsize;
            continue;
        curentp = ary + oldsize;

-       for (entp = ary, ent = *ary; ent; ent = *entp) {
+       do {

            if ((newsize & PTR_TABLE_HASH(ent->oldval)) != i) {
                *entp = ent->next;
                ent->next = *curentp;
                *curentp = ent;
            if ((newsize & PTR_TABLE_HASH(ent->oldval)) != i) {
                *entp = ent->next;
                ent->next = *curentp;
                *curentp = ent;

-               continue;

            }
            else
                entp = &ent->next;
            }
            else
                entp = &ent->next;

-       }
+           ent = *entp;
+       } while (ent);

     }
 }
 
     }
 }
 


@@ -10922,10 +11531,16 @@ Perl_rvpv_dup(pTHX_ SV *const dstr, const SV *const sstr, CLONE_PARAMS *const pa
     PERL_ARGS_ASSERT_RVPV_DUP;
 
     if (SvROK(sstr)) {
     PERL_ARGS_ASSERT_RVPV_DUP;
 
     if (SvROK(sstr)) {

-       SvRV_set(dstr, SvWEAKREF(sstr)
-                      ? sv_dup(SvRV_const(sstr), param)
-                      : sv_dup_inc(SvRV_const(sstr), param));
-
+       if (SvWEAKREF(sstr)) {
+           SvRV_set(dstr, sv_dup(SvRV_const(sstr), param));
+           if (param->flags & CLONEf_JOIN_IN) {
+               /* if joining, we add any back references individually rather
+                * than copying the whole backref array */
+               Perl_sv_add_backref(aTHX_ SvRV(dstr), dstr);
+           }
+       }
+       else
+           SvRV_set(dstr, sv_dup_inc(SvRV_const(sstr), param));

     }
     else if (SvPVX_const(sstr)) {
        /* Has something there */
     }
     else if (SvPVX_const(sstr)) {
        /* Has something there */


@@ -10978,16 +11593,14 @@ S_sv_dup_inc_multiple(pTHX_ SV *const *source, SV **dest,
 
 /* duplicate an SV of any type (including AV, HV etc) */
 
 
 /* duplicate an SV of any type (including AV, HV etc) */
 

-SV *
-Perl_sv_dup(pTHX_ const SV *const sstr, CLONE_PARAMS *const param)
+static SV *
+S_sv_dup_common(pTHX_ const SV *const sstr, CLONE_PARAMS *const param)

 {
     dVAR;
     SV *dstr;
 
 {
     dVAR;
     SV *dstr;
 

-    PERL_ARGS_ASSERT_SV_DUP;
+    PERL_ARGS_ASSERT_SV_DUP_COMMON;

 
 

-    if (!sstr)
-       return NULL;

     if (SvTYPE(sstr) == SVTYPEMASK) {
 #ifdef DEBUG_LEAKING_SCALARS_ABORT
        abort();
     if (SvTYPE(sstr) == SVTYPEMASK) {
 #ifdef DEBUG_LEAKING_SCALARS_ABORT
        abort();


@@ -11004,9 +11617,12 @@ Perl_sv_dup(pTHX_ const SV *const sstr, CLONE_PARAMS *const param)
            something that is bad **/
        if (SvTYPE(sstr) == SVt_PVHV) {
            const HEK * const hvname = HvNAME_HEK(sstr);
            something that is bad **/
        if (SvTYPE(sstr) == SVt_PVHV) {
            const HEK * const hvname = HvNAME_HEK(sstr);

-           if (hvname)
+           if (hvname) {

                /** don't clone stashes if they already exist **/
                /** don't clone stashes if they already exist **/

-               return MUTABLE_SV(gv_stashpvn(HEK_KEY(hvname), HEK_LEN(hvname), 0));
+               dstr = MUTABLE_SV(gv_stashpvn(HEK_KEY(hvname), HEK_LEN(hvname), 0));
+               ptr_table_store(PL_ptr_table, sstr, dstr);
+               return dstr;
+           }

         }
     }
 
         }
     }
 


@@ -11017,7 +11633,8 @@ Perl_sv_dup(pTHX_ const SV *const sstr, CLONE_PARAMS *const param)
     dstr->sv_debug_optype = sstr->sv_debug_optype;
     dstr->sv_debug_line = sstr->sv_debug_line;
     dstr->sv_debug_inpad = sstr->sv_debug_inpad;
     dstr->sv_debug_optype = sstr->sv_debug_optype;
     dstr->sv_debug_line = sstr->sv_debug_line;
     dstr->sv_debug_inpad = sstr->sv_debug_inpad;

-    dstr->sv_debug_cloned = 1;
+    dstr->sv_debug_parent = (SV*)sstr;
+    FREE_SV_DEBUG_FILE(dstr);

     dstr->sv_debug_file = savepv(sstr->sv_debug_file);
 #endif
 
     dstr->sv_debug_file = savepv(sstr->sv_debug_file);
 #endif
 


@@ -11105,7 +11722,8 @@ Perl_sv_dup(pTHX_ const SV *const sstr, CLONE_PARAMS *const param)
 #endif
 
            if (sv_type != SVt_PVAV && sv_type != SVt_PVHV
 #endif
 
            if (sv_type != SVt_PVAV && sv_type != SVt_PVHV

-               && !isGV_with_GP(dstr))
+               && !isGV_with_GP(dstr)
+               && !(sv_type == SVt_PVIO && !(IoFLAGS(dstr) & IOf_FAKE_DIRP)))

                Perl_rvpv_dup(aTHX_ dstr, sstr, param);
 
            /* The Copy above means that all the source (unduplicated) pointers
                Perl_rvpv_dup(aTHX_ dstr, sstr, param);
 
            /* The Copy above means that all the source (unduplicated) pointers


@@ -11145,6 +11763,7 @@ Perl_sv_dup(pTHX_ const SV *const sstr, CLONE_PARAMS *const param)
                else
                    LvTARG(dstr) = sv_dup_inc(LvTARG(dstr), param);
            case SVt_PVGV:
                else
                    LvTARG(dstr) = sv_dup_inc(LvTARG(dstr), param);
            case SVt_PVGV:

+               /* non-GP case already handled above */

                if(isGV_with_GP(sstr)) {
                    GvNAME_HEK(dstr) = hek_dup(GvNAME_HEK(dstr), param);
                    /* Don't call sv_add_backref here as it's going to be
                if(isGV_with_GP(sstr)) {
                    GvNAME_HEK(dstr) = hek_dup(GvNAME_HEK(dstr), param);
                    /* Don't call sv_add_backref here as it's going to be


@@ -11154,29 +11773,13 @@ Perl_sv_dup(pTHX_ const SV *const sstr, CLONE_PARAMS *const param)
                    /* Danger Will Robinson - GvGP(dstr) isn't initialised
                       at the point of this comment.  */
                    GvSTASH(dstr) = hv_dup(GvSTASH(dstr), param);
                    /* Danger Will Robinson - GvGP(dstr) isn't initialised
                       at the point of this comment.  */
                    GvSTASH(dstr) = hv_dup(GvSTASH(dstr), param);

-                   if(param->flags & CLONEf_JOIN_IN) {
-                       const HEK * const hvname
-                        = HvNAME_HEK(GvSTASH(dstr));
-                       if( hvname
-                        && GvSTASH(dstr) == gv_stashpvn(
-                            HEK_KEY(hvname), HEK_LEN(hvname), 0
-                           )
-                         )
-                           Perl_sv_add_backref(
-                            aTHX_ MUTABLE_SV(GvSTASH(dstr)), dstr
-                           );
-                   }
+                   if (param->flags & CLONEf_JOIN_IN)
+                       Perl_sv_add_backref(aTHX_ MUTABLE_SV(GvSTASH(dstr)), dstr);

                    GvGP(dstr)  = gp_dup(GvGP(sstr), param);
                    (void)GpREFCNT_inc(GvGP(dstr));
                    GvGP(dstr)  = gp_dup(GvGP(sstr), param);
                    (void)GpREFCNT_inc(GvGP(dstr));

-               } else
-                   Perl_rvpv_dup(aTHX_ dstr, sstr, param);
+               }

                break;
            case SVt_PVIO:
                break;
            case SVt_PVIO:

-               IoIFP(dstr)     = fp_dup(IoIFP(dstr), IoTYPE(dstr), param);
-               if (IoOFP(dstr) == IoIFP(sstr))
-                   IoOFP(dstr) = IoIFP(dstr);
-               else
-                   IoOFP(dstr) = fp_dup(IoOFP(dstr), IoTYPE(dstr), param);

                /* PL_parser->rsfp_filters entries have fake IoDIRP() */
                if(IoFLAGS(dstr) & IOf_FAKE_DIRP) {
                    /* I have no idea why fake dirp (rsfps)
                /* PL_parser->rsfp_filters entries have fake IoDIRP() */
                if(IoFLAGS(dstr) & IOf_FAKE_DIRP) {
                    /* I have no idea why fake dirp (rsfps)


@@ -11190,12 +11793,17 @@ Perl_sv_dup(pTHX_ const SV *const sstr, CLONE_PARAMS *const param)
                    IoFMT_GV(dstr)      = gv_dup(IoFMT_GV(dstr), param);
                    IoBOTTOM_GV(dstr)   = gv_dup(IoBOTTOM_GV(dstr), param);
                    if (IoDIRP(dstr)) {
                    IoFMT_GV(dstr)      = gv_dup(IoFMT_GV(dstr), param);
                    IoBOTTOM_GV(dstr)   = gv_dup(IoBOTTOM_GV(dstr), param);
                    if (IoDIRP(dstr)) {

-                       IoDIRP(dstr)    = dirp_dup(IoDIRP(dstr));
+                       IoDIRP(dstr)    = dirp_dup(IoDIRP(dstr), param);

                    } else {
                        NOOP;
                        /* IoDIRP(dstr) is already a copy of IoDIRP(sstr)  */
                    }
                    } else {
                        NOOP;
                        /* IoDIRP(dstr) is already a copy of IoDIRP(sstr)  */
                    }

+                   IoIFP(dstr) = fp_dup(IoIFP(sstr), IoTYPE(dstr), param);

                }
                }

+               if (IoOFP(dstr) == IoIFP(sstr))
+                   IoOFP(dstr) = IoIFP(dstr);
+               else
+                   IoOFP(dstr) = fp_dup(IoOFP(dstr), IoTYPE(dstr), param);

                IoTOP_NAME(dstr)        = SAVEPV(IoTOP_NAME(dstr));
                IoFMT_NAME(dstr)        = SAVEPV(IoFMT_NAME(dstr));
                IoBOTTOM_NAME(dstr)     = SAVEPV(IoBOTTOM_NAME(dstr));
                IoTOP_NAME(dstr)        = SAVEPV(IoTOP_NAME(dstr));
                IoFMT_NAME(dstr)        = SAVEPV(IoFMT_NAME(dstr));
                IoBOTTOM_NAME(dstr)     = SAVEPV(IoBOTTOM_NAME(dstr));


@@ -11218,11 +11826,6 @@ Perl_sv_dup(pTHX_ const SV *const sstr, CLONE_PARAMS *const param)
                    else {
                        while (items-- > 0)
                            *dst_ary++ = sv_dup(*src_ary++, param);
                    else {
                        while (items-- > 0)
                            *dst_ary++ = sv_dup(*src_ary++, param);

-                       if (!(param->flags & CLONEf_COPY_STACKS)
-                            && AvREIFY(sstr))
-                       {
-                           av_reify(MUTABLE_AV(dstr)); /* #41138 */
-                       }

                    }
                    items = AvMAX((const AV *)sstr) - AvFILLp((const AV *)sstr);
                    while (items-- > 0) {
                    }
                    items = AvMAX((const AV *)sstr) - AvFILLp((const AV *)sstr);
                    while (items-- > 0) {


@@ -11254,15 +11857,33 @@ Perl_sv_dup(pTHX_ const SV *const sstr, CLONE_PARAMS *const param)
                        ++i;
                    }
                    if (SvOOK(sstr)) {
                        ++i;
                    }
                    if (SvOOK(sstr)) {

-                       HEK *hvname;

                        const struct xpvhv_aux * const saux = HvAUX(sstr);
                        struct xpvhv_aux * const daux = HvAUX(dstr);
                        /* This flag isn't copied.  */
                        /* SvOOK_on(hv) attacks the IV flags.  */
                        SvFLAGS(dstr) |= SVf_OOK;
 
                        const struct xpvhv_aux * const saux = HvAUX(sstr);
                        struct xpvhv_aux * const daux = HvAUX(dstr);
                        /* This flag isn't copied.  */
                        /* SvOOK_on(hv) attacks the IV flags.  */
                        SvFLAGS(dstr) |= SVf_OOK;
 

-                       hvname = saux->xhv_name;
-                       daux->xhv_name = hek_dup(hvname, param);
+                       if (saux->xhv_name_count) {
+                           HEK ** const sname = saux->xhv_name_u.xhvnameu_names;
+                           const I32 count
+                            = saux->xhv_name_count < 0
+                               ? -saux->xhv_name_count
+                               :  saux->xhv_name_count;
+                           HEK **shekp = sname + count;
+                           HEK **dhekp;
+                           Newx(daux->xhv_name_u.xhvnameu_names, count, HEK *);
+                           dhekp = daux->xhv_name_u.xhvnameu_names + count;
+                           while (shekp-- > sname) {
+                               dhekp--;
+                               *dhekp = hek_dup(*shekp, param);
+                           }
+                       }
+                       else {
+                           daux->xhv_name_u.xhvnameu_name
+                               = hek_dup(saux->xhv_name_u.xhvnameu_name,
+                                         param);
+                       }
+                       daux->xhv_name_count = saux->xhv_name_count;

 
                        daux->xhv_riter = saux->xhv_riter;
                        daux->xhv_eiter = saux->xhv_eiter
 
                        daux->xhv_riter = saux->xhv_riter;
                        daux->xhv_eiter = saux->xhv_eiter


@@ -11270,9 +11891,22 @@ Perl_sv_dup(pTHX_ const SV *const sstr, CLONE_PARAMS *const param)
                                        cBOOL(HvSHAREKEYS(sstr)), param) : 0;
                        /* backref array needs refcnt=2; see sv_add_backref */
                        daux->xhv_backreferences =
                                        cBOOL(HvSHAREKEYS(sstr)), param) : 0;
                        /* backref array needs refcnt=2; see sv_add_backref */
                        daux->xhv_backreferences =

-                           saux->xhv_backreferences
-                           ? MUTABLE_AV(SvREFCNT_inc(
-                                                     sv_dup_inc((const SV *)saux->xhv_backreferences, param)))
+                           (param->flags & CLONEf_JOIN_IN)
+                               /* when joining, we let the individual GVs and
+                                * CVs add themselves to backref as
+                                * needed. This avoids pulling in stuff
+                                * that isn't required, and simplifies the
+                                * case where stashes aren't cloned back
+                                * if they already exist in the parent
+                                * thread */
+                           ? NULL
+                           : saux->xhv_backreferences
+                               ? (SvTYPE(saux->xhv_backreferences) == SVt_PVAV)
+                                   ? MUTABLE_AV(SvREFCNT_inc(
+                                         sv_dup_inc((const SV *)
+                                           saux->xhv_backreferences, param)))
+                                   : MUTABLE_AV(sv_dup((const SV *)
+                                           saux->xhv_backreferences, param))

                                : 0;
 
                         daux->xhv_mro_meta = saux->xhv_mro_meta
                                : 0;
 
                         daux->xhv_mro_meta = saux->xhv_mro_meta


@@ -11280,7 +11914,7 @@ Perl_sv_dup(pTHX_ const SV *const sstr, CLONE_PARAMS *const param)
                             : 0;
 
                        /* Record stashes for possible cloning in Perl_clone(). */
                             : 0;
 
                        /* Record stashes for possible cloning in Perl_clone(). */

-                       if (hvname)
+                       if (HvNAME(sstr))

                            av_push(param->stashes, dstr);
                    }
                }
                            av_push(param->stashes, dstr);
                    }
                }


@@ -11291,28 +11925,36 @@ Perl_sv_dup(pTHX_ const SV *const sstr, CLONE_PARAMS *const param)
                if (!(param->flags & CLONEf_COPY_STACKS)) {
                    CvDEPTH(dstr) = 0;
                }
                if (!(param->flags & CLONEf_COPY_STACKS)) {
                    CvDEPTH(dstr) = 0;
                }

+               /*FALLTHROUGH*/

            case SVt_PVFM:
                /* NOTE: not refcounted */
            case SVt_PVFM:
                /* NOTE: not refcounted */

-               CvSTASH(dstr)   = hv_dup(CvSTASH(dstr), param);
-               OP_REFCNT_LOCK;
-               if (!CvISXSUB(dstr))
+               SvANY(MUTABLE_CV(dstr))->xcv_stash =
+                   hv_dup(CvSTASH(dstr), param);
+               if ((param->flags & CLONEf_JOIN_IN) && CvSTASH(dstr))
+                   Perl_sv_add_backref(aTHX_ MUTABLE_SV(CvSTASH(dstr)), dstr);
+               if (!CvISXSUB(dstr)) {
+                   OP_REFCNT_LOCK;

                    CvROOT(dstr) = OpREFCNT_inc(CvROOT(dstr));
                    CvROOT(dstr) = OpREFCNT_inc(CvROOT(dstr));

-               OP_REFCNT_UNLOCK;
-               if (CvCONST(dstr) && CvISXSUB(dstr)) {
+                   OP_REFCNT_UNLOCK;
+                   CvFILE(dstr) = SAVEPV(CvFILE(dstr));
+               } else if (CvCONST(dstr)) {

                    CvXSUBANY(dstr).any_ptr =
                        sv_dup_inc((const SV *)CvXSUBANY(dstr).any_ptr, param);
                }
                /* don't dup if copying back - CvGV isn't refcounted, so the
                 * duped GV may never be freed. A bit of a hack! DAPM */
                    CvXSUBANY(dstr).any_ptr =
                        sv_dup_inc((const SV *)CvXSUBANY(dstr).any_ptr, param);
                }
                /* don't dup if copying back - CvGV isn't refcounted, so the
                 * duped GV may never be freed. A bit of a hack! DAPM */

-               CvGV(dstr)      = (param->flags & CLONEf_JOIN_IN) ?
-                   NULL : gv_dup(CvGV(dstr), param) ;
-               PAD_DUP(CvPADLIST(dstr), CvPADLIST(sstr), param);
+               SvANY(MUTABLE_CV(dstr))->xcv_gv =
+                   CvCVGV_RC(dstr)
+                   ? gv_dup_inc(CvGV(sstr), param)
+                   : (param->flags & CLONEf_JOIN_IN)
+                       ? NULL
+                       : gv_dup(CvGV(sstr), param);
+
+               CvPADLIST(dstr) = padlist_dup(CvPADLIST(sstr), param);

                CvOUTSIDE(dstr) =
                    CvWEAKOUTSIDE(sstr)
                    ? cv_dup(    CvOUTSIDE(dstr), param)
                    : cv_dup_inc(CvOUTSIDE(dstr), param);
                CvOUTSIDE(dstr) =
                    CvWEAKOUTSIDE(sstr)
                    ? cv_dup(    CvOUTSIDE(dstr), param)
                    : cv_dup_inc(CvOUTSIDE(dstr), param);

-               if (!CvISXSUB(dstr))
-                   CvFILE(dstr) = SAVEPV(CvFILE(dstr));

                break;
            }
        }
                break;
            }
        }


@@ -11324,6 +11966,41 @@ Perl_sv_dup(pTHX_ const SV *const sstr, CLONE_PARAMS *const param)
     return dstr;
  }
 
     return dstr;
  }
 

+SV *
+Perl_sv_dup_inc(pTHX_ const SV *const sstr, CLONE_PARAMS *const param)
+{
+    PERL_ARGS_ASSERT_SV_DUP_INC;
+    return sstr ? SvREFCNT_inc(sv_dup_common(sstr, param)) : NULL;
+}
+
+SV *
+Perl_sv_dup(pTHX_ const SV *const sstr, CLONE_PARAMS *const param)
+{
+    SV *dstr = sstr ? sv_dup_common(sstr, param) : NULL;
+    PERL_ARGS_ASSERT_SV_DUP;
+
+    /* Track every SV that (at least initially) had a reference count of 0.
+       We need to do this by holding an actual reference to it in this array.
+       If we attempt to cheat, turn AvREAL_off(), and store only pointers
+       (akin to the stashes hash, and the perl stack), we come unstuck if
+       a weak reference (or other SV legitimately SvREFCNT() == 0 for this
+       thread) is manipulated in a CLONE method, because CLONE runs before the
+       unreferenced array is walked to find SVs still with SvREFCNT() == 0
+       (and fix things up by giving each a reference via the temps stack).
+       Instead, during CLONE, if the 0-referenced SV has SvREFCNT_inc() and
+       then SvREFCNT_dec(), it will be cleaned up (and added to the free list)
+       before the walk of unreferenced happens and a reference to that is SV
+       added to the temps stack. At which point we have the same SV considered
+       to be in use, and free to be re-used. Not good.
+    */
+    if (dstr && !(param->flags & CLONEf_COPY_STACKS) && !SvREFCNT(dstr)) {
+       assert(param->unreferenced);
+       av_push(param->unreferenced, SvREFCNT_inc(dstr));
+    }
+
+    return dstr;
+}
+

 /* duplicate a context */
 
 PERL_CONTEXT *
 /* duplicate a context */
 
 PERL_CONTEXT *


@@ -11386,13 +12063,13 @@ Perl_cx_dup(pTHX_ PERL_CONTEXT *cxs, I32 ix, I32 max, CLONE_PARAMS* param)
            case CXt_LOOP_LAZYIV:
            case CXt_LOOP_PLAIN:
                if (CxPADLOOP(ncx)) {
            case CXt_LOOP_LAZYIV:
            case CXt_LOOP_PLAIN:
                if (CxPADLOOP(ncx)) {

-                   ncx->blk_loop.oldcomppad
+                   ncx->blk_loop.itervar_u.oldcomppad

                        = (PAD*)ptr_table_fetch(PL_ptr_table,
                        = (PAD*)ptr_table_fetch(PL_ptr_table,

-                                               ncx->blk_loop.oldcomppad);
+                                       ncx->blk_loop.itervar_u.oldcomppad);

                } else {
                } else {

-                   ncx->blk_loop.oldcomppad
-                       = (PAD*)gv_dup((const GV *)ncx->blk_loop.oldcomppad,
-                                      param);
+                   ncx->blk_loop.itervar_u.gv
+                       = gv_dup((const GV *)ncx->blk_loop.itervar_u.gv,
+                                   param);

                }
                break;
            case CXt_FORMAT:
                }
                break;
            case CXt_FORMAT:


@@ -11536,6 +12213,7 @@ Perl_ss_dup(pTHX_ PerlInterpreter *proto_perl, CLONE_PARAMS* param)
            TOPPTR(nss,ix) = sv_dup_inc(sv, param);
            /* fall through */
        case SAVEt_ITEM:                        /* normal string */
            TOPPTR(nss,ix) = sv_dup_inc(sv, param);
            /* fall through */
        case SAVEt_ITEM:                        /* normal string */

+        case SAVEt_GVSV:                       /* scalar slot in GV */

         case SAVEt_SV:                         /* scalar reference */
            sv = (const SV *)POPPTR(ss,ix);
            TOPPTR(nss,ix) = sv_dup_inc(sv, param);
         case SAVEt_SV:                         /* scalar reference */
            sv = (const SV *)POPPTR(ss,ix);
            TOPPTR(nss,ix) = sv_dup_inc(sv, param);


@@ -11621,13 +12299,11 @@ Perl_ss_dup(pTHX_ PerlInterpreter *proto_perl, CLONE_PARAMS* param)
            TOPPTR(nss,ix) = pv_dup(c);
            break;
        case SAVEt_GP:                          /* scalar reference */
            TOPPTR(nss,ix) = pv_dup(c);
            break;
        case SAVEt_GP:                          /* scalar reference */

-           gv = (const GV *)POPPTR(ss,ix);
-           TOPPTR(nss,ix) = gv_dup_inc(gv, param);

            gp = (GP*)POPPTR(ss,ix);
            TOPPTR(nss,ix) = gp = gp_dup(gp, param);
            (void)GpREFCNT_inc(gp);
            gp = (GP*)POPPTR(ss,ix);
            TOPPTR(nss,ix) = gp = gp_dup(gp, param);
            (void)GpREFCNT_inc(gp);

-           i = POPINT(ss,ix);
-           TOPINT(nss,ix) = i;
+           gv = (const GV *)POPPTR(ss,ix);
+           TOPPTR(nss,ix) = gv_dup_inc(gv, param);

            break;
        case SAVEt_FREEOP:
            ptr = POPPTR(ss,ix);
            break;
        case SAVEt_FREEOP:
            ptr = POPPTR(ss,ix);


@@ -11655,6 +12331,10 @@ Perl_ss_dup(pTHX_ PerlInterpreter *proto_perl, CLONE_PARAMS* param)
            else
                TOPPTR(nss,ix) = NULL;
            break;
            else
                TOPPTR(nss,ix) = NULL;
            break;

+       case SAVEt_FREECOPHH:
+           ptr = POPPTR(ss,ix);
+           TOPPTR(nss,ix) = cophh_copy((COPHH *)ptr);
+           break;

        case SAVEt_DELETE:
            hv = (const HV *)POPPTR(ss,ix);
            TOPPTR(nss,ix) = hv_dup_inc(hv, param);
        case SAVEt_DELETE:
            hv = (const HV *)POPPTR(ss,ix);
            TOPPTR(nss,ix) = hv_dup_inc(hv, param);


@@ -11703,11 +12383,7 @@ Perl_ss_dup(pTHX_ PerlInterpreter *proto_perl, CLONE_PARAMS* param)
            break;
        case SAVEt_HINTS:
            ptr = POPPTR(ss,ix);
            break;
        case SAVEt_HINTS:
            ptr = POPPTR(ss,ix);

-           if (ptr) {
-               HINTS_REFCNT_LOCK;
-               ((struct refcounted_he *)ptr)->refcounted_he_refcnt++;
-               HINTS_REFCNT_UNLOCK;
-           }
+           ptr = cophh_copy((COPHH*)ptr);

            TOPPTR(nss,ix) = ptr;
            i = POPINT(ss,ix);
            TOPINT(nss,ix) = i;
            TOPPTR(nss,ix) = ptr;
            i = POPINT(ss,ix);
            TOPINT(nss,ix) = i;


@@ -11958,7 +12634,7 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags,
     PL_parser = NULL;
     Zero(&PL_debug_pad, 1, struct perl_debug_pad);
 #  ifdef DEBUG_LEAKING_SCALARS
     PL_parser = NULL;
     Zero(&PL_debug_pad, 1, struct perl_debug_pad);
 #  ifdef DEBUG_LEAKING_SCALARS

-    PL_sv_serial = (((U32)my_perl >> 2) & 0xfff) * 1000000;
+    PL_sv_serial = (((UV)my_perl >> 2) & 0xfff) * 1000000;

 #  endif
 #else  /* !DEBUGGING */
     Zero(my_perl, 1, PerlInterpreter);
 #  endif
 #else  /* !DEBUGGING */
     Zero(my_perl, 1, PerlInterpreter);


@@ -11978,15 +12654,19 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags,
 #endif         /* PERL_IMPLICIT_SYS */
 
     param->flags = flags;
 #endif         /* PERL_IMPLICIT_SYS */
 
     param->flags = flags;

+    /* Nothing in the core code uses this, but we make it available to
+       extensions (using mg_dup).  */

     param->proto_perl = proto_perl;
     param->proto_perl = proto_perl;

+    /* Likely nothing will use this, but it is initialised to be consistent
+       with Perl_clone_params_new().  */
+    param->new_perl = my_perl;
+    param->unreferenced = NULL;

 
     INIT_TRACK_MEMPOOL(my_perl->Imemory_debug_header, my_perl);
 
     PL_body_arenas = NULL;
     Zero(&PL_body_roots, 1, PL_body_roots);
     
 
     INIT_TRACK_MEMPOOL(my_perl->Imemory_debug_header, my_perl);
 
     PL_body_arenas = NULL;
     Zero(&PL_body_roots, 1, PL_body_roots);
     

-    PL_nice_chunk      = NULL;
-    PL_nice_chunk_size = 0;

     PL_sv_count                = 0;
     PL_sv_objcount     = 0;
     PL_sv_root         = NULL;
     PL_sv_count                = 0;
     PL_sv_objcount     = 0;
     PL_sv_root         = NULL;


@@ -12056,11 +12736,7 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags,
 
     ptr_table_store(PL_ptr_table, &proto_perl->Icompiling, &PL_compiling);
     PL_compiling.cop_warnings = DUP_WARNINGS(PL_compiling.cop_warnings);
 
     ptr_table_store(PL_ptr_table, &proto_perl->Icompiling, &PL_compiling);
     PL_compiling.cop_warnings = DUP_WARNINGS(PL_compiling.cop_warnings);

-    if (PL_compiling.cop_hints_hash) {
-       HINTS_REFCNT_LOCK;
-       PL_compiling.cop_hints_hash->refcounted_he_refcnt++;
-       HINTS_REFCNT_UNLOCK;
-    }
+    CopHINTHASH_set(&PL_compiling, cophh_copy(CopHINTHASH_get(&PL_compiling)));

     PL_curcop          = (COP*)any_dup(proto_perl->Icurcop, proto_perl);
 #ifdef PERL_DEBUG_READONLY_OPS
     PL_slabs = NULL;
     PL_curcop          = (COP*)any_dup(proto_perl->Icurcop, proto_perl);
 #ifdef PERL_DEBUG_READONLY_OPS
     PL_slabs = NULL;


@@ -12072,6 +12748,17 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags,
     PL_origargv                = proto_perl->Iorigargv;
 
     param->stashes      = newAV();  /* Setup array of objects to call clone on */
     PL_origargv                = proto_perl->Iorigargv;
 
     param->stashes      = newAV();  /* Setup array of objects to call clone on */

+    /* This makes no difference to the implementation, as it always pushes
+       and shifts pointers to other SVs without changing their reference
+       count, with the array becoming empty before it is freed. However, it
+       makes it conceptually clear what is going on, and will avoid some
+       work inside av.c, filling slots between AvFILL() and AvMAX() with
+       &PL_sv_undef, and SvREFCNT_dec()ing those.  */
+    AvREAL_off(param->stashes);
+
+    if (!(flags & CLONEf_COPY_STACKS)) {
+       param->unreferenced = newAV();
+    }

 
     /* Set tainting stuff before PerlIO_debug can possibly get called */
     PL_tainting                = proto_perl->Itainting;
 
     /* Set tainting stuff before PerlIO_debug can possibly get called */
     PL_tainting                = proto_perl->Itainting;


@@ -12092,6 +12779,7 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags,
     /* switches */
     PL_minus_c         = proto_perl->Iminus_c;
     PL_patchlevel      = sv_dup_inc(proto_perl->Ipatchlevel, param);
     /* switches */
     PL_minus_c         = proto_perl->Iminus_c;
     PL_patchlevel      = sv_dup_inc(proto_perl->Ipatchlevel, param);

+    PL_apiversion      = sv_dup_inc(proto_perl->Iapiversion, param);

     PL_localpatches    = proto_perl->Ilocalpatches;
     PL_splitstr                = proto_perl->Isplitstr;
     PL_minus_n         = proto_perl->Iminus_n;
     PL_localpatches    = proto_perl->Ilocalpatches;
     PL_splitstr                = proto_perl->Isplitstr;
     PL_minus_n         = proto_perl->Iminus_n;


@@ -12102,7 +12790,6 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags,
     PL_minus_F         = proto_perl->Iminus_F;
     PL_doswitches      = proto_perl->Idoswitches;
     PL_dowarn          = proto_perl->Idowarn;
     PL_minus_F         = proto_perl->Iminus_F;
     PL_doswitches      = proto_perl->Idoswitches;
     PL_dowarn          = proto_perl->Idowarn;

-    PL_doextract       = proto_perl->Idoextract;

     PL_sawampersand    = proto_perl->Isawampersand;
     PL_unsafe          = proto_perl->Iunsafe;
     PL_inplace         = SAVEPV(proto_perl->Iinplace);
     PL_sawampersand    = proto_perl->Isawampersand;
     PL_unsafe          = proto_perl->Iunsafe;
     PL_inplace         = SAVEPV(proto_perl->Iinplace);


@@ -12144,7 +12831,7 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags,
     PL_regex_pad = AvARRAY(PL_regex_padav);
 
     /* shortcuts to various I/O objects */
     PL_regex_pad = AvARRAY(PL_regex_padav);
 
     /* shortcuts to various I/O objects */

-    PL_ofsgv            = gv_dup(proto_perl->Iofsgv, param);
+    PL_ofsgv            = gv_dup_inc(proto_perl->Iofsgv, param);

     PL_stdingv         = gv_dup(proto_perl->Istdingv, param);
     PL_stderrgv                = gv_dup(proto_perl->Istderrgv, param);
     PL_defgv           = gv_dup(proto_perl->Idefgv, param);
     PL_stdingv         = gv_dup(proto_perl->Istdingv, param);
     PL_stderrgv                = gv_dup(proto_perl->Istderrgv, param);
     PL_defgv           = gv_dup(proto_perl->Idefgv, param);


@@ -12251,6 +12938,7 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags,
     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);
     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);

+    PL_custom_ops      = hv_dup_inc(proto_perl->Icustom_ops, param);

 
     PL_profiledata     = NULL;
 
 
     PL_profiledata     = NULL;
 


@@ -12379,6 +13067,7 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags,
     PL_unlockhook      = proto_perl->Iunlockhook;
     PL_threadhook      = proto_perl->Ithreadhook;
     PL_destroyhook     = proto_perl->Idestroyhook;
     PL_unlockhook      = proto_perl->Iunlockhook;
     PL_threadhook      = proto_perl->Ithreadhook;
     PL_destroyhook     = proto_perl->Idestroyhook;

+    PL_signalhook      = proto_perl->Isignalhook;

 
 #ifdef THREADS_HAVE_PIDS
     PL_ppid            = proto_perl->Ippid;
 
 #ifdef THREADS_HAVE_PIDS
     PL_ppid            = proto_perl->Ippid;


@@ -12467,19 +13156,6 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags,
     else {
        init_stacks();
        ENTER;                  /* perl_destruct() wants to LEAVE; */
     else {
        init_stacks();
        ENTER;                  /* perl_destruct() wants to LEAVE; */

-
-       /* although we're not duplicating the tmps stack, we should still
-        * add entries for any SVs on the tmps stack that got cloned by a
-        * non-refcount means (eg a temp in @_); otherwise they will be
-        * orphaned
-        */
-       for (i = 0; i<= proto_perl->Itmps_ix; i++) {
-           SV * const nsv = MUTABLE_SV(ptr_table_fetch(PL_ptr_table,
-                   proto_perl->Itmps_stack[i]));
-           if (nsv && !SvREFCNT(nsv)) {
-               PUSH_EXTEND_MORTAL__SV_C(SvREFCNT_inc_simple(nsv));
-           }
-       }

     }
 
     PL_start_env       = proto_perl->Istart_env;       /* XXXXXX */
     }
 
     PL_start_env       = proto_perl->Istart_env;       /* XXXXXX */


@@ -12513,7 +13189,7 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags,
     PL_restartop       = proto_perl->Irestartop;
     PL_in_eval         = proto_perl->Iin_eval;
     PL_delaymagic      = proto_perl->Idelaymagic;
     PL_restartop       = proto_perl->Irestartop;
     PL_in_eval         = proto_perl->Iin_eval;
     PL_delaymagic      = proto_perl->Idelaymagic;

-    PL_dirty           = proto_perl->Idirty;
+    PL_phase           = proto_perl->Iphase;

     PL_localizing      = proto_perl->Ilocalizing;
 
     PL_errors          = sv_dup_inc(proto_perl->Ierrors, param);
     PL_localizing      = proto_perl->Ilocalizing;
 
     PL_errors          = sv_dup_inc(proto_perl->Ierrors, param);


@@ -12545,6 +13221,7 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags,
 
     /* Pluggable optimizer */
     PL_peepp           = proto_perl->Ipeepp;
 
     /* Pluggable optimizer */
     PL_peepp           = proto_perl->Ipeepp;

+    PL_rpeepp          = proto_perl->Irpeepp;

     /* op_free() hook */
     PL_opfreehook      = proto_perl->Iopfreehook;
 
     /* op_free() hook */
     PL_opfreehook      = proto_perl->Iopfreehook;
 


@@ -12561,6 +13238,8 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags,
     }
 
     PL_registered_mros  = hv_dup_inc(proto_perl->Iregistered_mros, param);
     }
 
     PL_registered_mros  = hv_dup_inc(proto_perl->Iregistered_mros, param);

+    PL_blockhooks      = av_dup_inc(proto_perl->Iblockhooks, param);
+    PL_utf8_foldclosures = hv_dup_inc(proto_perl->Iutf8_foldclosures, param);

 
     /* Call the ->CLONE method, if it exists, for each of the stashes
        identified by sv_dup() above.
 
     /* Call the ->CLONE method, if it exists, for each of the stashes
        identified by sv_dup() above.


@@ -12586,6 +13265,9 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags,
         PL_ptr_table = NULL;
     }
 
         PL_ptr_table = NULL;
     }
 

+    if (!(flags & CLONEf_COPY_STACKS)) {
+       unreferenced_to_tmp_stack(param->unreferenced);
+    }

 
     SvREFCNT_dec(param->stashes);
 
 
     SvREFCNT_dec(param->stashes);
 


@@ -12598,6 +13280,109 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags,
     return my_perl;
 }
 
     return my_perl;
 }
 

+static void
+S_unreferenced_to_tmp_stack(pTHX_ AV *const unreferenced)
+{
+    PERL_ARGS_ASSERT_UNREFERENCED_TO_TMP_STACK;
+    
+    if (AvFILLp(unreferenced) > -1) {
+       SV **svp = AvARRAY(unreferenced);
+       SV **const last = svp + AvFILLp(unreferenced);
+       SSize_t count = 0;
+
+       do {
+           if (SvREFCNT(*svp) == 1)
+               ++count;
+       } while (++svp <= last);
+
+       EXTEND_MORTAL(count);
+       svp = AvARRAY(unreferenced);
+
+       do {
+           if (SvREFCNT(*svp) == 1) {
+               /* Our reference is the only one to this SV. This means that
+                  in this thread, the scalar effectively has a 0 reference.
+                  That doesn't work (cleanup never happens), so donate our
+                  reference to it onto the save stack. */
+               PL_tmps_stack[++PL_tmps_ix] = *svp;
+           } else {
+               /* As an optimisation, because we are already walking the
+                  entire array, instead of above doing either
+                  SvREFCNT_inc(*svp) or *svp = &PL_sv_undef, we can instead
+                  release our reference to the scalar, so that at the end of
+                  the array owns zero references to the scalars it happens to
+                  point to. We are effectively converting the array from
+                  AvREAL() on to AvREAL() off. This saves the av_clear()
+                  (triggered by the SvREFCNT_dec(unreferenced) below) from
+                  walking the array a second time.  */
+               SvREFCNT_dec(*svp);
+           }
+
+       } while (++svp <= last);
+       AvREAL_off(unreferenced);
+    }
+    SvREFCNT_dec(unreferenced);
+}
+
+void
+Perl_clone_params_del(CLONE_PARAMS *param)
+{
+    /* This seemingly funky ordering keeps the build with PERL_GLOBAL_STRUCT
+       happy: */
+    PerlInterpreter *const to = param->new_perl;
+    dTHXa(to);
+    PerlInterpreter *const was = PERL_GET_THX;
+
+    PERL_ARGS_ASSERT_CLONE_PARAMS_DEL;
+
+    if (was != to) {
+       PERL_SET_THX(to);
+    }
+
+    SvREFCNT_dec(param->stashes);
+    if (param->unreferenced)
+       unreferenced_to_tmp_stack(param->unreferenced);
+
+    Safefree(param);
+
+    if (was != to) {
+       PERL_SET_THX(was);
+    }
+}
+
+CLONE_PARAMS *
+Perl_clone_params_new(PerlInterpreter *const from, PerlInterpreter *const to)
+{
+    dVAR;
+    /* Need to play this game, as newAV() can call safesysmalloc(), and that
+       does a dTHX; to get the context from thread local storage.
+       FIXME - under PERL_CORE Newx(), Safefree() and friends should expand to
+       a version that passes in my_perl.  */
+    PerlInterpreter *const was = PERL_GET_THX;
+    CLONE_PARAMS *param;
+
+    PERL_ARGS_ASSERT_CLONE_PARAMS_NEW;
+
+    if (was != to) {
+       PERL_SET_THX(to);
+    }
+
+    /* Given that we've set the context, we can do this unshared.  */
+    Newx(param, 1, CLONE_PARAMS);
+
+    param->flags = 0;
+    param->proto_perl = from;
+    param->new_perl = to;
+    param->stashes = (AV *)Perl_newSV_type(to, SVt_PVAV);
+    AvREAL_off(param->stashes);
+    param->unreferenced = (AV *)Perl_newSV_type(to, SVt_PVAV);
+
+    if (was != to) {
+       PERL_SET_THX(was);
+    }
+    return param;
+}
+

 #endif /* USE_ITHREADS */
 
 /*
 #endif /* USE_ITHREADS */
 
 /*


@@ -12947,7 +13732,7 @@ S_find_uninit_var(pTHX_ const OP *const obase, const SV *const uninit_sv,
 
     case OP_GVSV:
        gv = cGVOPx_gv(obase);
 
     case OP_GVSV:
        gv = cGVOPx_gv(obase);

-       if (!gv || (match && GvSV(gv) != uninit_sv))
+       if (!gv || (match && GvSV(gv) != uninit_sv) || !GvSTASH(gv))

            break;
        return varname(gv, '$', 0, NULL, 0, FUV_SUBSCRIPT_NONE);
 
            break;
        return varname(gv, '$', 0, NULL, 0, FUV_SUBSCRIPT_NONE);
 


@@ -13246,6 +14031,12 @@ S_find_uninit_var(pTHX_ const OP *const obase, const SV *const uninit_sv,
                if ( (type == OP_CONST && SvOK(cSVOPx_sv(kid)))
                  || (type == OP_NULL  && ! (kid->op_flags & OPf_KIDS))
                  || (type == OP_PUSHMARK)
                if ( (type == OP_CONST && SvOK(cSVOPx_sv(kid)))
                  || (type == OP_NULL  && ! (kid->op_flags & OPf_KIDS))
                  || (type == OP_PUSHMARK)

+                 || (
+                     /* @$a and %$a, but not @a or %a */
+                       (type == OP_RV2AV || type == OP_RV2HV)
+                    && cUNOPx(kid)->op_first
+                    && cUNOPx(kid)->op_first->op_type != OP_GV
+                    )

                )
                continue;
            }
                )
                continue;
            }