Split out the use of SVp_SCREAM for GVs with GPs into a new symbolic
[p5sagit/p5-mst-13.2.git] / sv.c
diff --git a/sv.c b/sv.c
index f5d9cb6..7e327d4 100644 (file)
--- a/sv.c
+++ b/sv.c
@@ -904,6 +904,9 @@ static const struct body_details bodies_by_type[] = {
     /* RVs are in the head now.  */
     { 0, 0, 0, SVt_RV, FALSE, NONV, NOARENA, 0 },
 
+    /* The bind placeholder pretends to be an RV for now.  */
+    { 0, 0, 0, SVt_BIND, FALSE, NONV, NOARENA, 0 },
+
     /* 8 bytes on most ILP32 with IEEE doubles */
     { sizeof(xpv_allocated),
       copy_length(XPV, xpv_len)
@@ -926,10 +929,6 @@ static const struct body_details bodies_by_type[] = {
     { sizeof(XPVMG), copy_length(XPVMG, xmg_stash), 0, SVt_PVMG, FALSE, HADNV,
       HASARENA, FIT_ARENA(0, sizeof(XPVMG)) },
     
-    /* 36 */
-    { sizeof(XPVBM), sizeof(XPVBM), 0, SVt_PVBM, TRUE, HADNV,
-      HASARENA, FIT_ARENA(0, sizeof(XPVBM)) },
-
     /* 48 */
     { sizeof(XPVGV), sizeof(XPVGV), 0, SVt_PVGV, TRUE, HADNV,
       HASARENA, FIT_ARENA(0, sizeof(XPVGV)) },
@@ -1277,13 +1276,11 @@ Perl_sv_upgrade(pTHX_ register SV *sv, svtype new_type)
            assert(SvPVX_const(sv) == 0);
        }
 
-       /* Could put this in the else clause below, as PVMG must have SvPVX
-          0 already (the assertion above)  */
-       SvPV_set(sv, NULL);
-
        if (old_type >= SVt_PVMG) {
            SvMAGIC_set(sv, ((XPVMG*)old_body)->xmg_u.xmg_magic);
            SvSTASH_set(sv, ((XPVMG*)old_body)->xmg_stash);
+       } else {
+           sv->sv_u.svu_array = NULL; /* or svu_hash  */
        }
        break;
 
@@ -1295,7 +1292,6 @@ Perl_sv_upgrade(pTHX_ register SV *sv, svtype new_type)
        assert(!SvNOK(sv));
     case SVt_PVIO:
     case SVt_PVFM:
-    case SVt_PVBM:
     case SVt_PVGV:
     case SVt_PVCV:
     case SVt_PVLV:
@@ -1560,8 +1556,6 @@ Like C<sv_setuv>, but also handles 'set' magic.
 void
 Perl_sv_setuv_mg(pTHX_ register SV *sv, UV u)
 {
-    sv_setiv(sv, 0);
-    SvIsUV_on(sv);
     sv_setuv(sv,u);
     SvSETMAGIC(sv);
 }
@@ -2163,7 +2157,11 @@ Perl_sv_2iv_flags(pTHX_ register SV *sv, I32 flags)
     dVAR;
     if (!sv)
        return 0;
-    if (SvGMAGICAL(sv)) {
+    if (SvGMAGICAL(sv) || (SvTYPE(sv) == SVt_PVGV && SvVALID(sv))) {
+       /* FBMs use the same flag bit as SVf_IVisUV, so must let them
+          cache IVs just in case. In practice it seems that they never
+          actually anywhere accessible by user Perl code, let alone get used
+          in anything other than a string context.  */
        if (flags & SV_GMAGIC)
            mg_get(sv);
        if (SvIOKp(sv))
@@ -2243,7 +2241,9 @@ Perl_sv_2uv_flags(pTHX_ register SV *sv, I32 flags)
     dVAR;
     if (!sv)
        return 0;
-    if (SvGMAGICAL(sv)) {
+    if (SvGMAGICAL(sv) || (SvTYPE(sv) == SVt_PVGV && SvVALID(sv))) {
+       /* FBMs use the same flag bit as SVf_IVisUV, so must let them
+          cache IVs just in case.  */
        if (flags & SV_GMAGIC)
            mg_get(sv);
        if (SvIOKp(sv))
@@ -2318,7 +2318,9 @@ Perl_sv_2nv(pTHX_ register SV *sv)
     dVAR;
     if (!sv)
        return 0.0;
-    if (SvGMAGICAL(sv)) {
+    if (SvGMAGICAL(sv) || (SvTYPE(sv) == SVt_PVGV && SvVALID(sv))) {
+       /* FBMs use the same flag bit as SVf_IVisUV, so must let them
+          cache IVs just in case.  */
        mg_get(sv);
        if (SvNOKp(sv))
            return SvNVX(sv);
@@ -2544,87 +2546,6 @@ S_uiv_2buf(char *buf, IV iv, UV uv, int is_uv, char **peob)
     return ptr;
 }
 
-/* stringify_regexp(): private routine for use by sv_2pv_flags(): converts
- * a regexp to its stringified form.
- */
-
-static char *
-S_stringify_regexp(pTHX_ SV *sv, MAGIC *mg, STRLEN *lp) {
-    dVAR;
-    const regexp * const re = (regexp *)mg->mg_obj;
-
-    if (!mg->mg_ptr) {
-       const char *fptr = "msix";
-       char reflags[6];
-       char ch;
-       int left = 0;
-       int right = 4;
-       bool need_newline = 0;
-       U16 reganch = (U16)((re->reganch & PMf_COMPILETIME) >> 12);
-
-       while((ch = *fptr++)) {
-           if(reganch & 1) {
-               reflags[left++] = ch;
-           }
-           else {
-               reflags[right--] = ch;
-           }
-           reganch >>= 1;
-       }
-       if(left != 4) {
-           reflags[left] = '-';
-           left = 5;
-       }
-
-       mg->mg_len = re->prelen + 4 + left;
-       /*
-        * If /x was used, we have to worry about a regex ending with a
-        * comment later being embedded within another regex. If so, we don't
-        * want this regex's "commentization" to leak out to the right part of
-        * the enclosing regex, we must cap it with a newline.
-        *
-        * So, if /x was used, we scan backwards from the end of the regex. If
-        * we find a '#' before we find a newline, we need to add a newline
-        * ourself. If we find a '\n' first (or if we don't find '#' or '\n'),
-        * we don't need to add anything.  -jfriedl
-        */
-       if (PMf_EXTENDED & re->reganch) {
-           const char *endptr = re->precomp + re->prelen;
-           while (endptr >= re->precomp) {
-               const char c = *(endptr--);
-               if (c == '\n')
-                   break; /* don't need another */
-               if (c == '#') {
-                   /* we end while in a comment, so we need a newline */
-                   mg->mg_len++; /* save space for it */
-                   need_newline = 1; /* note to add it */
-                   break;
-               }
-           }
-       }
-
-       Newx(mg->mg_ptr, mg->mg_len + 1 + left, char);
-       mg->mg_ptr[0] = '(';
-       mg->mg_ptr[1] = '?';
-       Copy(reflags, mg->mg_ptr+2, left, char);
-       *(mg->mg_ptr+left+2) = ':';
-       Copy(re->precomp, mg->mg_ptr+3+left, re->prelen, char);
-       if (need_newline)
-           mg->mg_ptr[mg->mg_len - 2] = '\n';
-       mg->mg_ptr[mg->mg_len - 1] = ')';
-       mg->mg_ptr[mg->mg_len] = 0;
-    }
-    PL_reginterp_cnt += re->program[0].next_off;
-    
-    if (re->reganch & ROPT_UTF8)
-       SvUTF8_on(sv);
-    else
-       SvUTF8_off(sv);
-    if (lp)
-       *lp = mg->mg_len;
-    return mg->mg_ptr;
-}
-
 /*
 =for apidoc sv_2pv_flags
 
@@ -2742,8 +2663,18 @@ Perl_sv_2pv_flags(pTHX_ register SV *sv, STRLEN *lp, I32 flags)
                           && ((SvFLAGS(referent) &
                                (SVs_OBJECT|SVf_OK|SVs_GMG|SVs_SMG|SVs_RMG))
                               == (SVs_OBJECT|SVs_SMG))
-                          && (mg = mg_find(referent, PERL_MAGIC_qr))) {
-                   return stringify_regexp(sv, mg, lp);
+                          && (mg = mg_find(referent, PERL_MAGIC_qr)))
+                {
+                    char *str = NULL;
+                    I32 haseval = 0;
+                    U32 flags = 0;
+                    (str) = CALLREG_AS_STR(mg,lp,&flags,&haseval);
+                    if (flags & 1)
+                       SvUTF8_on(sv);
+                    else
+                       SvUTF8_off(sv);
+                    PL_reginterp_cnt += haseval;
+                   return str;
                } else {
                    const char *const typestr = sv_reftype(referent, 0);
                    const STRLEN typelen = strlen(typestr);
@@ -2819,7 +2750,6 @@ Perl_sv_2pv_flags(pTHX_ register SV *sv, STRLEN *lp, I32 flags)
     if (SvIOK(sv) || ((SvIOKp(sv) && !SvNOKp(sv)))) {
        /* I'm assuming that if both IV and NV are equally valid then
           converting the IV is going to be more efficient */
-       const U32 isIOK = SvIOK(sv);
        const U32 isUIOK = SvIsUV(sv);
        char buf[TYPE_CHARS(UV)];
        char *ebuf, *ptr;
@@ -2833,12 +2763,6 @@ Perl_sv_2pv_flags(pTHX_ register SV *sv, STRLEN *lp, I32 flags)
        SvCUR_set(sv, ebuf - ptr);
        s = SvEND(sv);
        *s = '\0';
-       if (isIOK)
-           SvIOK_on(sv);
-       else
-           SvIOKp_on(sv);
-       if (isUIOK)
-           SvIsUV_on(sv);
     }
     else if (SvNOKp(sv)) {
        const int olderrno = errno;
@@ -3253,7 +3177,9 @@ S_glob_assign_glob(pTHX_ SV *dstr, SV *sstr, const int dtype)
            }
            sv_upgrade(dstr, SVt_PVGV);
            (void)SvOK_off(dstr);
-           SvSCREAM_on(dstr);
+           /* FIXME - why are we doing this, then turning it off and on again
+              below?  */
+           isGV_with_GP_on(dstr);
        }
        GvSTASH(dstr) = GvSTASH(sstr);
        if (GvSTASH(dstr))
@@ -3269,9 +3195,9 @@ S_glob_assign_glob(pTHX_ SV *dstr, SV *sstr, const int dtype)
 #endif
 
     gp_free((GV*)dstr);
-    SvSCREAM_off(dstr);
+    isGV_with_GP_off(dstr);
     (void)SvOK_off(dstr);
-    SvSCREAM_on(dstr);
+    isGV_with_GP_on(dstr);
     GvINTRO_off(dstr);         /* one-shot flag */
     GvGP(dstr) = gp_ref(GvGP(sstr));
     if (SvTAINTED(sstr))
@@ -3450,6 +3376,8 @@ Perl_sv_setsv_flags(pTHX_ SV *dstr, register SV *sstr, I32 flags)
            case SVt_PV:
                sv_upgrade(dstr, SVt_PVIV);
                break;
+           case SVt_PVGV:
+               goto end_of_first_switch;
            }
            (void)SvIOK_only(dstr);
            SvIV_set(dstr,  SvIVX(sstr));
@@ -3476,6 +3404,8 @@ Perl_sv_setsv_flags(pTHX_ SV *dstr, register SV *sstr, I32 flags)
            case SVt_PVIV:
                sv_upgrade(dstr, SVt_PVNV);
                break;
+           case SVt_PVGV:
+               goto end_of_first_switch;
            }
            SvNV_set(dstr, SvNVX(sstr));
            (void)SvNOK_only(dstr);
@@ -3523,21 +3453,22 @@ Perl_sv_setsv_flags(pTHX_ SV *dstr, register SV *sstr, I32 flags)
        }
        break;
 
+       /* case SVt_BIND: */
     case SVt_PVGV:
-       if (dtype <= 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.  */
        /*FALLTHROUGH*/
 
     case SVt_PVMG:
     case SVt_PVLV:
-    case SVt_PVBM:
        if (SvGMAGICAL(sstr) && (flags & SV_GMAGIC)) {
            mg_get(sstr);
            if (SvTYPE(sstr) != stype) {
                stype = SvTYPE(sstr);
-               if (stype == SVt_PVGV && dtype <= SVt_PVGV) {
+               if (isGV_with_GP(sstr) && stype == SVt_PVGV && dtype <= SVt_PVGV) {
                    glob_assign_glob(dstr, sstr, dtype);
                    return;
                }
@@ -3548,14 +3479,28 @@ Perl_sv_setsv_flags(pTHX_ SV *dstr, register SV *sstr, I32 flags)
        else
            SvUPGRADE(dstr, (svtype)stype);
     }
+ end_of_first_switch:
 
     /* dstr may have been upgraded.  */
     dtype = SvTYPE(dstr);
     sflags = SvFLAGS(sstr);
 
-    if (sflags & SVf_ROK) {
-       if (dtype == SVt_PVGV &&
-           SvROK(sstr) && SvTYPE(SvRV(sstr)) == SVt_PVGV) {
+    if (dtype == SVt_PVCV) {
+       /* Assigning to a subroutine sets the prototype.  */
+       if (SvOK(sstr)) {
+           STRLEN len;
+           const char *const ptr = SvPV_const(sstr, len);
+
+            SvGROW(dstr, len + 1);
+            Copy(ptr, SvPVX(dstr), len + 1, char);
+            SvCUR_set(dstr, len);
+           SvPOK_only(dstr);
+       } else {
+           SvOK_off(dstr);
+       }
+    } else if (sflags & SVf_ROK) {
+       if (isGV_with_GP(dstr) && dtype == SVt_PVGV
+           && SvTYPE(SvRV(sstr)) == SVt_PVGV) {
            sstr = SvRV(sstr);
            if (sstr == dstr) {
                if (GvIMPORTED(dstr) != GVf_IMPORTED
@@ -3583,13 +3528,13 @@ Perl_sv_setsv_flags(pTHX_ SV *dstr, register SV *sstr, I32 flags)
        }
        (void)SvOK_off(dstr);
        SvRV_set(dstr, SvREFCNT_inc(SvRV(sstr)));
-       SvFLAGS(dstr) |= sflags & (SVf_ROK|SVf_AMAGIC);
+       SvFLAGS(dstr) |= sflags & SVf_ROK;
        assert(!(sflags & SVp_NOK));
        assert(!(sflags & SVp_IOK));
        assert(!(sflags & SVf_NOK));
        assert(!(sflags & SVf_IOK));
     }
-    else if (dtype == SVt_PVGV) {
+    else if (dtype == SVt_PVGV && isGV_with_GP(dstr)) {
        if (!(sflags & SVf_OK)) {
            if (ckWARN(WARN_MISC))
                Perl_warner(aTHX_ packWARN(WARN_MISC),
@@ -3612,6 +3557,9 @@ Perl_sv_setsv_flags(pTHX_ SV *dstr, register SV *sstr, I32 flags)
         * 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.
         */
 
        /* Whichever path we take through the next code, we want this true,
@@ -3619,10 +3567,28 @@ Perl_sv_setsv_flags(pTHX_ SV *dstr, register SV *sstr, I32 flags)
        (void)SvPOK_only(dstr);
 
        if (
-           /* We're not already COW  */
-            ((sflags & (SVf_FAKE | SVf_READONLY)) != (SVf_FAKE | SVf_READONLY)
+           /* 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_FAKE|SVf_READONLY)) != (SVf_FAKE|SVf_READONLY)
+              : 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_OLD_COPY_ON_WRITE
-            /* or we are, but dstr isn't a suitable target.  */
+            /* 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) & CAN_COW_MASK) != CAN_COW_FLAGS
 #endif
             )
@@ -3736,8 +3702,7 @@ Perl_sv_setsv_flags(pTHX_ SV *dstr, register SV *sstr, I32 flags)
            if (sflags & SVf_IVisUV)
                SvIsUV_on(dstr);
        }
-       SvFLAGS(dstr) |= sflags & (SVf_IOK|SVp_IOK|SVf_NOK|SVp_NOK|SVf_UTF8
-                                  |SVf_AMAGIC);
+       SvFLAGS(dstr) |= sflags & (SVf_IOK|SVp_IOK|SVf_NOK|SVp_NOK|SVf_UTF8);
        {
            const MAGIC * const smg = SvVSTRING_mg(sstr);
            if (smg) {
@@ -3749,8 +3714,7 @@ Perl_sv_setsv_flags(pTHX_ SV *dstr, register SV *sstr, I32 flags)
     }
     else if (sflags & (SVp_IOK|SVp_NOK)) {
        (void)SvOK_off(dstr);
-       SvFLAGS(dstr) |= sflags & (SVf_IOK|SVp_IOK|SVf_IVisUV|SVf_NOK|SVp_NOK
-                                  |SVf_AMAGIC);
+       SvFLAGS(dstr) |= sflags & (SVf_IOK|SVp_IOK|SVf_IVisUV|SVf_NOK|SVp_NOK);
        if (sflags & SVp_IOK) {
            /* XXXX Do we want to set IsUV for IV(ROK)?  Be extra safe... */
            SvIV_set(dstr, SvIVX(sstr));
@@ -3770,7 +3734,6 @@ Perl_sv_setsv_flags(pTHX_ SV *dstr, register SV *sstr, I32 flags)
            SvFAKE_off(sstr);
            gv_efullname3(dstr, (GV *)sstr, "*");
            SvFLAGS(sstr) |= wasfake;
-           SvFLAGS(dstr) |= sflags & SVf_AMAGIC;
        }
        else
            (void)SvOK_off(dstr);
@@ -5145,7 +5108,7 @@ Perl_sv_clear(pTHX_ register SV *sv)
        }
     }
     if (type >= SVt_PVMG) {
-       if ((type == SVt_PVMG || type == SVt_PVGV) && SvPAD_OUR(sv)) {
+       if (type == SVt_PVMG && SvPAD_OUR(sv)) {
            SvREFCNT_dec(OURSTASH(sv));
        } else if (SvMAGIC(sv))
            mg_free(sv);
@@ -5153,6 +5116,7 @@ Perl_sv_clear(pTHX_ register SV *sv)
            SvREFCNT_dec(SvSTASH(sv));
     }
     switch (type) {
+       /* case SVt_BIND: */
     case SVt_PVIO:
        if (IoIFP(sv) &&
            IoIFP(sv) != PerlIO_stdin() &&
@@ -5168,8 +5132,6 @@ Perl_sv_clear(pTHX_ register SV *sv)
        Safefree(IoFMT_NAME(sv));
        Safefree(IoBOTTOM_NAME(sv));
        goto freescalar;
-    case SVt_PVBM:
-       goto freescalar;
     case SVt_PVCV:
     case SVt_PVFM:
        cv_undef((CV*)sv);
@@ -5191,14 +5153,15 @@ Perl_sv_clear(pTHX_ register SV *sv)
            SvREFCNT_dec(LvTARG(sv));
        goto freescalar;
     case SVt_PVGV:
-       gp_free((GV*)sv);
-       if (GvNAME_HEK(sv)) {
-           unshare_hek(GvNAME_HEK(sv));
-       }
+       if (isGV_with_GP(sv)) {
+           gp_free((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 (GvSTASH(sv))
-           sv_del_backref((SV*)GvSTASH(sv), sv);
+       if (!SvVALID(sv) && GvSTASH(sv))
+               sv_del_backref((SV*)GvSTASH(sv), sv);
+       }
     case SVt_PVMG:
     case SVt_PVNV:
     case SVt_PVIV:
@@ -5687,18 +5650,7 @@ S_utf8_mg_pos_cache_update(pTHX_ SV *sv, MAGIC **mgp, STRLEN byte, STRLEN utf8,
 
     if (PL_utf8cache < 0) {
        const U8 *start = (const U8 *) SvPVX_const(sv);
-       const U8 *const end = start + byte;
-       STRLEN realutf8 = 0;
-
-       while (start < end) {
-           start += UTF8SKIP(start);
-           realutf8++;
-       }
-
-       /* Can't use S_sv_pos_b2u_forwards as it will scream warnings on
-          surrogates.  FIXME - is it inconsistent that b2u warns, but u2b
-          doesn't?  I don't know whether this difference was introduced with
-          the caching code in 5.8.1.  */
+       const STRLEN realutf8 = utf8_length(start, start + byte);
 
        if (realutf8 != utf8) {
            /* Need to turn the assertions off otherwise we may recurse
@@ -5809,29 +5761,6 @@ S_utf8_mg_pos_cache_update(pTHX_ SV *sv, MAGIC **mgp, STRLEN byte, STRLEN utf8,
     ASSERT_UTF8_CACHE(cache);
 }
 
-/* If we don't know the character offset of the end of a region, our only
-   option is to walk forwards to the target byte offset.  */
-static STRLEN
-S_sv_pos_b2u_forwards(pTHX_ const U8 *s, const U8 *const target)
-{
-    STRLEN len = 0;
-    while (s < target) {
-       STRLEN n = 1;
-
-       /* Call utf8n_to_uvchr() to validate the sequence
-        * (unless a simple non-UTF character) */
-       if (!UTF8_IS_INVARIANT(*s))
-           utf8n_to_uvchr(s, UTF8SKIP(s), &n, 0);
-       if (n > 0) {
-           s += n;
-           len++;
-       }
-       else
-           break;
-    }
-    return len;
-}
-
 /* We already know all of the way, now we may be able to walk back.  The same
    assumption is made as in S_sv_pos_u2b_midway(), namely that walking
    backward is half the speed of walking forward. */
@@ -5843,7 +5772,7 @@ S_sv_pos_b2u_midway(pTHX_ const U8 *s, const U8 *const target, const U8 *end,
     STRLEN backw = end - target;
 
     if (forw < 2 * backw) {
-       return S_sv_pos_b2u_forwards(aTHX_ s, target);
+       return utf8_length(s, target);
     }
 
     while (end > target) {
@@ -5916,8 +5845,7 @@ Perl_sv_pos_b2u(pTHX_ register SV* sv, I32* offsetp)
                        + S_sv_pos_b2u_midway(aTHX_ s + cache[1], send,
                                              s + blen, mg->mg_len - cache[0]);
                } else {
-                   len = cache[0]
-                       + S_sv_pos_b2u_forwards(aTHX_ s + cache[1], send);
+                   len = cache[0] + utf8_length(s + cache[1], send);
                }
            }
            else if (cache[3] < byte) {
@@ -5943,7 +5871,7 @@ Perl_sv_pos_b2u(pTHX_ register SV* sv, I32* offsetp)
        }
     }
     if (!found || PL_utf8cache < 0) {
-       const STRLEN real_len = S_sv_pos_b2u_forwards(aTHX_ s, send);
+       const STRLEN real_len = utf8_length(s, send);
 
        if (found && PL_utf8cache < 0) {
            if (len != real_len) {
@@ -7710,7 +7638,6 @@ Perl_sv_reftype(pTHX_ const SV *sv, int ob)
        case SVt_PVIV:
        case SVt_PVNV:
        case SVt_PVMG:
-       case SVt_PVBM:
                                if (SvVOK(sv))
                                    return "VSTRING";
                                if (SvROK(sv))
@@ -7729,6 +7656,7 @@ Perl_sv_reftype(pTHX_ const SV *sv, int ob)
        case SVt_PVGV:          return "GLOB";
        case SVt_PVFM:          return "FORMAT";
        case SVt_PVIO:          return "IO";
+       case SVt_BIND:          return "BIND";
        default:                return "UNKNOWN";
        }
     }
@@ -8020,7 +7948,7 @@ S_sv_unglob(pTHX_ SV *sv)
     if (GvNAME_HEK(sv)) {
        unshare_hek(GvNAME_HEK(sv));
     }
-    SvSCREAM_off(sv);
+    isGV_with_GP_off(sv);
 
     /* need to keep SvANY(sv) in the right arena */
     xpvmg = new_XPVMG();
@@ -9039,6 +8967,7 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV
            base = 10;
            goto uns_integer;
 
+       case 'B':
        case 'b':
            base = 2;
            goto uns_integer;
@@ -9132,7 +9061,7 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV
                    } while (uv >>= 1);
                    if (tempalt) {
                        esignbuf[esignlen++] = '0';
-                       esignbuf[esignlen++] = 'b';
+                       esignbuf[esignlen++] = c;
                    }
                    break;
                default:                /* it had better be ten or less */
@@ -9147,7 +9076,8 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV
                if (has_precis) {
                    if (precis > elen)
                        zeros = precis - elen;
-                   else if (precis == 0 && elen == 1 && *eptr == '0')
+                   else if (precis == 0 && elen == 1 && *eptr == '0'
+                            && !(base == 8 && alt)) /* "%#.0o" prints "0" */
                        elen = 0;
 
                /* a precision nullifies the 0 flag. */
@@ -9548,15 +9478,6 @@ ptr_table_* functions.
 #define SAVEPVN(p,n)   ((p) ? savepvn(p,n) : NULL)
 
 
-/* Duplicate a regexp. Required reading: pregcomp() and pregfree() in
-   regcomp.c. AMS 20010712 */
-
-REGEXP *
-Perl_re_dup(pTHX_ const REGEXP *r, CLONE_PARAMS *param)
-{
-    return CALLREGDUPE(r,param);
-}
-
 /* duplicate a file handle */
 
 PerlIO *
@@ -9651,7 +9572,7 @@ Perl_mg_dup(pTHX_ MAGIC *mg, CLONE_PARAMS* param)
        nmg->mg_type    = mg->mg_type;
        nmg->mg_flags   = mg->mg_flags;
        if (mg->mg_type == PERL_MAGIC_qr) {
-           nmg->mg_obj = (SV*)re_dup((REGEXP*)mg->mg_obj, param);
+           nmg->mg_obj = (SV*)CALLREGDUPE((REGEXP*)mg->mg_obj, param);
        }
        else if(mg->mg_type == PERL_MAGIC_backref) {
            /* The backref AV has its reference count deliberately bumped by
@@ -9957,6 +9878,7 @@ Perl_sv_dup(pTHX_ const SV *sstr, CLONE_PARAMS* param)
        SvANY(dstr)     = &(dstr->sv_u.svu_rv);
        Perl_rvpv_dup(aTHX_ dstr, sstr, param);
        break;
+       /* case SVt_BIND: */
     default:
        {
            /* These are all the types that need complex bodies allocating.  */
@@ -9978,7 +9900,6 @@ Perl_sv_dup(pTHX_ const SV *sstr, CLONE_PARAMS* param)
            case SVt_PVFM:
            case SVt_PVHV:
            case SVt_PVAV:
-           case SVt_PVBM:
            case SVt_PVCV:
            case SVt_PVLV:
            case SVt_PVMG:
@@ -10035,8 +9956,6 @@ Perl_sv_dup(pTHX_ const SV *sstr, CLONE_PARAMS* param)
                break;
            case SVt_PVMG:
                break;
-           case SVt_PVBM:
-               break;
            case SVt_PVLV:
                /* XXX LvTARGOFF sometimes holds PMOP* when DEBUGGING */
                if (LvTYPE(dstr) == 't') /* for tie: unrefcnted fake (SV**) */
@@ -10047,12 +9966,15 @@ Perl_sv_dup(pTHX_ const SV *sstr, CLONE_PARAMS* param)
                    LvTARG(dstr) = sv_dup_inc(LvTARG(dstr), param);
                break;
            case SVt_PVGV:
-               if (GvNAME_HEK(dstr))
-                   GvNAME_HEK(dstr) = hek_dup(GvNAME_HEK(dstr), param);
+               if(isGV_with_GP(sstr)) {
+                   if (GvNAME_HEK(dstr))
+                       GvNAME_HEK(dstr) = hek_dup(GvNAME_HEK(dstr), param);
+               }
 
                /* Don't call sv_add_backref here as it's going to be created
                   as part of the magic cloning of the symbol table.  */
-               GvSTASH(dstr)   = hv_dup(GvSTASH(dstr), param);
+               if(!SvVALID(dstr))
+                   GvSTASH(dstr) = hv_dup(GvSTASH(dstr), param);
                if(isGV_with_GP(sstr)) {
                    /* Danger Will Robinson - GvGP(dstr) isn't initialised
                       at the point of this comment.  */
@@ -10098,7 +10020,7 @@ Perl_sv_dup(pTHX_ const SV *sstr, CLONE_PARAMS* param)
                    src_ary = AvARRAY((AV*)sstr);
                    Newxz(dst_ary, AvMAX((AV*)sstr)+1, SV*);
                    ptr_table_store(PL_ptr_table, src_ary, dst_ary);
-                   SvPV_set(dstr, (char*)dst_ary);
+                   AvARRAY((AV*)dstr) = dst_ary;
                    AvALLOC((AV*)dstr) = dst_ary;
                    if (AvREAL((AV*)sstr)) {
                        while (items-- > 0)
@@ -10114,7 +10036,7 @@ Perl_sv_dup(pTHX_ const SV *sstr, CLONE_PARAMS* param)
                    }
                }
                else {
-                   SvPV_set(dstr, NULL);
+                   AvARRAY((AV*)dstr)  = NULL;
                    AvALLOC((AV*)dstr)  = (SV**)NULL;
                }
                break;
@@ -10161,7 +10083,7 @@ Perl_sv_dup(pTHX_ const SV *sstr, CLONE_PARAMS* param)
                    }
                }
                else
-                   SvPV_set(dstr, NULL);
+                   HvARRAY((HV*)dstr) = NULL;
                break;
            case SVt_PVCV:
                if (!(param->flags & CLONEf_COPY_STACKS)) {
@@ -10432,7 +10354,7 @@ Perl_ss_dup(pTHX_ PerlInterpreter *proto_perl, CLONE_PARAMS* param)
            /* fall through */
        case SAVEt_COMPPAD:
        case SAVEt_NSTAB:
-           sv = POPPTR(ss,ix);
+           sv = (SV*) POPPTR(ss,ix);
            TOPPTR(nss,ix) = sv_dup(sv, param);
            break;
        case SAVEt_INT:                         /* int reference */
@@ -10506,7 +10428,9 @@ Perl_ss_dup(pTHX_ PerlInterpreter *proto_perl, CLONE_PARAMS* param)
                case OP_LEAVEWRITE:
                    TOPPTR(nss,ix) = ptr;
                    o = (OP*)ptr;
+                   OP_REFCNT_LOCK;
                    OpREFCNT_inc(o);
+                   OP_REFCNT_UNLOCK;
                    break;
                default:
                    TOPPTR(nss,ix) = NULL;
@@ -11011,7 +10935,7 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags,
                SvREPADTMP(regex)
                    ? sv_dup_inc(regex, param)
                    : SvREFCNT_inc(
-                       newSViv(PTR2IV(re_dup(
+                       newSViv(PTR2IV(CALLREGDUPE(
                                INT2PTR(REGEXP *, SvIVX(regex)), param))))
                ;
            av_push(PL_regex_padav, sv);
@@ -11078,7 +11002,9 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags,
 
     /* current interpreter roots */
     PL_main_cv         = cv_dup_inc(proto_perl->Imain_cv, param);
+    OP_REFCNT_LOCK;
     PL_main_root       = OpREFCNT_inc(proto_perl->Imain_root);
+    OP_REFCNT_UNLOCK;
     PL_main_start      = proto_perl->Imain_start;
     PL_eval_root       = proto_perl->Ieval_root;
     PL_eval_start      = proto_perl->Ieval_start;