Upgrade Win32 from version 0.48 to 0.49

[perl5.git] / sv.c

diff --git a/sv.c b/sv.c
index f17508b..087606b 100644 (file)
--- a/sv.c
+++ b/sv.c
@@ -33,11 +33,11 @@
 #include "regcomp.h"
 
 #ifndef HAS_C99
 #include "regcomp.h"
 
 #ifndef HAS_C99

-# if __STDC_VERSION__ >= 199901L && !defined(VMS)
+# if defined(__STDC_VERSION__) && __STDC_VERSION__ >= 199901L && !defined(VMS)

 #  define HAS_C99 1
 # endif
 #endif
 #  define HAS_C99 1
 # endif
 #endif

-#if HAS_C99
+#ifdef HAS_C99

 # include <stdint.h>
 #endif
 
 # include <stdint.h>
 #endif
 


@@ -46,6 +46,17 @@
   char *gconvert(double, int, int,  char *);
 #endif
 
   char *gconvert(double, int, int,  char *);
 #endif
 

+/* void Gconvert: on Linux at least, gcvt (which Gconvert gets deffed to),
+ * has a mandatory return value, even though that value is just the same
+ * as the buf arg */
+
+#define V_Gconvert(x,n,t,b) \
+{ \
+    char *rc = (char *)Gconvert(x,n,t,b); \
+    PERL_UNUSED_VAR(rc); \
+}
+
+

 #ifdef PERL_UTF8_CACHE_ASSERT
 /* if adding more checks watch out for the following tests:
  *   t/op/index.t t/op/length.t t/op/pat.t t/op/substr.t
 #ifdef PERL_UTF8_CACHE_ASSERT
 /* if adding more checks watch out for the following tests:
  *   t/op/index.t t/op/length.t t/op/pat.t t/op/substr.t


@@ -770,19 +781,19 @@ is "not there", because you'll be overwriting the last members of the
 preceding structure in memory.)
 
 We calculate the correction using the STRUCT_OFFSET macro on the first
 preceding structure in memory.)
 
 We calculate the correction using the STRUCT_OFFSET macro on the first

-member present. If the allocated structure is smaller (no initial NV
+member present.  If the allocated structure is smaller (no initial NV

 actually allocated) then the net effect is to subtract the size of the NV
 from the pointer, to return a new pointer as if an initial NV were actually
 actually allocated) then the net effect is to subtract the size of the NV
 from the pointer, to return a new pointer as if an initial NV were actually

-allocated. (We were using structures named *_allocated for this, but
+allocated.  (We were using structures named *_allocated for this, but

 this turned out to be a subtle bug, because a structure without an NV
 could have a lower alignment constraint, but the compiler is allowed to
 optimised accesses based on the alignment constraint of the actual pointer
 to the full structure, for example, using a single 64 bit load instruction
 because it "knows" that two adjacent 32 bit members will be 8-byte aligned.)
 
 this turned out to be a subtle bug, because a structure without an NV
 could have a lower alignment constraint, but the compiler is allowed to
 optimised accesses based on the alignment constraint of the actual pointer
 to the full structure, for example, using a single 64 bit load instruction
 because it "knows" that two adjacent 32 bit members will be 8-byte aligned.)
 

-This is the same trick as was used for NV and IV bodies. Ironically it
+This is the same trick as was used for NV and IV bodies.  Ironically it

 doesn't need to be used for NV bodies any more, because NV is now at
 doesn't need to be used for NV bodies any more, because NV is now at

-the start of the structure. IV bodies don't need it either, because
+the start of the structure.  IV bodies don't need it either, because

 they are no longer allocated.
 
 In turn, the new_body_* allocators call S_new_body(), which invokes
 they are no longer allocated.
 
 In turn, the new_body_* allocators call S_new_body(), which invokes


@@ -2289,8 +2300,7 @@ Perl_sv_2iv_flags(pTHX_ SV *const sv, const I32 flags)
 {
     dVAR;
 
 {
     dVAR;
 

-    if (!sv)
-       return 0;
+    PERL_ARGS_ASSERT_SV_2IV_FLAGS;

 
     assert (SvTYPE(sv) != SVt_PVAV && SvTYPE(sv) != SVt_PVHV
         && SvTYPE(sv) != SVt_PVFM);
 
     assert (SvTYPE(sv) != SVt_PVAV && SvTYPE(sv) != SVt_PVHV
         && SvTYPE(sv) != SVt_PVFM);


@@ -2385,8 +2395,7 @@ Perl_sv_2uv_flags(pTHX_ SV *const sv, const I32 flags)
 {
     dVAR;
 
 {
     dVAR;
 

-    if (!sv)
-       return 0;
+    PERL_ARGS_ASSERT_SV_2UV_FLAGS;

 
     if (SvGMAGICAL(sv) && (flags & SV_GMAGIC))
        mg_get(sv);
 
     if (SvGMAGICAL(sv) && (flags & SV_GMAGIC))
        mg_get(sv);


@@ -2467,8 +2476,9 @@ NV
 Perl_sv_2nv_flags(pTHX_ SV *const sv, const I32 flags)
 {
     dVAR;
 Perl_sv_2nv_flags(pTHX_ SV *const sv, const I32 flags)
 {
     dVAR;

-    if (!sv)
-       return 0.0;
+
+    PERL_ARGS_ASSERT_SV_2NV_FLAGS;
+

     assert (SvTYPE(sv) != SVt_PVAV && SvTYPE(sv) != SVt_PVHV
         && SvTYPE(sv) != SVt_PVFM);
     if (SvGMAGICAL(sv) || SvVALID(sv) || isREGEXP(sv)) {
     assert (SvTYPE(sv) != SVt_PVAV && SvTYPE(sv) != SVt_PVHV
         && SvTYPE(sv) != SVt_PVFM);
     if (SvGMAGICAL(sv) || SvVALID(sv) || isREGEXP(sv)) {


@@ -2771,11 +2781,8 @@ Perl_sv_2pv_flags(pTHX_ SV *const sv, STRLEN *const lp, const I32 flags)
     dVAR;
     char *s;
 
     dVAR;
     char *s;
 

-    if (!sv) {
-       if (lp)
-           *lp = 0;
-       return (char *)"";
-    }
+    PERL_ARGS_ASSERT_SV_2PV_FLAGS;
+

     assert (SvTYPE(sv) != SVt_PVAV && SvTYPE(sv) != SVt_PVHV
         && SvTYPE(sv) != SVt_PVFM);
     if (SvGMAGICAL(sv) && (flags & SV_GMAGIC))
     assert (SvTYPE(sv) != SVt_PVAV && SvTYPE(sv) != SVt_PVHV
         && SvTYPE(sv) != SVt_PVFM);
     if (SvGMAGICAL(sv) && (flags & SV_GMAGIC))


@@ -2947,34 +2954,22 @@ Perl_sv_2pv_flags(pTHX_ SV *const sv, STRLEN *const lp, const I32 flags)
            /* some Xenix systems wipe out errno here */
 
 #ifndef USE_LOCALE_NUMERIC
            /* some Xenix systems wipe out errno here */
 
 #ifndef USE_LOCALE_NUMERIC

-            Gconvert(SvNVX(sv), NV_DIG, 0, s);
+            V_Gconvert(SvNVX(sv), NV_DIG, 0, s);

             SvPOK_on(sv);
 #else
             SvPOK_on(sv);
 #else

-            /* Gconvert always uses the current locale.  That's the right thing
-             * to do if we're supposed to be using locales.  But otherwise, we
-             * want the result to be based on the C locale, so we need to
-             * change to the C locale during the Gconvert and then change back.
-             * But if we're already in the C locale (PL_numeric_standard is
-             * TRUE in that case), no need to do any changing */
-            if (PL_numeric_standard || IN_SOME_LOCALE_FORM_RUNTIME) {
-                Gconvert(SvNVX(sv), NV_DIG, 0, s);
+            {
+                DECLARE_STORE_LC_NUMERIC_SET_TO_NEEDED();
+                V_Gconvert(SvNVX(sv), NV_DIG, 0, s);

 
                 /* If the radix character is UTF-8, and actually is in the
                  * output, turn on the UTF-8 flag for the scalar */
 
                 /* If the radix character is UTF-8, and actually is in the
                  * output, turn on the UTF-8 flag for the scalar */

-                if (! PL_numeric_standard
+                if (PL_numeric_local

                     && PL_numeric_radix_sv && SvUTF8(PL_numeric_radix_sv)
                     && instr(s, SvPVX_const(PL_numeric_radix_sv)))
                 {
                     SvUTF8_on(sv);
                 }
                     && PL_numeric_radix_sv && SvUTF8(PL_numeric_radix_sv)
                     && instr(s, SvPVX_const(PL_numeric_radix_sv)))
                 {
                     SvUTF8_on(sv);
                 }

-            }
-            else {
-                char *loc = savepv(setlocale(LC_NUMERIC, NULL));
-                setlocale(LC_NUMERIC, "C");
-                Gconvert(SvNVX(sv), NV_DIG, 0, s);
-                setlocale(LC_NUMERIC, loc);
-                Safefree(loc);
-
+                RESTORE_LC_NUMERIC();

             }
 
             /* We don't call SvPOK_on(), because it may come to pass that the
             }
 
             /* We don't call SvPOK_on(), because it may come to pass that the


@@ -3224,35 +3219,39 @@ Always sets the SvUTF8 flag to avoid future validity checks even
 if all the bytes are invariant in UTF-8.
 If C<flags> has C<SV_GMAGIC> bit set,
 will C<mg_get> on C<sv> if appropriate, else not.
 if all the bytes are invariant in UTF-8.
 If C<flags> has C<SV_GMAGIC> bit set,
 will C<mg_get> on C<sv> if appropriate, else not.

-Returns the number of bytes in the converted string
-C<sv_utf8_upgrade> and
-C<sv_utf8_upgrade_nomg> are implemented in terms of this function.
+
+If C<flags> has SV_FORCE_UTF8_UPGRADE set, this function assumes that the PV
+will expand when converted to UTF-8, and skips the extra work of checking for
+that.  Typically this flag is used by a routine that has already parsed the
+string and found such characters, and passes this information on so that the
+work doesn't have to be repeated.
+
+Returns the number of bytes in the converted string.

 
 This is not a general purpose byte encoding to Unicode interface:
 use the Encode extension for that.
 
 
 This is not a general purpose byte encoding to Unicode interface:
 use the Encode extension for that.
 

-=cut
+=for apidoc sv_utf8_upgrade_flags_grow
+
+Like sv_utf8_upgrade_flags, but has an additional parameter C<extra>, which is
+the number of unused bytes the string of 'sv' is guaranteed to have free after
+it upon return.  This allows the caller to reserve extra space that it intends
+to fill, to avoid extra grows.

 
 

-The grow version is currently not externally documented.  It adds a parameter,
-extra, which is the number of unused bytes the string of 'sv' is guaranteed to
-have free after it upon return.  This allows the caller to reserve extra space
-that it intends to fill, to avoid extra grows.
+C<sv_utf8_upgrade>, C<sv_utf8_upgrade_nomg>, and C<sv_utf8_upgrade_flags>
+are implemented in terms of this function.

 
 

-Also externally undocumented for the moment is the flag SV_FORCE_UTF8_UPGRADE,
-which can be used to tell this function to not first check to see if there are
-any characters that are different in UTF-8 (variant characters) which would
-force it to allocate a new string to sv, but to assume there are.  Typically
-this flag is used by a routine that has already parsed the string to find that
-there are such characters, and passes this information on so that the work
-doesn't have to be repeated.
+Returns the number of bytes in the converted string (not including the spares).
+
+=cut

 
 (One might think that the calling routine could pass in the position of the
 
 (One might think that the calling routine could pass in the position of the

-first such variant, so it wouldn't have to be found again.  But that is not the
-case, because typically when the caller is likely to use this flag, it won't be
-calling this routine unless it finds something that won't fit into a byte.
-Otherwise it tries to not upgrade and just use bytes.  But some things that
-do fit into a byte are variants in utf8, and the caller may not have been
-keeping track of these.)
+first variant character when it has set SV_FORCE_UTF8_UPGRADE, so it wouldn't
+have to be found again.  But that is not the case, because typically when the
+caller is likely to use this flag, it won't be calling this routine unless it
+finds something that won't fit into a byte.  Otherwise it tries to not upgrade
+and just use bytes.  But some things that do fit into a byte are variants in
+utf8, and the caller may not have been keeping track of these.)

 
 If the routine itself changes the string, it adds a trailing NUL.  Such a NUL
 isn't guaranteed due to having other routines do the work in some input cases,
 
 If the routine itself changes the string, it adds a trailing NUL.  Such a NUL
 isn't guaranteed due to having other routines do the work in some input cases,


@@ -3662,9 +3661,10 @@ Perl_sv_utf8_decode(pTHX_ SV *const sv)
 
 Copies the contents of the source SV C<ssv> into the destination SV
 C<dsv>.  The source SV may be destroyed if it is mortal, so don't use this
 
 Copies the contents of the source SV C<ssv> into the destination SV
 C<dsv>.  The source SV may be destroyed if it is mortal, so don't use this

-function if the source SV needs to be reused.  Does not handle 'set' magic.
-Loosely speaking, it performs a copy-by-value, obliterating any previous
-content of the destination.
+function if the source SV needs to be reused.  Does not handle 'set' magic on
+destination SV.  Calls 'get' magic on source SV.  Loosely speaking, it
+performs a copy-by-value, obliterating any previous content of the
+destination.

 
 You probably want to use one of the assortment of wrappers, such as
 C<SvSetSV>, C<SvSetSV_nosteal>, C<SvSetMagicSV> and
 
 You probably want to use one of the assortment of wrappers, such as
 C<SvSetSV>, C<SvSetSV_nosteal>, C<SvSetMagicSV> and


@@ -3679,7 +3679,7 @@ Loosely speaking, it performs a copy-by-value, obliterating any previous
 content of the destination.
 If the C<flags> parameter has the C<SV_GMAGIC> bit set, will C<mg_get> on
 C<ssv> if appropriate, else not.  If the C<flags>
 content of the destination.
 If the C<flags> parameter has the C<SV_GMAGIC> bit set, will C<mg_get> on
 C<ssv> if appropriate, else not.  If the C<flags>

-parameter has the C<NOSTEAL> bit set then the
+parameter has the C<SV_NOSTEAL> bit set then the

 buffers of temps will not be stolen.  <sv_setsv>
 and C<sv_setsv_nomg> are implemented in terms of this function.
 
 buffers of temps will not be stolen.  <sv_setsv>
 and C<sv_setsv_nomg> are implemented in terms of this function.
 


@@ -3713,8 +3713,6 @@ S_glob_assign_glob(pTHX_ SV *const dstr, SV *const sstr, const int dtype)
            }
            SvUPGRADE(dstr, SVt_PVGV);
            (void)SvOK_off(dstr);
            }
            SvUPGRADE(dstr, SVt_PVGV);
            (void)SvOK_off(dstr);

-           /* We have to turn this on here, even though we turn it off
-              below, as GvSTASH will fail an assertion otherwise. */

            isGV_with_GP_on(dstr);
        }
        GvSTASH(dstr) = GvSTASH(sstr);
            isGV_with_GP_on(dstr);
        }
        GvSTASH(dstr) = GvSTASH(sstr);


@@ -3775,12 +3773,11 @@ S_glob_assign_glob(pTHX_ SV *const dstr, SV *const sstr, const int dtype)
                     );
             }
         }
                     );
             }
         }

+
+        SvREFCNT_inc_simple_void_NN(sv_2mortal(dstr));

     }
 
     gp_free(MUTABLE_GV(dstr));
     }
 
     gp_free(MUTABLE_GV(dstr));

-    isGV_with_GP_off(dstr); /* SvOK_off does not like globs. */
-    (void)SvOK_off(dstr);
-    isGV_with_GP_on(dstr);

     GvINTRO_off(dstr);         /* one-shot flag */
     GvGP_set(dstr, gp_ref(GvGP(sstr)));
     if (SvTAINTED(sstr))
     GvINTRO_off(dstr);         /* one-shot flag */
     GvGP_set(dstr, gp_ref(GvGP(sstr)));
     if (SvTAINTED(sstr))


@@ -4033,6 +4030,48 @@ S_glob_assign_ref(pTHX_ SV *const dstr, SV *const sstr)
 # define GE_COWBUF_THRESHOLD(len)      1
 #endif
 
 # define GE_COWBUF_THRESHOLD(len)      1
 #endif
 

+#ifdef PERL_DEBUG_READONLY_COW
+# include <sys/mman.h>
+
+# ifndef PERL_MEMORY_DEBUG_HEADER_SIZE
+#  define PERL_MEMORY_DEBUG_HEADER_SIZE 0
+# endif
+
+void
+Perl_sv_buf_to_ro(pTHX_ SV *sv)
+{
+    struct perl_memory_debug_header * const header =
+       (struct perl_memory_debug_header *)(SvPVX(sv)-PERL_MEMORY_DEBUG_HEADER_SIZE);
+    const MEM_SIZE len = header->size;
+    PERL_ARGS_ASSERT_SV_BUF_TO_RO;
+# ifdef PERL_TRACK_MEMPOOL
+    if (!header->readonly) header->readonly = 1;
+# endif
+    if (mprotect(header, len, PROT_READ))
+       Perl_warn(aTHX_ "mprotect RW for COW string %p %lu failed with %d",
+                        header, len, errno);
+}
+
+static void
+S_sv_buf_to_rw(pTHX_ SV *sv)
+{
+    struct perl_memory_debug_header * const header =
+       (struct perl_memory_debug_header *)(SvPVX(sv)-PERL_MEMORY_DEBUG_HEADER_SIZE);
+    const MEM_SIZE len = header->size;
+    PERL_ARGS_ASSERT_SV_BUF_TO_RW;
+    if (mprotect(header, len, PROT_READ|PROT_WRITE))
+       Perl_warn(aTHX_ "mprotect for COW string %p %lu failed with %d",
+                        header, len, errno);
+# ifdef PERL_TRACK_MEMPOOL
+    header->readonly = 0;
+# endif
+}
+
+#else
+# define sv_buf_to_ro(sv)      NOOP
+# define sv_buf_to_rw(sv)      NOOP
+#endif
+

 void
 Perl_sv_setsv_flags(pTHX_ SV *dstr, SV* sstr, const I32 flags)
 {
 void
 Perl_sv_setsv_flags(pTHX_ SV *dstr, SV* sstr, const I32 flags)
 {


@@ -4275,8 +4314,10 @@ Perl_sv_setsv_flags(pTHX_ SV *dstr, SV* sstr, const I32 flags)
                    reset_isa = TRUE;
                }
 
                    reset_isa = TRUE;
                }
 

-               if (GvGP(dstr))
+               if (GvGP(dstr)) {
+                   SvREFCNT_inc_simple_void_NN(sv_2mortal(dstr));

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

+               }

                GvGP_set(dstr, gp_ref(GvGP(gv)));
 
                if (reset_isa) {
                GvGP_set(dstr, gp_ref(GvGP(gv)));
 
                if (reset_isa) {


@@ -4297,18 +4338,50 @@ Perl_sv_setsv_flags(pTHX_ SV *dstr, SV* sstr, const I32 flags)
        reg_temp_copy((REGEXP*)dstr, (REGEXP*)sstr);
     }
     else if (sflags & SVp_POK) {
        reg_temp_copy((REGEXP*)dstr, (REGEXP*)sstr);
     }
     else if (sflags & SVp_POK) {

-        bool isSwipe = 0;

        const STRLEN cur = SvCUR(sstr);
        const STRLEN len = SvLEN(sstr);
 
        /*
        const STRLEN cur = SvCUR(sstr);
        const STRLEN len = SvLEN(sstr);
 
        /*

-        * Check to see if we can just swipe the string.  If so, it's a
-        * possible small lose on short strings, but a big win on long ones.
-        * It might even be a win on short strings if SvPVX_const(dstr)
-        * has to be allocated and SvPVX_const(sstr) has to be freed.
-        * Likewise if we can set up COW rather than doing an actual copy, we
-        * drop to the else clause, as the swipe code and the COW setup code
-        * have much in common.
+        * We have three basic ways to copy the string:
+        *
+        *  1. Swipe
+        *  2. Copy-on-write
+        *  3. Actual copy
+        * 
+        * Which we choose is based on various factors.  The following
+        * things are listed in order of speed, fastest to slowest:
+        *  - Swipe
+        *  - Copying a short string
+        *  - Copy-on-write bookkeeping
+        *  - malloc
+        *  - Copying a long string
+        * 
+        * We swipe the string (steal the string buffer) if the SV on the
+        * rhs is about to be freed anyway (TEMP and refcnt==1).  This is a
+        * big win on long strings.  It should be a win on short strings if
+        * SvPVX_const(dstr) has to be allocated.  If not, it should not 
+        * slow things down, as SvPVX_const(sstr) would have been freed
+        * soon anyway.
+        * 
+        * We also steal the buffer from a PADTMP (operator target) if it
+        * is ‘long enough’.  For short strings, a swipe does not help
+        * here, as it causes more malloc calls the next time the target
+        * is used.  Benchmarks show that even if SvPVX_const(dstr) has to
+        * be allocated it is still not worth swiping PADTMPs for short
+        * strings, as the savings here are small.
+        * 
+        * If the rhs is already flagged as a copy-on-write string and COW
+        * is possible here, we use copy-on-write and make both SVs share
+        * the string buffer.
+        * 
+        * If the rhs is not flagged as copy-on-write, then we see whether
+        * it is worth upgrading it to such.  If the lhs already has a buf-
+        * fer big enough and the string is short, we skip it and fall back
+        * to method 3, since memcpy is faster for short strings than the
+        * later bookkeeping overhead that copy-on-write entails.
+        * 
+        * If there is no buffer on the left, or the buffer is too small,
+        * then we use copy-on-write.

         */
 
        /* Whichever path we take through the next code, we want this true,
         */
 
        /* Whichever path we take through the next code, we want this true,


@@ -4316,86 +4389,70 @@ Perl_sv_setsv_flags(pTHX_ SV *dstr, SV* sstr, const I32 flags)
        (void)SvPOK_only(dstr);
 
        if (
        (void)SvPOK_only(dstr);
 
        if (

-           /* If we're already COW then this clause is not true, and if COW
-              is allowed then we drop down to the else and make dest COW 
-              with us.  If caller hasn't said that we're allowed to COW
-              shared hash keys then we don't do the COW setup, even if the
-              source scalar is a shared hash key scalar.  */
-            (((flags & SV_COW_SHARED_HASH_KEYS)
-              ? !(sflags & SVf_IsCOW)
-#ifdef PERL_NEW_COPY_ON_WRITE
-               || (len &&
-                   ((!GE_COWBUF_THRESHOLD(cur) && SvLEN(dstr) > cur)
-                  /* If this is a regular (non-hek) COW, only so many COW
-                     "copies" are possible. */
-                   || CowREFCNT(sstr) == SV_COW_REFCNT_MAX))
-#endif
-              : 1 /* If making a COW copy is forbidden then the behaviour we
-                      desire is as if the source SV isn't actually already
-                      COW, even if it is.  So we act as if the source flags
-                      are not COW, rather than actually testing them.  */
-             )
-#ifndef PERL_ANY_COW
-            /* The change that added SV_COW_SHARED_HASH_KEYS makes the logic
-               when PERL_OLD_COPY_ON_WRITE is defined a little wrong.
-               Conceptually PERL_OLD_COPY_ON_WRITE being defined should
-               override SV_COW_SHARED_HASH_KEYS, because it means "always COW"
-               but in turn, it's somewhat dead code, never expected to go
-               live, but more kept as a placeholder on how to do it better
-               in a newer implementation.  */
-            /* If we are COW and dstr is a suitable target then we drop down
-               into the else and make dest a COW of us.  */
-            || (SvFLAGS(dstr) & SVf_BREAK)
-#endif
-            )
-            &&
-            !(isSwipe =
-#ifdef PERL_NEW_COPY_ON_WRITE
+                 (              /* Either ... */

                                /* slated for free anyway (and not COW)? */
                                /* slated for free anyway (and not COW)? */

-                 (sflags & (SVs_TEMP|SVf_IsCOW)) == SVs_TEMP &&
-#else
-                 (sflags & SVs_TEMP) &&   /* slated for free anyway? */
-#endif
+                    (sflags & (SVs_TEMP|SVf_IsCOW)) == SVs_TEMP
+                                /* or a swipable TARG */
+                 || ((sflags & (SVs_PADTMP|SVf_READONLY|SVf_IsCOW))
+                       == SVs_PADTMP
+                                /* whose buffer is worth stealing */
+                     && GE_COWBUF_THRESHOLD(cur)
+                    )
+                 ) &&

                  !(sflags & SVf_OOK) &&   /* and not involved in OOK hack? */
                 (!(flags & SV_NOSTEAL)) &&
                                        /* and we're allowed to steal temps */
                  SvREFCNT(sstr) == 1 &&   /* and no other references to it? */
                  len)             /* and really is a string */
                  !(sflags & SVf_OOK) &&   /* and not involved in OOK hack? */
                 (!(flags & SV_NOSTEAL)) &&
                                        /* and we're allowed to steal temps */
                  SvREFCNT(sstr) == 1 &&   /* and no other references to it? */
                  len)             /* and really is a string */

-#ifdef PERL_ANY_COW
-            && ((flags & SV_COW_SHARED_HASH_KEYS)
-               ? (!((sflags & CAN_COW_MASK) == CAN_COW_FLAGS
-# ifdef PERL_OLD_COPY_ON_WRITE
+       {       /* Passes the swipe test.  */
+           if (SvPVX_const(dstr))      /* we know that dtype >= SVt_PV */
+               SvPV_free(dstr);
+           SvPV_set(dstr, SvPVX_mutable(sstr));
+           SvLEN_set(dstr, SvLEN(sstr));
+           SvCUR_set(dstr, SvCUR(sstr));
+
+           SvTEMP_off(dstr);
+           (void)SvOK_off(sstr);       /* NOTE: nukes most SvFLAGS on sstr */
+           SvPV_set(sstr, NULL);
+           SvLEN_set(sstr, 0);
+           SvCUR_set(sstr, 0);
+           SvTEMP_off(sstr);
+        }
+       else if (flags & SV_COW_SHARED_HASH_KEYS
+             &&
+#ifdef PERL_OLD_COPY_ON_WRITE
+                (  sflags & SVf_IsCOW
+                || (   (sflags & CAN_COW_MASK) == CAN_COW_FLAGS

                     && (SvFLAGS(dstr) & CAN_COW_MASK) == CAN_COW_FLAGS
                     && SvTYPE(sstr) >= SVt_PVIV && len
                     && (SvFLAGS(dstr) & CAN_COW_MASK) == CAN_COW_FLAGS
                     && SvTYPE(sstr) >= SVt_PVIV && len

-# else
+                   )
+                )
+#elif defined(PERL_NEW_COPY_ON_WRITE)
+                (sflags & SVf_IsCOW
+                  ? (!len ||
+                      (  (GE_COWBUF_THRESHOLD(cur) || SvLEN(dstr) < cur+1)
+                         /* If this is a regular (non-hek) COW, only so
+                            many COW "copies" are possible. */
+                      && CowREFCNT(sstr) != SV_COW_REFCNT_MAX  ))
+                  : (  (sflags & CAN_COW_MASK) == CAN_COW_FLAGS

                     && !(SvFLAGS(dstr) & SVf_BREAK)
                     && !(SvFLAGS(dstr) & SVf_BREAK)

-                    && !(sflags & SVf_IsCOW)

                     && GE_COW_THRESHOLD(cur) && cur+1 < len
                     && (GE_COWBUF_THRESHOLD(cur) || SvLEN(dstr) < cur+1)
                     && GE_COW_THRESHOLD(cur) && cur+1 < len
                     && (GE_COWBUF_THRESHOLD(cur) || SvLEN(dstr) < cur+1)

-# endif

                    ))
                    ))

-               : 1)
+#else
+                sflags & SVf_IsCOW
+             && !(SvFLAGS(dstr) & SVf_BREAK)

 #endif
             ) {
 #endif
             ) {

-            /* Failed the swipe test, and it's not a shared hash key either.
-               Have to copy the string.  */
-            SvGROW(dstr, cur + 1);     /* inlined from sv_setpvn */
-            Move(SvPVX_const(sstr),SvPVX(dstr),cur,char);
-            SvCUR_set(dstr, cur);
-            *SvEND(dstr) = '\0';
-        } else {
-            /* If PERL_OLD_COPY_ON_WRITE is not defined, then isSwipe will always
-               be true in here.  */

             /* Either it's a shared hash key, or it's suitable for
             /* Either it's a shared hash key, or it's suitable for

-               copy-on-write or we can swipe the string.  */
+               copy-on-write.  */

             if (DEBUG_C_TEST) {
                 PerlIO_printf(Perl_debug_log, "Copy on write: sstr --> dstr\n");
                 sv_dump(sstr);
                 sv_dump(dstr);
             }
 #ifdef PERL_ANY_COW
             if (DEBUG_C_TEST) {
                 PerlIO_printf(Perl_debug_log, "Copy on write: sstr --> dstr\n");
                 sv_dump(sstr);
                 sv_dump(dstr);
             }
 #ifdef PERL_ANY_COW

-            if (!isSwipe) {
-                if (!(sflags & SVf_IsCOW)) {
+            if (!(sflags & SVf_IsCOW)) {

                     SvIsCOW_on(sstr);
 # ifdef PERL_OLD_COPY_ON_WRITE
                     /* Make the source SV into a loop of 1.
                     SvIsCOW_on(sstr);
 # ifdef PERL_OLD_COPY_ON_WRITE
                     /* Make the source SV into a loop of 1.


@@ -4404,18 +4461,14 @@ Perl_sv_setsv_flags(pTHX_ SV *dstr, SV* sstr, const I32 flags)
 # else
                    CowREFCNT(sstr) = 0;
 # endif
 # else
                    CowREFCNT(sstr) = 0;
 # endif

-                }

             }
 #endif
             }
 #endif

-            /* Initial code is common.  */

            if (SvPVX_const(dstr)) {    /* we know that dtype >= SVt_PV */
                SvPV_free(dstr);
            }
 
            if (SvPVX_const(dstr)) {    /* we know that dtype >= SVt_PV */
                SvPV_free(dstr);
            }
 

-            if (!isSwipe) {
-                /* making another shared SV.  */

 #ifdef PERL_ANY_COW
 #ifdef PERL_ANY_COW

-                if (len) {
+           if (len) {

 # ifdef PERL_OLD_COPY_ON_WRITE
                    assert (SvTYPE(dstr) >= SVt_PVIV);
                     /* SvIsCOW_normal */
 # ifdef PERL_OLD_COPY_ON_WRITE
                    assert (SvTYPE(dstr) >= SVt_PVIV);
                     /* SvIsCOW_normal */


@@ -4423,12 +4476,16 @@ Perl_sv_setsv_flags(pTHX_ SV *dstr, SV* sstr, const I32 flags)
                     SV_COW_NEXT_SV_SET(dstr, SV_COW_NEXT_SV(sstr));
                     SV_COW_NEXT_SV_SET(sstr, dstr);
 # else
                     SV_COW_NEXT_SV_SET(dstr, SV_COW_NEXT_SV(sstr));
                     SV_COW_NEXT_SV_SET(sstr, dstr);
 # else

+                   if (sflags & SVf_IsCOW) {
+                       sv_buf_to_rw(sstr);
+                   }

                    CowREFCNT(sstr)++;
 # endif
                     SvPV_set(dstr, SvPVX_mutable(sstr));
                    CowREFCNT(sstr)++;
 # endif
                     SvPV_set(dstr, SvPVX_mutable(sstr));

-                } else
+                    sv_buf_to_ro(sstr);
+            } else

 #endif
 #endif

-               {
+            {

                     /* SvIsCOW_shared_hash */
                     DEBUG_C(PerlIO_printf(Perl_debug_log,
                                           "Copy on write: Sharing hash\n"));
                     /* SvIsCOW_shared_hash */
                     DEBUG_C(PerlIO_printf(Perl_debug_log,
                                           "Copy on write: Sharing hash\n"));


@@ -4436,24 +4493,17 @@ Perl_sv_setsv_flags(pTHX_ SV *dstr, SV* sstr, const I32 flags)
                    assert (SvTYPE(dstr) >= SVt_PV);
                     SvPV_set(dstr,
                             HEK_KEY(share_hek_hek(SvSHARED_HEK_FROM_PV(SvPVX_const(sstr)))));
                    assert (SvTYPE(dstr) >= SVt_PV);
                     SvPV_set(dstr,
                             HEK_KEY(share_hek_hek(SvSHARED_HEK_FROM_PV(SvPVX_const(sstr)))));

-               }
-                SvLEN_set(dstr, len);
-                SvCUR_set(dstr, cur);
-                SvIsCOW_on(dstr);
-            }
-            else
-                {      /* Passes the swipe test.  */
-                SvPV_set(dstr, SvPVX_mutable(sstr));
-                SvLEN_set(dstr, SvLEN(sstr));
-                SvCUR_set(dstr, SvCUR(sstr));
-
-                SvTEMP_off(dstr);
-                (void)SvOK_off(sstr);  /* NOTE: nukes most SvFLAGS on sstr */
-                SvPV_set(sstr, NULL);
-                SvLEN_set(sstr, 0);
-                SvCUR_set(sstr, 0);
-                SvTEMP_off(sstr);
-            }
+           }
+           SvLEN_set(dstr, len);
+           SvCUR_set(dstr, cur);
+           SvIsCOW_on(dstr);
+       } else {
+           /* Failed the swipe test, and we cannot do copy-on-write either.
+              Have to copy the string.  */
+           SvGROW(dstr, cur + 1);      /* inlined from sv_setpvn */
+           Move(SvPVX_const(sstr),SvPVX(dstr),cur,char);
+           SvCUR_set(dstr, cur);
+           *SvEND(dstr) = '\0';

         }
        if (sflags & SVp_NOK) {
            SvNV_set(dstr, SvNVX(sstr));
         }
        if (sflags & SVp_NOK) {
            SvNV_set(dstr, SvNVX(sstr));


@@ -4526,6 +4576,9 @@ Perl_sv_setsv_cow(pTHX_ SV *dstr, SV *sstr)
     STRLEN cur = SvCUR(sstr);
     STRLEN len = SvLEN(sstr);
     char *new_pv;
     STRLEN cur = SvCUR(sstr);
     STRLEN len = SvLEN(sstr);
     char *new_pv;

+#if defined(PERL_DEBUG_READONLY_COW) && defined(PERL_NEW_COPY_ON_WRITE)
+    const bool already = cBOOL(SvIsCOW(sstr));
+#endif

 
     PERL_ARGS_ASSERT_SV_SETSV_COW;
 
 
     PERL_ARGS_ASSERT_SV_SETSV_COW;
 


@@ -4586,9 +4639,13 @@ Perl_sv_setsv_cow(pTHX_ SV *dstr, SV *sstr)
 # ifdef PERL_OLD_COPY_ON_WRITE
     SV_COW_NEXT_SV_SET(sstr, dstr);
 # else
 # ifdef PERL_OLD_COPY_ON_WRITE
     SV_COW_NEXT_SV_SET(sstr, dstr);
 # else

+#  ifdef PERL_DEBUG_READONLY_COW
+    if (already) sv_buf_to_rw(sstr);
+#  endif

     CowREFCNT(sstr)++; 
 # endif
     new_pv = SvPVX_mutable(sstr);
     CowREFCNT(sstr)++; 
 # endif
     new_pv = SvPVX_mutable(sstr);

+    sv_buf_to_ro(sstr);

 
   common_exit:
     SvPV_set(dstr, new_pv);
 
   common_exit:
     SvPV_set(dstr, new_pv);


@@ -4863,6 +4920,7 @@ S_sv_release_COW(pTHX_ SV *sv, const char *pvx, SV *after)
                in the loop.)
                Hence other SV is no longer copy on write either.  */
             SvIsCOW_off(after);
                in the loop.)
                Hence other SV is no longer copy on write either.  */
             SvIsCOW_off(after);

+            sv_buf_to_rw(after);

         } else {
             /* We need to follow the pointers around the loop.  */
             SV *next;
         } else {
             /* We need to follow the pointers around the loop.  */
             SV *next;


@@ -4896,6 +4954,10 @@ the C<flags> parameter gets passed to C<sv_unref_flags()>
 when unreffing.  C<sv_force_normal> calls this function
 with flags set to 0.
 
 when unreffing.  C<sv_force_normal> calls this function
 with flags set to 0.
 

+This function is expected to be used to signal to perl that this SV is
+about to be written to, and any extra book-keeping needs to be taken care
+of.  Hence, it croaks on read-only values.
+

 =cut
 */
 
 =cut
 */
 


@@ -4927,7 +4989,7 @@ S_sv_uncow(pTHX_ SV * const sv, const U32 flags)
 # ifdef PERL_NEW_COPY_ON_WRITE
        if (len && CowREFCNT(sv) == 0)
            /* We own the buffer ourselves. */
 # ifdef PERL_NEW_COPY_ON_WRITE
        if (len && CowREFCNT(sv) == 0)
            /* We own the buffer ourselves. */

-           NOOP;
+           sv_buf_to_rw(sv);

        else
 # endif
        {
        else
 # endif
        {


@@ -4935,7 +4997,11 @@ S_sv_uncow(pTHX_ SV * const sv, const U32 flags)
             /* This SV doesn't own the buffer, so need to Newx() a new one:  */
 # ifdef PERL_NEW_COPY_ON_WRITE
            /* Must do this first, since the macro uses SvPVX. */
             /* This SV doesn't own the buffer, so need to Newx() a new one:  */
 # ifdef PERL_NEW_COPY_ON_WRITE
            /* Must do this first, since the macro uses SvPVX. */

-           if (len) CowREFCNT(sv)--;
+           if (len) {
+               sv_buf_to_rw(sv);
+               CowREFCNT(sv)--;
+               sv_buf_to_ro(sv);
+           }

 # endif
             SvPV_set(sv, NULL);
             SvLEN_set(sv, 0);
 # endif
             SvPV_set(sv, NULL);
             SvLEN_set(sv, 0);


@@ -6416,7 +6482,9 @@ Perl_sv_clear(pTHX_ SV *const orig_sv)
                        sv_release_COW(sv, SvPVX_const(sv), SV_COW_NEXT_SV(sv));
 # else
                        if (CowREFCNT(sv)) {
                        sv_release_COW(sv, SvPVX_const(sv), SV_COW_NEXT_SV(sv));
 # else
                        if (CowREFCNT(sv)) {

+                           sv_buf_to_rw(sv);

                            CowREFCNT(sv)--;
                            CowREFCNT(sv)--;

+                           sv_buf_to_ro(sv);

                            SvLEN_set(sv, 0);
                        }
 # endif
                            SvLEN_set(sv, 0);
                        }
 # endif


@@ -7721,6 +7789,8 @@ Perl_sv_cmp_locale_flags(pTHX_ SV *const sv1, SV *const sv2,
   raw_compare:
     /*FALLTHROUGH*/
 
   raw_compare:
     /*FALLTHROUGH*/
 

+#else
+    PERL_UNUSED_ARG(flags);

 #endif /* USE_LOCALE_COLLATE */
 
     return sv_cmp(sv1, sv2);
 #endif /* USE_LOCALE_COLLATE */
 
     return sv_cmp(sv1, sv2);


@@ -7932,8 +8002,8 @@ S_sv_gets_read_record(pTHX_ SV *const sv, PerlIO *const fp, I32 append)
 =for apidoc sv_gets
 
 Get a line from the filehandle and store it into the SV, optionally
 =for apidoc sv_gets
 
 Get a line from the filehandle and store it into the SV, optionally

-appending to the currently-stored string. If C<append> is not 0, the
-line is appended to the SV instead of overwriting it. C<append> should
+appending to the currently-stored string.  If C<append> is not 0, the
+line is appended to the SV instead of overwriting it.  C<append> should

 be set to the byte offset that the appended string should start at
 in the SV (typically, C<SvCUR(sv)> is a suitable choice).
 
 be set to the byte offset that the appended string should start at
 in the SV (typically, C<SvCUR(sv)> is a suitable choice).
 


@@ -7996,7 +8066,13 @@ Perl_sv_gets(pTHX_ SV *const sv, PerlIO *const fp, I32 append)
        if (!PerlLIO_fstat(PerlIO_fileno(fp), &st) && S_ISREG(st.st_mode))  {
            const Off_t offset = PerlIO_tell(fp);
            if (offset != (Off_t) -1 && st.st_size + append > offset) {
        if (!PerlLIO_fstat(PerlIO_fileno(fp), &st) && S_ISREG(st.st_mode))  {
            const Off_t offset = PerlIO_tell(fp);
            if (offset != (Off_t) -1 && st.st_size + append > offset) {

-               (void) SvGROW(sv, (STRLEN)((st.st_size - offset) + append + 1));
+#ifdef PERL_NEW_COPY_ON_WRITE
+                /* Add an extra byte for the sake of copy-on-write's
+                 * buffer reference count. */
+               (void) SvGROW(sv, (STRLEN)((st.st_size - offset) + append + 2));
+#else
+               (void) SvGROW(sv, (STRLEN)((st.st_size - offset) + append + 1));
+#endif

            }
        }
        rsptr = NULL;
            }
        }
        rsptr = NULL;


@@ -9426,7 +9502,8 @@ Perl_sv_pvn_force_flags(pTHX_ SV *const sv, STRLEN *const lp, const I32 flags)
        if (lp)
            *lp = len;
 
        if (lp)
            *lp = len;
 

-       if (s != SvPVX_const(sv)) {     /* Almost, but not quite, sv_setpvn() */
+        if (SvTYPE(sv) < SVt_PV ||
+            s != SvPVX_const(sv)) {    /* Almost, but not quite, sv_setpvn() */

            if (SvROK(sv))
                sv_unref(sv);
            SvUPGRADE(sv, SVt_PV);              /* Never FALSE */
            if (SvROK(sv))
                sv_unref(sv);
            SvUPGRADE(sv, SVt_PV);              /* Never FALSE */


@@ -9502,6 +9579,14 @@ Perl_sv_reftype(pTHX_ const SV *const sv, const int ob)
        return SvPV_nolen_const(sv_ref(NULL, sv, ob));
     }
     else {
        return SvPV_nolen_const(sv_ref(NULL, sv, ob));
     }
     else {

+        /* WARNING - There is code, for instance in mg.c, that assumes that
+         * the only reason that sv_reftype(sv,0) would return a string starting
+         * with 'L' or 'S' is that it is a LVALUE or a SCALAR.
+         * Yes this a dodgy way to do type checking, but it saves practically reimplementing
+         * this routine inside other subs, and it saves time.
+         * Do not change this assumption without searching for "dodgy type check" in
+         * the code.
+         * - Yves */

        switch (SvTYPE(sv)) {
        case SVt_NULL:
        case SVt_IV:
        switch (SvTYPE(sv)) {
        case SVt_NULL:
        case SVt_IV:


@@ -9626,7 +9711,7 @@ Perl_sv_isa(pTHX_ SV *sv, const char *const name)
 Creates a new SV for the existing RV, C<rv>, to point to.  If C<rv> is not an
 RV then it will be upgraded to one.  If C<classname> is non-null then the new
 SV will be blessed in the specified package.  The new SV is returned and its
 Creates a new SV for the existing RV, C<rv>, to point to.  If C<rv> is not an
 RV then it will be upgraded to one.  If C<classname> is non-null then the new
 SV will be blessed in the specified package.  The new SV is returned and its

-reference count is 1. The reference count 1 is owned by C<rv>.
+reference count is 1.  The reference count 1 is owned by C<rv>.

 
 =cut
 */
 
 =cut
 */


@@ -9866,6 +9951,7 @@ S_sv_unglob(pTHX_ SV *const sv, U32 flags)
     if (!(flags & SV_COW_DROP_PV))
        gv_efullname3(temp, MUTABLE_GV(sv), "*");
 
     if (!(flags & SV_COW_DROP_PV))
        gv_efullname3(temp, MUTABLE_GV(sv), "*");
 

+    SvREFCNT_inc_simple_void_NN(sv_2mortal(sv));

     if (GvGP(sv)) {
         if(GvCVu((const GV *)sv) && (stash = GvSTASH(MUTABLE_GV(sv)))
           && HvNAME_get(stash))
     if (GvGP(sv)) {
         if(GvCVu((const GV *)sv) && (stash = GvSTASH(MUTABLE_GV(sv)))
           && HvNAME_get(stash))


@@ -10154,7 +10240,7 @@ Perl_sv_catpvf_nocontext(SV *const sv, const char *const pat, ...)
     PERL_ARGS_ASSERT_SV_CATPVF_NOCONTEXT;
 
     va_start(args, pat);
     PERL_ARGS_ASSERT_SV_CATPVF_NOCONTEXT;
 
     va_start(args, pat);

-    sv_vcatpvf(sv, pat, &args);
+    sv_vcatpvfn_flags(sv, pat, strlen(pat), &args, NULL, 0, NULL, SV_GMAGIC|SV_SMAGIC);

     va_end(args);
 }
 
     va_end(args);
 }
 


@@ -10172,7 +10258,8 @@ Perl_sv_catpvf_mg_nocontext(SV *const sv, const char *const pat, ...)
     PERL_ARGS_ASSERT_SV_CATPVF_MG_NOCONTEXT;
 
     va_start(args, pat);
     PERL_ARGS_ASSERT_SV_CATPVF_MG_NOCONTEXT;
 
     va_start(args, pat);

-    sv_vcatpvf_mg(sv, pat, &args);
+    sv_vcatpvfn_flags(sv, pat, strlen(pat), &args, NULL, 0, NULL, SV_GMAGIC|SV_SMAGIC);
+    SvSETMAGIC(sv);

     va_end(args);
 }
 #endif
     va_end(args);
 }
 #endif


@@ -10198,7 +10285,7 @@ Perl_sv_catpvf(pTHX_ SV *const sv, const char *const pat, ...)
     PERL_ARGS_ASSERT_SV_CATPVF;
 
     va_start(args, pat);
     PERL_ARGS_ASSERT_SV_CATPVF;
 
     va_start(args, pat);

-    sv_vcatpvf(sv, pat, &args);
+    sv_vcatpvfn_flags(sv, pat, strlen(pat), &args, NULL, 0, NULL, SV_GMAGIC|SV_SMAGIC);

     va_end(args);
 }
 
     va_end(args);
 }
 


@@ -10218,7 +10305,7 @@ Perl_sv_vcatpvf(pTHX_ SV *const sv, const char *const pat, va_list *const args)
 {
     PERL_ARGS_ASSERT_SV_VCATPVF;
 
 {
     PERL_ARGS_ASSERT_SV_VCATPVF;
 

-    sv_vcatpvfn(sv, pat, strlen(pat), args, NULL, 0, NULL);
+    sv_vcatpvfn_flags(sv, pat, strlen(pat), args, NULL, 0, NULL, SV_GMAGIC|SV_SMAGIC);

 }
 
 /*
 }
 
 /*


@@ -10237,7 +10324,8 @@ Perl_sv_catpvf_mg(pTHX_ SV *const sv, const char *const pat, ...)
     PERL_ARGS_ASSERT_SV_CATPVF_MG;
 
     va_start(args, pat);
     PERL_ARGS_ASSERT_SV_CATPVF_MG;
 
     va_start(args, pat);

-    sv_vcatpvf_mg(sv, pat, &args);
+    sv_vcatpvfn_flags(sv, pat, strlen(pat), &args, NULL, 0, NULL, SV_GMAGIC|SV_SMAGIC);
+    SvSETMAGIC(sv);

     va_end(args);
 }
 
     va_end(args);
 }
 


@@ -10404,9 +10492,8 @@ Perl_sv_vcatpvfn_flags(pTHX_ SV *const sv, const char *const pat, const STRLEN p
     char ebuf[IV_DIG * 4 + NV_DIG + 32];
     /* large enough for "%#.#f" --chip */
     /* what about long double NVs? --jhi */
     char ebuf[IV_DIG * 4 + NV_DIG + 32];
     /* large enough for "%#.#f" --chip */
     /* what about long double NVs? --jhi */

-#ifdef USE_LOCALE_NUMERIC
-    SV* oldlocale = NULL;
-#endif
+
+    DECLARATION_FOR_STORE_LC_NUMERIC_SET_TO_NEEDED;

 
     PERL_ARGS_ASSERT_SV_VCATPVFN_FLAGS;
     PERL_UNUSED_ARG(maybe_tainted);
 
     PERL_ARGS_ASSERT_SV_VCATPVFN_FLAGS;
     PERL_UNUSED_ARG(maybe_tainted);


@@ -10459,7 +10546,8 @@ Perl_sv_vcatpvfn_flags(pTHX_ SV *const sv, const char *const pat, const STRLEN p
                   a Configure test for this.  */
                if (digits && digits < sizeof(ebuf) - NV_DIG - 10) {
                     /* 0, point, slack */
                   a Configure test for this.  */
                if (digits && digits < sizeof(ebuf) - NV_DIG - 10) {
                     /* 0, point, slack */

-                   Gconvert(nv, (int)digits, 0, ebuf);
+                    STORE_LC_NUMERIC_SET_TO_NEEDED();
+                   V_Gconvert(nv, (int)digits, 0, ebuf);

                    sv_catpv_nomg(sv, ebuf);
                    if (*ebuf)  /* May return an empty string for digits==0 */
                        return;
                    sv_catpv_nomg(sv, ebuf);
                    if (*ebuf)  /* May return an empty string for digits==0 */
                        return;


@@ -10844,7 +10932,7 @@ Perl_sv_vcatpvfn_flags(pTHX_ SV *const sv, const char *const pat, const STRLEN p
        case 'V':
        case 'z':
        case 't':
        case 'V':
        case 'z':
        case 't':

-#if HAS_C99
+#ifdef HAS_C99

         case 'j':
 #endif
            intsize = *q++;
         case 'j':
 #endif
            intsize = *q++;


@@ -10952,9 +11040,6 @@ Perl_sv_vcatpvfn_flags(pTHX_ SV *const sv, const char *const pat, const STRLEN p
            /*FALLTHROUGH*/
        case 'd':
        case 'i':
            /*FALLTHROUGH*/
        case 'd':
        case 'i':

-#if vdNUMBER
-       format_vd:
-#endif

            if (vectorize) {
                STRLEN ulen;
                if (!veclen)
            if (vectorize) {
                STRLEN ulen;
                if (!veclen)


@@ -10980,7 +11065,7 @@ Perl_sv_vcatpvfn_flags(pTHX_ SV *const sv, const char *const pat, const STRLEN p
                case 'z':       iv = va_arg(*args, SSize_t); break;
                case 't':       iv = va_arg(*args, ptrdiff_t); break;
                default:        iv = va_arg(*args, int); break;
                case 'z':       iv = va_arg(*args, SSize_t); break;
                case 't':       iv = va_arg(*args, ptrdiff_t); break;
                default:        iv = va_arg(*args, int); break;

-#if HAS_C99
+#ifdef HAS_C99

                case 'j':       iv = va_arg(*args, intmax_t); break;
 #endif
                case 'q':
                case 'j':       iv = va_arg(*args, intmax_t); break;
 #endif
                case 'q':


@@ -11077,7 +11162,7 @@ Perl_sv_vcatpvfn_flags(pTHX_ SV *const sv, const char *const pat, const STRLEN p
                case 'V':  uv = va_arg(*args, UV); break;
                case 'z':  uv = va_arg(*args, Size_t); break;
                case 't':  uv = va_arg(*args, ptrdiff_t); break; /* will sign extend, but there is no uptrdiff_t, so oh well */
                case 'V':  uv = va_arg(*args, UV); break;
                case 'z':  uv = va_arg(*args, Size_t); break;
                case 't':  uv = va_arg(*args, ptrdiff_t); break; /* will sign extend, but there is no uptrdiff_t, so oh well */

-#if HAS_C99
+#ifdef HAS_C99

                case 'j':  uv = va_arg(*args, uintmax_t); break;
 #endif
                default:   uv = va_arg(*args, unsigned); break;
                case 'j':  uv = va_arg(*args, uintmax_t); break;
 #endif
                default:   uv = va_arg(*args, unsigned); break;


@@ -11319,7 +11404,8 @@ Perl_sv_vcatpvfn_flags(pTHX_ SV *const sv, const char *const pat, const STRLEN p
                /* See earlier comment about buggy Gconvert when digits,
                   aka precis is 0  */
                if ( c == 'g' && precis) {
                /* See earlier comment about buggy Gconvert when digits,
                   aka precis is 0  */
                if ( c == 'g' && precis) {

-                   Gconvert((NV)nv, (int)precis, 0, PL_efloatbuf);
+                    STORE_LC_NUMERIC_SET_TO_NEEDED();
+                   V_Gconvert((NV)nv, (int)precis, 0, PL_efloatbuf);

                    /* May return an empty string for digits==0 */
                    if (*PL_efloatbuf) {
                        elen = strlen(PL_efloatbuf);
                    /* May return an empty string for digits==0 */
                    if (*PL_efloatbuf) {
                        elen = strlen(PL_efloatbuf);


@@ -11368,20 +11454,11 @@ Perl_sv_vcatpvfn_flags(pTHX_ SV *const sv, const char *const pat, const STRLEN p
                 * where printf() taints but print($float) doesn't.
                 * --jhi */
 
                 * where printf() taints but print($float) doesn't.
                 * --jhi */
 

-#ifdef USE_LOCALE_NUMERIC
-                if (! PL_numeric_standard && ! IN_SOME_LOCALE_FORM) {
-
-                    /* We use a mortal SV, so that any failures (such as if
-                     * warnings are made fatal) won't leak */
-                    char *oldlocale_string = setlocale(LC_NUMERIC, NULL);
-                    oldlocale = newSVpvn_flags(oldlocale_string,
-                                               strlen(oldlocale_string),
-                                               SVs_TEMP);
-                    PL_numeric_standard = TRUE;
-                    setlocale(LC_NUMERIC, "C");
-                }
-#endif
+                STORE_LC_NUMERIC_SET_TO_NEEDED();

 
 

+                /* hopefully the above makes ptr a very constrained format
+                 * that is safe to use, even though it's not literal */
+                GCC_DIAG_IGNORE(-Wformat-nonliteral);

 #if defined(HAS_LONG_DOUBLE)
                elen = ((intsize == 'q')
                        ? my_snprintf(PL_efloatbuf, PL_efloatsize, ptr, nv)
 #if defined(HAS_LONG_DOUBLE)
                elen = ((intsize == 'q')
                        ? my_snprintf(PL_efloatbuf, PL_efloatsize, ptr, nv)


@@ -11389,11 +11466,14 @@ Perl_sv_vcatpvfn_flags(pTHX_ SV *const sv, const char *const pat, const STRLEN p
 #else
                elen = my_sprintf(PL_efloatbuf, ptr, nv);
 #endif
 #else
                elen = my_sprintf(PL_efloatbuf, ptr, nv);
 #endif

+                GCC_DIAG_RESTORE;

            }
        float_converted:
            eptr = PL_efloatbuf;
 
 #ifdef USE_LOCALE_NUMERIC
            }
        float_converted:
            eptr = PL_efloatbuf;
 
 #ifdef USE_LOCALE_NUMERIC

+            /* If the decimal point character in the string is UTF-8, make the
+             * output utf8 */

             if (PL_numeric_radix_sv && SvUTF8(PL_numeric_radix_sv)
                 && instr(eptr, SvPVX_const(PL_numeric_radix_sv)))
             {
             if (PL_numeric_radix_sv && SvUTF8(PL_numeric_radix_sv)
                 && instr(eptr, SvPVX_const(PL_numeric_radix_sv)))
             {


@@ -11418,7 +11498,7 @@ Perl_sv_vcatpvfn_flags(pTHX_ SV *const sv, const char *const pat, const STRLEN p
                case 'V':       *(va_arg(*args, IV*)) = i; break;
                case 'z':       *(va_arg(*args, SSize_t*)) = i; break;
                case 't':       *(va_arg(*args, ptrdiff_t*)) = i; break;
                case 'V':       *(va_arg(*args, IV*)) = i; break;
                case 'z':       *(va_arg(*args, SSize_t*)) = i; break;
                case 't':       *(va_arg(*args, ptrdiff_t*)) = i; break;

-#if HAS_C99
+#ifdef HAS_C99

                case 'j':       *(va_arg(*args, intmax_t*)) = i; break;
 #endif
                case 'q':
                case 'j':       *(va_arg(*args, intmax_t*)) = i; break;
 #endif
                case 'q':


@@ -11558,13 +11638,8 @@ Perl_sv_vcatpvfn_flags(pTHX_ SV *const sv, const char *const pat, const STRLEN p
     }
     SvTAINT(sv);
 
     }
     SvTAINT(sv);
 

-#ifdef USE_LOCALE_NUMERIC   /* Done outside loop, so don't have to save/restore
+    RESTORE_LC_NUMERIC();   /* Done outside loop, so don't have to save/restore

                                each iteration. */
                                each iteration. */

-    if (oldlocale) {
-        setlocale(LC_NUMERIC, SvPVX(oldlocale));
-        PL_numeric_standard = FALSE;
-    }
-#endif

 }
 
 /* =========================================================================
 }
 
 /* =========================================================================


@@ -11760,7 +11835,8 @@ Perl_dirp_dup(pTHX_ DIR *const dp, CLONE_PARAMS *const param)
 {
     DIR *ret;
 
 {
     DIR *ret;
 

-#ifdef HAS_FCHDIR
+#if defined(HAS_FCHDIR) && defined(HAS_TELLDIR) && defined(HAS_SEEKDIR)
+    int rc = 0;

     DIR *pwd;
     const Direntry_t *dirent;
     char smallbuf[256];
     DIR *pwd;
     const Direntry_t *dirent;
     char smallbuf[256];


@@ -11780,7 +11856,7 @@ Perl_dirp_dup(pTHX_ DIR *const dp, CLONE_PARAMS *const param)
     if (ret)
        return ret;
 
     if (ret)
        return ret;
 

-#ifdef HAS_FCHDIR
+#if defined(HAS_FCHDIR) && defined(HAS_TELLDIR) && defined(HAS_SEEKDIR)

 
     PERL_UNUSED_ARG(param);
 
 
     PERL_UNUSED_ARG(param);
 


@@ -11797,7 +11873,9 @@ Perl_dirp_dup(pTHX_ DIR *const dp, CLONE_PARAMS *const param)
     /* 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. */
     /* 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? */
+    rc = fchdir(my_dirfd(pwd));
+    /* XXX If this fails, then what? */
+    PERL_UNUSED_VAR(rc);

 
     /* We have no need of the pwd handle any more. */
     PerlDir_close(pwd);
 
     /* We have no need of the pwd handle any more. */
     PerlDir_close(pwd);


@@ -12023,7 +12101,9 @@ Perl_ptr_table_fetch(pTHX_ PTR_TBL_t *const tbl, const void *const sv)
     return tblent ? tblent->newval : NULL;
 }
 
     return tblent ? tblent->newval : NULL;
 }
 

-/* add a new entry to a pointer-mapping table */
+/* add a new entry to a pointer-mapping table 'tbl'.  In hash terms, 'oldsv' is
+ * the key; 'newsv' is the value.  The names "old" and "new" are specific to
+ * the core's typical use of ptr_tables in thread cloning. */

 
 void
 Perl_ptr_table_store(pTHX_ PTR_TBL_t *const tbl, const void *const oldsv, void *const newsv)
 
 void
 Perl_ptr_table_store(pTHX_ PTR_TBL_t *const tbl, const void *const oldsv, void *const newsv)


@@ -12536,6 +12616,11 @@ S_sv_dup_common(pTHX_ const SV *const sstr, CLONE_PARAMS *const param)
                        daux->xhv_name_count = saux->xhv_name_count;
 
                        daux->xhv_fill_lazy = saux->xhv_fill_lazy;
                        daux->xhv_name_count = saux->xhv_name_count;
 
                        daux->xhv_fill_lazy = saux->xhv_fill_lazy;

+                       daux->xhv_aux_flags = saux->xhv_aux_flags;
+#ifdef PERL_HASH_RANDOMIZE_KEYS
+                       daux->xhv_rand = saux->xhv_rand;
+                       daux->xhv_last_rand = saux->xhv_last_rand;
+#endif

                        daux->xhv_riter = saux->xhv_riter;
                        daux->xhv_eiter = saux->xhv_eiter
                            ? he_dup(saux->xhv_eiter,
                        daux->xhv_riter = saux->xhv_riter;
                        daux->xhv_eiter = saux->xhv_eiter
                            ? he_dup(saux->xhv_eiter,


@@ -13298,7 +13383,7 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags,
     PL_origargc                = proto_perl->Iorigargc;
     PL_origargv                = proto_perl->Iorigargv;
 
     PL_origargc                = proto_perl->Iorigargc;
     PL_origargv                = proto_perl->Iorigargv;
 

-#if !NO_TAINT_SUPPORT
+#ifndef NO_TAINT_SUPPORT

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


@@ -13406,6 +13491,7 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags,
 
     /* Did the locale setup indicate UTF-8? */
     PL_utf8locale      = proto_perl->Iutf8locale;
 
     /* Did the locale setup indicate UTF-8? */
     PL_utf8locale      = proto_perl->Iutf8locale;

+    PL_in_utf8_CTYPE_locale = proto_perl->Iin_utf8_CTYPE_locale;

     /* Unicode features (see perlrun/-C) */
     PL_unicode         = proto_perl->Iunicode;
 
     /* Unicode features (see perlrun/-C) */
     PL_unicode         = proto_perl->Iunicode;
 


@@ -13474,11 +13560,7 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags,
     PL_statbuf         = proto_perl->Istatbuf;
     PL_statcache       = proto_perl->Istatcache;
 
     PL_statbuf         = proto_perl->Istatbuf;
     PL_statcache       = proto_perl->Istatcache;
 

-#ifdef HAS_TIMES
-    PL_timesbuf                = proto_perl->Itimesbuf;
-#endif
-
-#if !NO_TAINT_SUPPORT
+#ifndef NO_TAINT_SUPPORT

     PL_tainted         = proto_perl->Itainted;
 #else
     PL_tainted          = FALSE;
     PL_tainted         = proto_perl->Itainted;
 #else
     PL_tainted          = FALSE;


@@ -13566,7 +13648,7 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags,
 #endif
 
     PL_envgv           = gv_dup_inc(proto_perl->Ienvgv, param);
 #endif
 
     PL_envgv           = gv_dup_inc(proto_perl->Ienvgv, param);

-    PL_incgv           = gv_dup(proto_perl->Iincgv, param);
+    PL_incgv           = gv_dup_inc(proto_perl->Iincgv, param);

     PL_hintgv          = gv_dup_inc(proto_perl->Ihintgv, param);
     PL_origfilename    = SAVEPV(proto_perl->Iorigfilename);
     PL_diehook         = sv_dup_inc(proto_perl->Idiehook, param);
     PL_hintgv          = gv_dup_inc(proto_perl->Ihintgv, param);
     PL_origfilename    = SAVEPV(proto_perl->Iorigfilename);
     PL_diehook         = sv_dup_inc(proto_perl->Idiehook, param);


@@ -13614,7 +13696,7 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags,
     PL_argvout_stack   = av_dup_inc(proto_perl->Iargvout_stack, param);
 
     /* shortcuts to regexp stuff */
     PL_argvout_stack   = av_dup_inc(proto_perl->Iargvout_stack, param);
 
     /* shortcuts to regexp stuff */

-    PL_replgv          = gv_dup(proto_perl->Ireplgv, param);
+    PL_replgv          = gv_dup_inc(proto_perl->Ireplgv, param);

 
     /* shortcuts to misc objects */
     PL_errgv           = gv_dup(proto_perl->Ierrgv, param);
 
     /* shortcuts to misc objects */
     PL_errgv           = gv_dup(proto_perl->Ierrgv, param);


@@ -13736,15 +13818,13 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags,
     PL_AboveLatin1     = sv_dup_inc(proto_perl->IAboveLatin1, param);
 
     PL_NonL1NonFinalFold = sv_dup_inc(proto_perl->INonL1NonFinalFold, param);
     PL_AboveLatin1     = sv_dup_inc(proto_perl->IAboveLatin1, param);
 
     PL_NonL1NonFinalFold = sv_dup_inc(proto_perl->INonL1NonFinalFold, param);

-    PL_HasMultiCharFold= sv_dup_inc(proto_perl->IHasMultiCharFold, param);
+    PL_HasMultiCharFold = sv_dup_inc(proto_perl->IHasMultiCharFold, param);

 
     /* utf8 character class swashes */
     for (i = 0; i < POSIX_SWASH_COUNT; i++) {
         PL_utf8_swash_ptrs[i] = sv_dup_inc(proto_perl->Iutf8_swash_ptrs[i], param);
     }
     for (i = 0; i < POSIX_CC_COUNT; i++) {
 
     /* utf8 character class swashes */
     for (i = 0; i < POSIX_SWASH_COUNT; i++) {
         PL_utf8_swash_ptrs[i] = sv_dup_inc(proto_perl->Iutf8_swash_ptrs[i], param);
     }
     for (i = 0; i < POSIX_CC_COUNT; i++) {

-        PL_Posix_ptrs[i] = sv_dup_inc(proto_perl->IPosix_ptrs[i], param);
-        PL_L1Posix_ptrs[i] = sv_dup_inc(proto_perl->IL1Posix_ptrs[i], param);

         PL_XPosix_ptrs[i] = sv_dup_inc(proto_perl->IXPosix_ptrs[i], param);
     }
     PL_utf8_mark       = sv_dup_inc(proto_perl->Iutf8_mark, param);
         PL_XPosix_ptrs[i] = sv_dup_inc(proto_perl->IXPosix_ptrs[i], param);
     }
     PL_utf8_mark       = sv_dup_inc(proto_perl->Iutf8_mark, param);


@@ -13867,7 +13947,7 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags,
     /* 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.
     */

-    while(av_len(param->stashes) != -1) {
+    while(av_tindex(param->stashes) != -1) {

        HV* const stash = MUTABLE_HV(av_shift(param->stashes));
        GV* const cloner = gv_fetchmethod_autoload(stash, "CLONE", 0);
        if (cloner && GvCV(cloner)) {
        HV* const stash = MUTABLE_HV(av_shift(param->stashes));
        GV* const cloner = gv_fetchmethod_autoload(stash, "CLONE", 0);
        if (cloner && GvCV(cloner)) {


@@ -14070,13 +14150,19 @@ Perl_sv_recode_to_utf8(pTHX_ SV *sv, SV *encoding)
        STRLEN len;
        const char *s;
        dSP;
        STRLEN len;
        const char *s;
        dSP;

+       SV *nsv = sv;

        ENTER;
        ENTER;

+       PUSHSTACK;

        SAVETMPS;
        SAVETMPS;

+       if (SvPADTMP(nsv)) {
+           nsv = sv_newmortal();
+           SvSetSV_nosteal(nsv, sv);
+       }

        save_re_context();
        PUSHMARK(sp);
        EXTEND(SP, 3);
        PUSHs(encoding);
        save_re_context();
        PUSHMARK(sp);
        EXTEND(SP, 3);
        PUSHs(encoding);

-       PUSHs(sv);
+       PUSHs(nsv);

 /*
   NI-S 2002/07/09
   Passing sv_yes is wrong - it needs to be or'ed set of constants
 /*
   NI-S 2002/07/09
   Passing sv_yes is wrong - it needs to be or'ed set of constants


@@ -14099,6 +14185,7 @@ Perl_sv_recode_to_utf8(pTHX_ SV *sv, SV *encoding)
            SvCUR_set(sv, len);
        }
        FREETMPS;
            SvCUR_set(sv, len);
        }
        FREETMPS;

+       POPSTACK;

        LEAVE;
        if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
            /* clear pos and any utf8 cache */
        LEAVE;
        if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
            /* clear pos and any utf8 cache */


@@ -14431,12 +14518,12 @@ S_find_uninit_var(pTHX_ const OP *const obase, const SV *const uninit_sv,
            AV *av = MUTABLE_AV(PAD_SV(obase->op_targ));
            if (!av || SvRMAGICAL(av))
                break;
            AV *av = MUTABLE_AV(PAD_SV(obase->op_targ));
            if (!av || SvRMAGICAL(av))
                break;

-           svp = av_fetch(av, (I32)obase->op_private, FALSE);
+           svp = av_fetch(av, (I8)obase->op_private, FALSE);

            if (!svp || *svp != uninit_sv)
                break;
        }
        return varname(NULL, '$', obase->op_targ,
            if (!svp || *svp != uninit_sv)
                break;
        }
        return varname(NULL, '$', obase->op_targ,

-                      NULL, (I32)obase->op_private, FUV_SUBSCRIPT_ARRAY);
+                      NULL, (I8)obase->op_private, FUV_SUBSCRIPT_ARRAY);

     case OP_AELEMFAST:
        {
            gv = cGVOPx_gv(obase);
     case OP_AELEMFAST:
        {
            gv = cGVOPx_gv(obase);


@@ -14447,12 +14534,12 @@ S_find_uninit_var(pTHX_ const OP *const obase, const SV *const uninit_sv,
                AV *const av = GvAV(gv);
                if (!av || SvRMAGICAL(av))
                    break;
                AV *const av = GvAV(gv);
                if (!av || SvRMAGICAL(av))
                    break;

-               svp = av_fetch(av, (I32)obase->op_private, FALSE);
+               svp = av_fetch(av, (I8)obase->op_private, FALSE);

                if (!svp || *svp != uninit_sv)
                    break;
            }
            return varname(gv, '$', 0,
                if (!svp || *svp != uninit_sv)
                    break;
            }
            return varname(gv, '$', 0,

-                   NULL, (I32)obase->op_private, FUV_SUBSCRIPT_ARRAY);
+                   NULL, (I8)obase->op_private, FUV_SUBSCRIPT_ARRAY);

        }
        break;
 
        }
        break;
 


@@ -14797,14 +14884,21 @@ Perl_report_uninit(pTHX_ const SV *uninit_sv)
            if (varname)
                sv_insert(varname, 0, 0, " ", 1);
        }
            if (varname)
                sv_insert(varname, 0, 0, " ", 1);
        }

+        /* PL_warn_uninit_sv is constant */
+        GCC_DIAG_IGNORE(-Wformat-nonliteral);

        /* diag_listed_as: Use of uninitialized value%s */
        Perl_warner(aTHX_ packWARN(WARN_UNINITIALIZED), PL_warn_uninit_sv,
                SVfARG(varname ? varname : &PL_sv_no),
                " in ", OP_DESC(PL_op));
        /* diag_listed_as: Use of uninitialized value%s */
        Perl_warner(aTHX_ packWARN(WARN_UNINITIALIZED), PL_warn_uninit_sv,
                SVfARG(varname ? varname : &PL_sv_no),
                " in ", OP_DESC(PL_op));

+        GCC_DIAG_RESTORE;

     }
     }

-    else
+    else {
+        /* PL_warn_uninit is constant */
+        GCC_DIAG_IGNORE(-Wformat-nonliteral);

        Perl_warner(aTHX_ packWARN(WARN_UNINITIALIZED), PL_warn_uninit,
                    "", "", "");
        Perl_warner(aTHX_ packWARN(WARN_UNINITIALIZED), PL_warn_uninit,
                    "", "", "");

+        GCC_DIAG_RESTORE;
+    }

 }
 
 /*
 }
 
 /*