Sync with the latest MakeMaker snapshot.

[p5sagit/p5-mst-13.2.git] / sv.c

diff --git a/sv.c b/sv.c
index 6293937..47616ce 100644 (file)
--- a/sv.c
+++ b/sv.c
@@ -3984,6 +3984,10 @@ Perl_sv_setsv_flags(pTHX_ SV *dstr, register SV *sstr, I32 flags)
         * has to be allocated and SvPVX(sstr) has to be freed.
         */
 
+       /* Whichever path we take through the next code, we want this true,
+          and doing it now facilitates the COW check.  */
+       (void)SvPOK_only(dstr);
+
        if (
 #ifdef PERL_COPY_ON_WRITE
             (sflags & (SVf_FAKE | SVf_READONLY)) != (SVf_FAKE | SVf_READONLY)
@@ -3998,6 +4002,7 @@ Perl_sv_setsv_flags(pTHX_ SV *dstr, register SV *sstr, I32 flags)
              !(PL_op && PL_op->op_type == OP_AASSIGN))
 #ifdef PERL_COPY_ON_WRITE
             && !((sflags & CAN_COW_MASK) == CAN_COW_FLAGS
+                && (SvFLAGS(dstr) & CAN_COW_MASK) == CAN_COW_FLAGS
                  && SvTYPE(sstr) >= SVt_PVIV)
 #endif
             ) {
@@ -4008,7 +4013,6 @@ Perl_sv_setsv_flags(pTHX_ SV *dstr, register SV *sstr, I32 flags)
             Move(SvPVX(sstr),SvPVX(dstr),len,char);
             SvCUR_set(dstr, len);
             *SvEND(dstr) = '\0';
-            (void)SvPOK_only(dstr);
         } else {
             /* If PERL_COPY_ON_WRITE is not defined, then isSwipe will always
                be true in here.  */
@@ -4046,7 +4050,6 @@ Perl_sv_setsv_flags(pTHX_ SV *dstr, register SV *sstr, I32 flags)
                else if (SvLEN(dstr))
                    Safefree(SvPVX(dstr));
            }
-           (void)SvPOK_only(dstr);
 
 #ifdef PERL_COPY_ON_WRITE
             if (!isSwipe) {
@@ -4494,14 +4497,17 @@ Perl_sv_force_normal_flags(pTHX_ register SV *sv, U32 flags)
     if (SvREADONLY(sv)) {
        if (SvFAKE(sv)) {
            char *pvx = SvPVX(sv);
+           int is_utf8 = SvUTF8(sv);
            STRLEN len = SvCUR(sv);
             U32 hash   = SvUVX(sv);
            SvFAKE_off(sv);
            SvREADONLY_off(sv);
+            SvPVX(sv) = 0;
+            SvLEN(sv) = 0;
            SvGROW(sv, len + 1);
            Move(pvx,SvPVX(sv),len,char);
            *SvEND(sv) = '\0';
-           unsharepvn(pvx, SvUTF8(sv) ? -(I32)len : len, hash);
+           unsharepvn(pvx, is_utf8 ? -(I32)len : len, hash);
        }
        else if (IN_PERL_RUNTIME)
            Perl_croak(aTHX_ PL_no_modify);
@@ -5729,10 +5735,8 @@ S_utf8_mg_pos_init(pTHX_ SV *sv, MAGIC **mgp, STRLEN **cachep, I32 i, I32 *offse
     bool found = FALSE; 
 
     if (SvMAGICAL(sv) && !SvREADONLY(sv)) {
-       if (!*mgp) {
-           sv_magic(sv, 0, PERL_MAGIC_utf8, 0, 0);
-           *mgp = mg_find(sv, PERL_MAGIC_utf8);
-       }
+       if (!*mgp)
+           *mgp = sv_magicext(sv, 0, PERL_MAGIC_utf8, &PL_vtbl_utf8, 0, 0);
        assert(*mgp);
 
        if ((*mgp)->mg_ptr)
@@ -5825,6 +5829,12 @@ S_utf8_mg_pos(pTHX_ SV *sv, MAGIC **mgp, STRLEN **cachep, I32 i, I32 *offsetp, I
                      /* Update the cache. */
                      (*cachep)[i]   = (STRLEN)uoff;
                      (*cachep)[i+1] = p - start;
+
+                     /* Drop the stale "length" cache */
+                     if (i == 0) {
+                         (*cachep)[2] = 0;
+                         (*cachep)[3] = 0;
+                     }
  
                      found = TRUE;
                 }
@@ -8627,6 +8637,7 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV
        }
     }
 
+#ifndef USE_LONG_DOUBLE
     /* special-case "%.<number>[gf]" */
     if ( patlen <= 5 && pat[0] == '%' && pat[1] == '.'
         && (pat[patlen-1] == 'g' || pat[patlen-1] == 'f') ) {
@@ -8647,7 +8658,7 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV
                return;
            if (*pp == 'g') {
                if (digits < sizeof(ebuf) - NV_DIG - 10) { /* 0, point, slack */
-                   Gconvert((double)nv, digits, 0, ebuf);
+                   Gconvert(nv, (int)digits, 0, ebuf);
                    sv_catpv(sv, ebuf);
                    if (*ebuf)  /* May return an empty string for digits==0 */
                        return;
@@ -8662,6 +8673,7 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV
            }
        }
     }
+#endif /* !USE_LONG_DOUBLE */
 
     if (!args && svix < svmax && DO_UTF8(*svargs))
        has_utf8 = TRUE;
@@ -9356,7 +9368,7 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV
            if ( !(width || left || plus || alt) && fill != '0'
                 && has_precis && intsize != 'q' ) {    /* Shortcuts */
                if ( c == 'g') {
-                   Gconvert((double)nv, precis, 0, PL_efloatbuf);
+                   Gconvert((NV)nv, (int)precis, 0, PL_efloatbuf);
                    if (*PL_efloatbuf)  /* May return an empty string for digits==0 */
                        goto float_converted;
                } else if ( c == 'f' && !precis) {
@@ -10995,9 +11007,10 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags,
     PL_debug           = proto_perl->Idebug;
 
 #ifdef USE_REENTRANT_API
-#ifdef DEBUGGING
-    PERL_SET_CONTEXT(proto_perl);
-#endif
+    /* XXX: things like -Dm will segfault here in perlio, but doing
+     *  PERL_SET_CONTEXT(proto_perl);
+     * breaks too many other things
+     */
     Perl_reentrant_init(aTHX);
 #endif