Put back the #8840, it was innocent.
[p5sagit/p5-mst-13.2.git] / sv.c
diff --git a/sv.c b/sv.c
index 54eb419..e9dda52 100644 (file)
--- a/sv.c
+++ b/sv.c
@@ -2448,6 +2448,9 @@ Perl_looks_like_number(pTHX_ SV *sv)
     I32 numtype = 0;
     I32 sawinf  = 0;
     STRLEN len;
+#ifdef USE_LOCALE_NUMERIC
+    bool specialradix = FALSE;
+#endif
 
     if (SvPOK(sv)) {
        sbegin = SvPVX(sv);
@@ -2514,10 +2517,15 @@ Perl_looks_like_number(pTHX_ SV *sv)
 
         if (*s == '.'
 #ifdef USE_LOCALE_NUMERIC
-           || IS_NUMERIC_RADIX(*s)
+           || (specialradix = IS_NUMERIC_RADIX(s))
 #endif
            ) {
-           s++;
+#ifdef USE_LOCALE_NUMERIC
+           if (specialradix)
+               s += SvCUR(PL_numeric_radix);
+           else
+#endif
+               s++;
            numtype |= IS_NUMBER_NOT_INT;
             while (isDIGIT(*s))  /* optional digits after the radix */
                 s++;
@@ -2525,10 +2533,15 @@ Perl_looks_like_number(pTHX_ SV *sv)
     }
     else if (*s == '.'
 #ifdef USE_LOCALE_NUMERIC
-           || IS_NUMERIC_RADIX(*s)
+           || (specialradix = IS_NUMERIC_RADIX(s))
 #endif
            ) {
-        s++;
+#ifdef USE_LOCALE_NUMERIC
+       if (specialradix)
+           s += SvCUR(PL_numeric_radix);
+       else
+#endif
+           s++;
        numtype |= IS_NUMBER_TO_INT_BY_ATOL | IS_NUMBER_NOT_INT;
         /* no digits before the radix means we need digits after it */
         if (isDIGIT(*s)) {
@@ -2957,6 +2970,7 @@ Perl_sv_utf8_upgrade(pTHX_ register SV *sv)
 
     if (hibit) {
        STRLEN len;
+
        if (SvREADONLY(sv) && SvFAKE(sv)) {
            sv_force_normal(sv);
            s = SvPVX(sv);
@@ -2987,10 +3001,13 @@ Perl_sv_utf8_downgrade(pTHX_ register SV* sv, bool fail_ok)
 {
     if (SvPOK(sv) && SvUTF8(sv)) {
         if (SvCUR(sv)) {
-           char *c = SvPVX(sv);
-           STRLEN len = SvCUR(sv);
+           char *s;
+           STRLEN len;
 
-           if (!utf8_to_bytes((U8*)c, &len)) {
+           if (SvREADONLY(sv) && SvFAKE(sv))
+               sv_force_normal(sv);
+           s = SvPV(sv, len);
+           if (!utf8_to_bytes((U8*)s, &len)) {
                if (fail_ok)
                    return FALSE;
                else {
@@ -3031,7 +3048,7 @@ Perl_sv_utf8_decode(pTHX_ register SV *sv)
     if (SvPOK(sv)) {
         char *c;
         char *e;
-        bool has_utf = FALSE;
+
         if (!sv_utf8_downgrade(sv, TRUE))
            return FALSE;
 
@@ -3201,6 +3218,13 @@ Perl_sv_setsv(pTHX_ SV *dstr, register SV *sstr)
                     && GvCV(dstr) && PL_sortcop == CvSTART(GvCV(dstr)))
                Perl_croak(aTHX_ "Can't redefine active sort subroutine %s",
                      GvNAME(dstr));
+
+#ifdef GV_SHARED_CHECK
+                if (GvSHARED((GV*)dstr)) {
+                    Perl_croak(aTHX_ PL_no_modify);
+                }
+#endif
+
            (void)SvOK_off(dstr);
            GvINTRO_off(dstr);          /* one-shot flag */
            gp_free((GV*)dstr);
@@ -3241,6 +3265,12 @@ Perl_sv_setsv(pTHX_ SV *dstr, register SV *sstr)
                SV *dref = 0;
                int intro = GvINTRO(dstr);
 
+#ifdef GV_SHARED_CHECK
+                if (GvSHARED((GV*)dstr)) {
+                    Perl_croak(aTHX_ PL_no_modify);
+                }
+#endif
+
                if (intro) {
                    GP *gp;
                    gp_free((GV*)dstr);
@@ -3295,7 +3325,6 @@ Perl_sv_setsv(pTHX_ SV *dstr, register SV *sstr)
                            if (!GvCVGEN((GV*)dstr) &&
                                (CvROOT(cv) || CvXSUB(cv)))
                            {
-                               SV *const_sv;
                                /* ahem, death to those who redefine
                                 * active sort subs */
                                if (PL_curstackinfo->si_type == PERLSI_SORT &&
@@ -3462,8 +3491,8 @@ Perl_sv_setsv(pTHX_ SV *dstr, register SV *sstr)
        if (sflags & SVf_IOK)
            (void)SvIOK_only(dstr);
        else {
-           SvOK_off(dstr);
-           SvIOKp_on(dstr);
+           (void)SvOK_off(dstr);
+           (void)SvIOKp_on(dstr);
        }
        /* XXXX Do we want to set IsUV for IV(ROK)?  Be extra safe... */
        if (sflags & SVf_IVisUV)
@@ -3481,7 +3510,7 @@ Perl_sv_setsv(pTHX_ SV *dstr, register SV *sstr)
        if (sflags & SVf_NOK)
            (void)SvNOK_only(dstr);
        else {
-           SvOK_off(dstr);
+           (void)SvOK_off(dstr);
            SvNOKp_on(dstr);
        }
        SvNVX(dstr) = SvNVX(sstr);
@@ -3526,16 +3555,17 @@ void
 Perl_sv_setpvn(pTHX_ register SV *sv, register const char *ptr, register STRLEN len)
 {
     register char *dptr;
-    {
-        /* len is STRLEN which is unsigned, need to copy to signed */
-       IV iv = len;
-       assert(iv >= 0);
-    }
+
     SV_CHECK_THINKFIRST(sv);
     if (!ptr) {
        (void)SvOK_off(sv);
        return;
     }
+    else {
+        /* len is STRLEN which is unsigned, need to copy to signed */
+       IV iv = len;
+       assert(iv >= 0);
+    }
     (void)SvUPGRADE(sv, SVt_PV);
 
     SvGROW(sv, len + 1);
@@ -3926,11 +3956,12 @@ Perl_sv_magic(pTHX_ register SV *sv, SV *obj, int how, const char *name, I32 nam
     }
     mg->mg_type = how;
     mg->mg_len = namlen;
-    if (name)
+    if (name) {
        if (namlen >= 0)
            mg->mg_ptr = savepvn(name, namlen);
        else if (namlen == HEf_SVKEY)
            mg->mg_ptr = (char*)SvREFCNT_inc((SV*)name);
+    }
 
     switch (how) {
     case 0:
@@ -4072,11 +4103,12 @@ Perl_sv_unmagic(pTHX_ SV *sv, int type)
            *mgp = mg->mg_moremagic;
            if (vtbl && vtbl->svt_free)
                CALL_FPTR(vtbl->svt_free)(aTHX_ sv, mg);
-           if (mg->mg_ptr && mg->mg_type != 'g')
+           if (mg->mg_ptr && mg->mg_type != 'g') {
                if (mg->mg_len >= 0)
                    Safefree(mg->mg_ptr);
                else if (mg->mg_len == HEf_SVKEY)
                    SvREFCNT_dec((SV*)mg->mg_ptr);
+            }
            if (mg->mg_flags & MGf_REFCOUNTED)
                SvREFCNT_dec(mg->mg_obj);
            Safefree(mg);
@@ -4685,30 +4717,22 @@ Perl_sv_eq(pTHX_ register SV *sv1, register SV *sv2)
 
     /* do not utf8ize the comparands as a side-effect */
     if (cur1 && cur2 && SvUTF8(sv1) != SvUTF8(sv2) && !IN_BYTE) {
+       bool is_utf8 = TRUE;
+
        if (PL_hints & HINT_UTF8_DISTINCT)
            return FALSE;
 
        if (SvUTF8(sv1)) {
-           (void)utf8_to_bytes((U8*)(pv1 = savepvn(pv1, cur1)), &cur1);
-           {
-               IV scur1 = cur1;
-               if (scur1 < 0) {
-                   Safefree(pv1);
-                   return 0;
-               }
-           }
-           pv1tmp = TRUE;
+           char *pv = (char*)bytes_from_utf8((U8*)pv1, &cur1, &is_utf8);
+
+           if ((pv1tmp = (pv != pv1)))
+               pv1 = pv;
        }
        else {
-           (void)utf8_to_bytes((U8*)(pv2 = savepvn(pv2, cur2)), &cur2);
-           {
-               IV scur2 = cur2;
-               if (scur2 < 0) {
-                   Safefree(pv2);
-                   return 0;
-               }
-           }
-           pv2tmp = TRUE;
+           char *pv = (char *)bytes_from_utf8((U8*)pv2, &cur2, &is_utf8);
+
+           if ((pv2tmp = (pv != pv2)))
+               pv2 = pv;
        }
     }
 
@@ -5596,6 +5620,12 @@ Perl_newSVpvn_share(pTHX_ const char *src, I32 len, U32 hash)
         len = -len;
         is_utf8 = TRUE;
     }
+    if (is_utf8 && !(PL_hints & HINT_UTF8_DISTINCT)) {
+       STRLEN tmplen = len;
+       /* See the note in hv.c:hv_fetch() --jhi */
+       src = (char*)bytes_from_utf8((U8*)src, &tmplen, &is_utf8);
+       len = tmplen;
+    }
     if (!hash)
        PERL_HASH(hash, src, len);
     new_SV(sv);
@@ -6323,6 +6353,25 @@ Perl_sv_setref_iv(pTHX_ SV *rv, const char *classname, IV iv)
 }
 
 /*
+=for apidoc sv_setref_uv
+
+Copies an unsigned integer into a new SV, optionally blessing the SV.  The C<rv>
+argument will be upgraded to an RV.  That RV will be modified to point to
+the new SV.  The C<classname> argument indicates the package for the
+blessing.  Set C<classname> to C<Nullch> to avoid the blessing.  The new SV
+will be returned and will have a reference count of 1.
+
+=cut
+*/
+
+SV*
+Perl_sv_setref_uv(pTHX_ SV *rv, const char *classname, UV uv)
+{
+    sv_setuv(newSVrv(rv,classname), uv);
+    return rv;
+}
+
+/*
 =for apidoc sv_setref_nv
 
 Copies a double into a new SV, optionally blessing the SV.  The C<rv>
@@ -6704,6 +6753,21 @@ Perl_sv_vsetpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV
     sv_vcatpvfn(sv, pat, patlen, args, svargs, svmax, maybe_tainted);
 }
 
+STATIC I32
+S_expect_number(pTHX_ char** pattern)
+{
+    I32 var = 0;
+    switch (**pattern) {
+    case '1': case '2': case '3':
+    case '4': case '5': case '6':
+    case '7': case '8': case '9':
+       while (isDIGIT(**pattern))
+           var = var * 10 + (*(*pattern)++ - '0');
+    }
+    return var;
+}
+#define EXPECT_NUMBER(pattern, var) (var = S_expect_number(aTHX_ &pattern))
+
 /*
 =for apidoc sv_vcatpvfn
 
@@ -6764,7 +6828,8 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV
        bool alt = FALSE;
        bool left = FALSE;
        bool vectorize = FALSE;
-       bool utf = FALSE;
+       bool vectorarg = FALSE;
+       bool vec_utf = FALSE;
        char fill = ' ';
        char plus = 0;
        char intsize = 0;
@@ -6801,10 +6866,13 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV
        STRLEN gap;
        char *dotstr = ".";
        STRLEN dotstrlen = 1;
-       I32 epix = 0; /* explicit parameter index */
+       I32 efix = 0; /* explicit format parameter index */
        I32 ewix = 0; /* explicit width index */
+       I32 epix = 0; /* explicit precision index */
+       I32 evix = 0; /* explicit vector index */
        bool asterisk = FALSE;
 
+       /* echo everything up to the next format specification */
        for (q = p; q < patend && *q != '%'; ++q) ;
        if (q > p) {
            sv_catpvn(sv, p, q - p);
@@ -6813,6 +6881,25 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV
        if (q++ >= patend)
            break;
 
+/*
+    We allow format specification elements in this order:
+       \d+\$              explicit format parameter index
+       [-+ 0#]+           flags
+       \*?(\d+\$)?v       vector with optional (optionally specified) arg
+       \d+|\*(\d+\$)?     width using optional (optionally specified) arg
+       \.(\d*|\*(\d+\$)?) precision using optional (optionally specified) arg
+       [hlqLV]            size
+    [%bcdefginopsux_DFOUX] format (mandatory)
+*/
+       if (EXPECT_NUMBER(q, width)) {
+           if (*q == '$') {
+               ++q;
+               efix = width;
+           } else {
+               goto gotwidth;
+           }
+       }
+
        /* FLAGS */
 
        while (*q) {
@@ -6836,63 +6923,60 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV
                q++;
                continue;
 
-           case '*':                   /* printf("%*vX",":",$ipv6addr) */
-               if (q[1] != 'v')
-                   break;
-               q++;
-               if (args)
-                   vecsv = va_arg(*args, SV*);
-               else if (svix < svmax)
-                   vecsv = svargs[svix++];
-               else
-                   continue;
-               dotstr = SvPVx(vecsv,dotstrlen);
-               if (DO_UTF8(vecsv))
-                   is_utf = TRUE;
-               /* FALL THROUGH */
-
-           case 'v':
-               vectorize = TRUE;
-               q++;
-               continue;
-
            default:
                break;
            }
            break;
        }
 
-       /* WIDTH */
-
-    scanwidth:
-
+      tryasterisk:
        if (*q == '*') {
-           if (asterisk)
-               goto unknown;
+           q++;
+           if (EXPECT_NUMBER(q, ewix))
+               if (*q++ != '$')
+                   goto unknown;
            asterisk = TRUE;
+       }
+       if (*q == 'v') {
            q++;
+           if (vectorize)
+               goto unknown;
+           if ((vectorarg = asterisk)) {
+               evix = ewix;
+               ewix = 0;
+               asterisk = FALSE;
+           }
+           vectorize = TRUE;
+           goto tryasterisk;
        }
 
-       switch (*q) {
-       case '1': case '2': case '3':
-       case '4': case '5': case '6':
-       case '7': case '8': case '9':
-           width = 0;
-           while (isDIGIT(*q))
-               width = width * 10 + (*q++ - '0');
-           if (*q == '$') {
-               if (asterisk && ewix == 0) {
-                   ewix  = width;
-                   width = 0;
-                   q++;
-                   goto scanwidth;
-               } else if (epix == 0) {
-                   epix  = width;
-                   width = 0;
-                   q++;
-                   goto scanwidth;
-               } else
-                   goto unknown;
+       if (!asterisk)
+           EXPECT_NUMBER(q, width);
+
+       if (vectorize) {
+           if (vectorarg) {
+               if (args)
+                   vecsv = va_arg(*args, SV*);
+               else
+                   vecsv = (evix ? evix <= svmax : svix < svmax) ?
+                       svargs[ewix ? ewix-1 : svix++] : &PL_sv_undef;
+               dotstr = SvPVx(vecsv, dotstrlen);
+               if (DO_UTF8(vecsv))
+                   is_utf = TRUE;
+           }
+           if (args) {
+               vecsv = va_arg(*args, SV*);
+               vecstr = (U8*)SvPVx(vecsv,veclen);
+               vec_utf = DO_UTF8(vecsv);
+           }
+           else if (efix ? efix <= svmax : svix < svmax) {
+               vecsv = svargs[efix ? efix-1 : svix++];
+               vecstr = (U8*)SvPVx(vecsv,veclen);
+               vec_utf = DO_UTF8(vecsv);
+           }
+           else {
+               vecstr = (U8*)"";
+               veclen = 0;
            }
        }
 
@@ -6905,19 +6989,22 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV
            left |= (i < 0);
            width = (i < 0) ? -i : i;
        }
+      gotwidth:
 
        /* PRECISION */
 
        if (*q == '.') {
            q++;
            if (*q == '*') {
+               q++;
+               if (EXPECT_NUMBER(q, epix) && *q++ != '$')
+                   goto unknown;
                if (args)
                    i = va_arg(*args, int);
                else
                    i = (ewix ? ewix <= svmax : svix < svmax)
                        ? SvIVx(svargs[ewix ? ewix-1 : svix++]) : 0;
                precis = (i < 0) ? 0 : i;
-               q++;
            }
            else {
                precis = 0;
@@ -6927,23 +7014,6 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV
            has_precis = TRUE;
        }
 
-       if (vectorize) {
-           if (args) {
-               vecsv = va_arg(*args, SV*);
-               vecstr = (U8*)SvPVx(vecsv,veclen);
-               utf = DO_UTF8(vecsv);
-           }
-           else if (epix ? epix <= svmax : svix < svmax) {
-               vecsv = svargs[epix ? epix-1 : svix++];
-               vecstr = (U8*)SvPVx(vecsv,veclen);
-               utf = DO_UTF8(vecsv);
-           }
-           else {
-               vecstr = (U8*)"";
-               veclen = 0;
-           }
-       }
-
        /* SIZE */
 
        switch (*q) {
@@ -6975,21 +7045,22 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV
 
        /* CONVERSION */
 
+       if (*q == '%') {
+           eptr = q++;
+           elen = 1;
+           goto string;
+       }
+
+       if (!args)
+           argsv = (efix ? efix <= svmax : svix < svmax) ?
+                   svargs[efix ? efix-1 : svix++] : &PL_sv_undef;
+
        switch (c = *q++) {
 
            /* STRINGS */
 
-       case '%':
-           eptr = q - 1;
-           elen = 1;
-           goto string;
-
        case 'c':
-           if (args)
-               uv = va_arg(*args, int);
-           else
-               uv = (epix ? epix <= svmax : svix < svmax) ?
-                   SvIVx(svargs[epix ? epix-1 : svix++]) : 0;
+           uv = args ? va_arg(*args, int) : SvIVx(argsv);
            if ((uv > 255 || (uv > 127 && SvUTF8(sv))) && !IN_BYTE) {
                eptr = (char*)utf8buf;
                elen = uv_to_utf8((U8*)eptr, uv) - utf8buf;
@@ -7018,8 +7089,7 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV
                    elen = sizeof nullstr - 1;
                }
            }
-           else if (epix ? epix <= svmax : svix < svmax) {
-               argsv = svargs[epix ? epix-1 : svix++];
+           else {
                eptr = SvPVx(argsv, elen);
                if (DO_UTF8(argsv)) {
                    if (has_precis && precis < elen) {
@@ -7043,7 +7113,7 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV
             */
            if (!args)
                goto unknown;
-           argsv = va_arg(*args,SV*);
+           argsv = va_arg(*args, SV*);
            eptr = SvPVx(argsv, elen);
            if (DO_UTF8(argsv))
                is_utf = TRUE;
@@ -7059,11 +7129,7 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV
        case 'p':
            if (alt)
                goto unknown;
-           if (args)
-               uv = PTR2UV(va_arg(*args, void*));
-           else
-               uv = (epix ? epix <= svmax : svix < svmax) ?
-                   PTR2UV(svargs[epix ? epix-1 : svix++]) : 0;
+           uv = PTR2UV(args ? va_arg(*args, void*) : argsv);
            base = 16;
            goto integer;
 
@@ -7078,11 +7144,9 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV
        case 'i':
            if (vectorize) {
                STRLEN ulen;
-               if (!veclen) {
-                   vectorize = FALSE;
-                   break;
-               }
-               if (utf)
+               if (!veclen)
+                   continue;
+               if (vec_utf)
                    iv = (IV)utf8_to_uv(vecstr, veclen, &ulen, 0);
                else {
                    iv = *vecstr;
@@ -7103,8 +7167,7 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV
                }
            }
            else {
-               iv = (epix ? epix <= svmax : svix < svmax) ?
-                   SvIVx(svargs[epix ? epix-1 : svix++]) : 0;
+               iv = SvIVx(argsv);
                switch (intsize) {
                case 'h':       iv = (short)iv; break;
                default:        break;
@@ -7161,11 +7224,9 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV
            if (vectorize) {
                STRLEN ulen;
        vector:
-               if (!veclen) {
-                   vectorize = FALSE;
-                   break;
-               }
-               if (utf)
+               if (!veclen)
+                   continue;
+               if (vec_utf)
                    uv = utf8_to_uv(vecstr, veclen, &ulen, 0);
                else {
                    uv = *vecstr;
@@ -7186,8 +7247,7 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV
                }
            }
            else {
-               uv = (epix ? epix <= svmax : svix < svmax) ?
-                   SvUVx(svargs[epix ? epix-1 : svix++]) : 0;
+               uv = SvUVx(argsv);
                switch (intsize) {
                case 'h':       uv = (unsigned short)uv; break;
                default:        break;
@@ -7276,11 +7336,7 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV
            /* This is evil, but floating point is even more evil */
 
            vectorize = FALSE;
-           if (args)
-               nv = va_arg(*args, NV);
-           else
-               nv = (epix ? epix <= svmax : svix < svmax) ?
-                   SvNVx(svargs[epix ? epix-1 : svix++]) : 0.0;
+           nv = args ? va_arg(*args, NV) : SvNVx(argsv);
 
            need = 0;
            if (c != 'e' && c != 'E') {
@@ -7360,8 +7416,8 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV
 #endif
                }
            }
-           else if (epix ? epix <= svmax : svix < svmax)
-               sv_setuv_mg(svargs[epix ? epix-1 : svix++], (UV)i);
+           else
+               sv_setuv_mg(argsv, (UV)i);
            continue;   /* not "break" */
 
            /* UNKNOWN */
@@ -7396,7 +7452,7 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV
            /* ... right here, because formatting flags should not apply */
            SvGROW(sv, SvCUR(sv) + elen + 1);
            p = SvEND(sv);
-           memcpy(p, eptr, elen);
+           Copy(eptr, p, elen, char);
            p += elen;
            *p = '\0';
            SvCUR(sv) = p - SvPVX(sv);
@@ -7426,7 +7482,7 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV
                *p++ = '0';
        }
        if (elen) {
-           memcpy(p, eptr, elen);
+           Copy(eptr, p, elen, char);
            p += elen;
        }
        if (gap && left) {
@@ -7435,7 +7491,7 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV
        }
        if (vectorize) {
            if (veclen) {
-               memcpy(p, dotstr, dotstrlen);
+               Copy(dotstr, p, dotstrlen, char);
                p += dotstrlen;
            }
            else
@@ -7679,10 +7735,110 @@ Perl_ptr_table_split(pTHX_ PTR_TBL_t *tbl)
     }
 }
 
+void
+Perl_ptr_table_clear(pTHX_ PTR_TBL_t *tbl)
+{
+    register PTR_TBL_ENT_t **array;
+    register PTR_TBL_ENT_t *entry;
+    register PTR_TBL_ENT_t *oentry = Null(PTR_TBL_ENT_t*);
+    UV riter = 0;
+    UV max;
+
+    if (!tbl || !tbl->tbl_items) {
+        return;
+    }
+
+    array = tbl->tbl_ary;
+    entry = array[0];
+    max = tbl->tbl_max;
+
+    for (;;) {
+        if (entry) {
+            oentry = entry;
+            entry = entry->next;
+            Safefree(oentry);
+        }
+        if (!entry) {
+            if (++riter > max) {
+                break;
+            }
+            entry = array[riter];
+        }
+    }
+
+    tbl->tbl_items = 0;
+}
+
+void
+Perl_ptr_table_free(pTHX_ PTR_TBL_t *tbl)
+{
+    if (!tbl) {
+        return;
+    }
+    ptr_table_clear(tbl);
+    Safefree(tbl->tbl_ary);
+    Safefree(tbl);
+}
+
 #ifdef DEBUGGING
 char *PL_watch_pvx;
 #endif
 
+STATIC SV *
+S_gv_share(pTHX_ SV *sstr)
+{
+    GV *gv = (GV*)sstr;
+    SV *sv = &PL_sv_no; /* just need SvREADONLY-ness */
+
+    if (GvIO(gv) || GvFORM(gv)) {
+        GvSHARED_off(gv); /* GvIOs cannot be shared. nor can GvFORMs */
+    }
+    else if (!GvCV(gv)) {
+        GvCV(gv) = (CV*)sv;
+    }
+    else {
+        /* CvPADLISTs cannot be shared */
+        if (!CvXSUB(GvCV(gv))) {
+            GvSHARED_off(gv);
+        }
+    }
+
+    if (!GvSHARED(gv)) {
+#if 0
+        PerlIO_printf(Perl_debug_log, "gv_share: unable to share %s::%s\n",
+                      HvNAME(GvSTASH(gv)), GvNAME(gv));
+#endif
+        return Nullsv;
+    }
+
+    /* 
+     * write attempts will die with
+     * "Modification of a read-only value attempted"
+     */
+    if (!GvSV(gv)) {
+        GvSV(gv) = sv;
+    }
+    else {
+        SvREADONLY_on(GvSV(gv));
+    }
+
+    if (!GvAV(gv)) {
+        GvAV(gv) = (AV*)sv;
+    }
+    else {
+        SvREADONLY_on(GvAV(gv));
+    }
+
+    if (!GvHV(gv)) {
+        GvHV(gv) = (HV*)sv;
+    }
+    else {
+        SvREADONLY_on(GvAV(gv));
+    }
+
+    return sstr; /* he_dup() will SvREFCNT_inc() */
+}
+
 SV *
 Perl_sv_dup(pTHX_ SV *sstr)
 {
@@ -7815,6 +7971,18 @@ Perl_sv_dup(pTHX_ SV *sstr)
        LvTYPE(dstr)    = LvTYPE(sstr);
        break;
     case SVt_PVGV:
+       if (GvSHARED((GV*)sstr)) {
+            SV *share;
+            if ((share = gv_share(sstr))) {
+                del_SV(dstr);
+                dstr = share;
+#if 0
+                PerlIO_printf(Perl_debug_log, "sv_dup: sharing %s::%s\n",
+                              HvNAME(GvSTASH(share)), GvNAME(share));
+#endif
+                break;
+            }
+       }
        SvANY(dstr)     = new_XPVGV();
        SvCUR(dstr)     = SvCUR(sstr);
        SvLEN(dstr)     = SvLEN(sstr);
@@ -8440,6 +8608,7 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags,
     PL_scopestack = 0;
     PL_savestack = 0;
     PL_retstack = 0;
+    PL_sig_pending = 0;
 #    else      /* !DEBUGGING */
     Zero(my_perl, 1, PerlInterpreter);
 #    endif     /* DEBUGGING */
@@ -8466,6 +8635,7 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags,
     PL_scopestack = 0;
     PL_savestack = 0;
     PL_retstack = 0;
+    PL_sig_pending = 0;
 #    else      /* !DEBUGGING */
     Zero(my_perl, 1, PerlInterpreter);
 #    endif     /* DEBUGGING */
@@ -8823,7 +8993,7 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags,
     PL_numeric_name    = SAVEPV(proto_perl->Inumeric_name);
     PL_numeric_standard        = proto_perl->Inumeric_standard;
     PL_numeric_local   = proto_perl->Inumeric_local;
-    PL_numeric_radix   = proto_perl->Inumeric_radix;
+    PL_numeric_radix   = sv_dup_inc(proto_perl->Inumeric_radix);
 #endif /* !USE_LOCALE_NUMERIC */
 
     /* utf8 character classes */
@@ -8865,25 +9035,29 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags,
     PL_uudmap['M']     = 0;            /* reinits on demand */
     PL_bitcount                = Nullch;       /* reinits on demand */
 
+    if (proto_perl->Ipsig_pend) {
+       Newz(0, PL_psig_pend, SIG_SIZE, int);
+    }
+    else {
+       PL_psig_pend    = (int*)NULL;
+    }
+
     if (proto_perl->Ipsig_ptr) {
-       int sig_num[] = { SIG_NUM };
-       Newz(0, PL_psig_ptr, sizeof(sig_num)/sizeof(*sig_num), SV*);
-       Newz(0, PL_psig_name, sizeof(sig_num)/sizeof(*sig_num), SV*);
-       Newz(0, PL_psig_pend, sizeof(sig_num)/sizeof(*sig_num), int*);
-       for (i = 1; PL_sig_name[i]; i++) {
-           PL_psig_ptr[i] = sv_dup_inc(proto_perl->Ipsig_ptr[i]);
+       Newz(0, PL_psig_ptr,  SIG_SIZE, SV*);
+       Newz(0, PL_psig_name, SIG_SIZE, SV*);
+       for (i = 1; i < SIG_SIZE; i++) {
+           PL_psig_ptr[i]  = sv_dup_inc(proto_perl->Ipsig_ptr[i]);
            PL_psig_name[i] = sv_dup_inc(proto_perl->Ipsig_name[i]);
        }
     }
     else {
        PL_psig_ptr     = (SV**)NULL;
        PL_psig_name    = (SV**)NULL;
-       PL_psig_pend    = (int*)NULL;
     }
 
     /* thrdvar.h stuff */
 
-    if (flags & 1) {
+    if (flags & CLONEf_COPY_STACKS) {
        /* next allocation will be PL_tmps_stack[PL_tmps_ix+1] */
        PL_tmps_ix              = proto_perl->Ttmps_ix;
        PL_tmps_max             = proto_perl->Ttmps_max;
@@ -9069,6 +9243,11 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags,
     PL_reginterp_cnt   = 0;
     PL_reg_starttry    = 0;
 
+    if (!(flags & CLONEf_KEEP_PTR_TABLE)) {
+        ptr_table_free(PL_ptr_table);
+        PL_ptr_table = NULL;
+    }
+
 #ifdef PERL_OBJECT
     return (PerlInterpreter*)pPerl;
 #else