Update Changes.

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

diff --git a/sv.c b/sv.c
index 20b387c..5cdcbf9 100644 (file)
--- a/sv.c
+++ b/sv.c
@@ -1569,22 +1569,13 @@ Perl_sv_2iv(pTHX_ register SV *sv)
                goto ret_iv_max;
            }
        }
-       else if (numtype) {
-           /* The NV may be reconstructed from IV - safe to cache IV,
-              which may be calculated by atol(). */
-           if (SvTYPE(sv) == SVt_PV)
-               sv_upgrade(sv, SVt_PVIV);
-           (void)SvIOK_on(sv);
-           SvIVX(sv) = Atol(SvPVX(sv));
-       }
-       else {                          /* Not a number.  Cache 0. */
-           dTHR;
-
+       else {  /* The NV may be reconstructed from IV - safe to cache IV,
+                  which may be calculated by atol(). */
            if (SvTYPE(sv) < SVt_PVIV)
                sv_upgrade(sv, SVt_PVIV);
            (void)SvIOK_on(sv);
-           SvIVX(sv) = 0;
-           if (ckWARN(WARN_NUMERIC))
+           SvIVX(sv) = Atol(SvPVX(sv));
+           if (! numtype && ckWARN(WARN_NUMERIC))
                not_a_number(sv);
        }
     }
@@ -1812,7 +1803,7 @@ Perl_sv_2nv(pTHX_ register SV *sv)
            sv_upgrade(sv, SVt_NV);
 #if defined(USE_LONG_DOUBLE)
        DEBUG_c({
-           RESTORE_NUMERIC_STANDARD();
+           STORE_NUMERIC_LOCAL_SET_STANDARD();
            PerlIO_printf(Perl_debug_log,
                          "0x%"UVxf" num(%" PERL_PRIgldbl ")\n",
                          PTR2UV(sv), SvNVX(sv));
@@ -1820,7 +1811,7 @@ Perl_sv_2nv(pTHX_ register SV *sv)
        });
 #else
        DEBUG_c({
-           RESTORE_NUMERIC_STANDARD();
+           STORE_NUMERIC_LOCAL_SET_STANDARD();
            PerlIO_printf(Perl_debug_log, "0x%"UVxf" num(%g)\n",
                          PTR2UV(sv), SvNVX(sv));
            RESTORE_NUMERIC_LOCAL();
@@ -1852,14 +1843,14 @@ Perl_sv_2nv(pTHX_ register SV *sv)
     SvNOK_on(sv);
 #if defined(USE_LONG_DOUBLE)
     DEBUG_c({
-       RESTORE_NUMERIC_STANDARD();
+       STORE_NUMERIC_LOCAL_SET_STANDARD();
        PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2nv(%" PERL_PRIgldbl ")\n",
                      PTR2UV(sv), SvNVX(sv));
        RESTORE_NUMERIC_LOCAL();
     });
 #else
     DEBUG_c({
-       RESTORE_NUMERIC_STANDARD();
+       STORE_NUMERIC_LOCAL_SET_STANDARD();
        PerlIO_printf(Perl_debug_log, "0x%"UVxf" 1nv(%g)\n",
                      PTR2UV(sv), SvNVX(sv));
        RESTORE_NUMERIC_LOCAL();
@@ -2182,7 +2173,10 @@ Perl_sv_2pv(pTHX_ register SV *sv, STRLEN *lp)
                case SVt_PV:
                case SVt_PVIV:
                case SVt_PVNV:
-               case SVt_PVBM:  s = "SCALAR";                   break;
+               case SVt_PVBM:  if (SvROK(sv))
+                                   s = "REF";
+                               else
+                                   s = "SCALAR";               break;
                case SVt_PVLV:  s = "LVALUE";                   break;
                case SVt_PVAV:  s = "ARRAY";                    break;
                case SVt_PVHV:  s = "HASH";                     break;
@@ -2213,12 +2207,12 @@ Perl_sv_2pv(pTHX_ register SV *sv, STRLEN *lp)
     }
     if (SvNOKp(sv)) {                  /* See note in sv_2uv() */
        /* XXXX 64-bit?  IV may have better precision... */
-       /* I tried changing this for to be 64-bit-aware and
+       /* I tried changing this to be 64-bit-aware and
         * the t/op/numconvert.t became very, very, angry.
         * --jhi Sep 1999 */
        if (SvTYPE(sv) < SVt_PVNV)
            sv_upgrade(sv, SVt_PVNV);
-       SvGROW(sv, 28);
+       SvGROW(sv, NV_DIG + 1);
        s = SvPVX(sv);
        olderrno = errno;       /* some Xenix systems wipe out errno here */
 #ifdef apollo
@@ -5540,8 +5534,23 @@ Perl_newSVrv(pTHX_ SV *rv, const char *classname)
     SV_CHECK_THINKFIRST(rv);
     SvAMAGIC_off(rv);
 
+    if (SvTYPE(rv) >= SVt_PVMG) {
+       U32 refcnt = SvREFCNT(rv);
+       SvREFCNT(rv) = 0;
+       sv_clear(rv);
+       SvFLAGS(rv) = 0;
+       SvREFCNT(rv) = refcnt;
+    }
+
     if (SvTYPE(rv) < SVt_RV)
-      sv_upgrade(rv, SVt_RV);
+       sv_upgrade(rv, SVt_RV);
+    else if (SvTYPE(rv) > SVt_RV) {
+       (void)SvOOK_off(rv);
+       if (SvPVX(rv) && SvLEN(rv))
+           Safefree(SvPVX(rv));
+       SvCUR_set(rv, 0);
+       SvLEN_set(rv, 0);
+    }
 
     (void)SvOK_off(rv);
     SvRV(rv) = sv;
@@ -6183,16 +6192,19 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV
        /* SIZE */
 
        switch (*q) {
-#ifdef HAS_QUAD
+#if defined(HAS_QUAD) || (defined(HAS_LONG_DOUBLE) && defined(USE_LONG_DOUBLE))
        case 'L':                       /* Ld */
+           /* FALL THROUGH */
+#endif
+#ifdef HAS_QUAD
        case 'q':                       /* qd */
            intsize = 'q';
            q++;
            break;
 #endif
        case 'l':
-#ifdef HAS_QUAD
-             if (*(q + 1) == 'l') {    /* lld */
+#if defined(HAS_QUAD) || (defined(HAS_LONG_DOUBLE) && defined(USE_LONG_DOUBLE))
+             if (*(q + 1) == 'l') {    /* lld, llf */
                intsize = 'q';
                q += 2;
                break;
@@ -6534,11 +6546,14 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV
            eptr = ebuf + sizeof ebuf;
            *--eptr = '\0';
            *--eptr = c;
-#ifdef USE_LONG_DOUBLE
+#if defined(USE_LONG_DOUBLE) && defined(PERL_PRIfldbl)
            {
-               static char const my_prifldbl[] = PERL_PRIfldbl;
-               char const *p = my_prifldbl + sizeof my_prifldbl - 3;
-               while (p >= my_prifldbl) { *--eptr = *p--; }
+               /* Copy the one or more characters in a long double
+                * format before the 'base' ([efgEFG]) character to
+                * the format string. */
+               static char const prifldbl[] = PERL_PRIfldbl;
+               char const *p = prifldbl + sizeof(prifldbl) - 3;
+               while (p >= prifldbl) { *--eptr = *p--; }
            }
 #endif
            if (has_precis) {
@@ -6561,9 +6576,13 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV
            *--eptr = '%';
 
            {
-               RESTORE_NUMERIC_STANDARD();
+               STORE_NUMERIC_STANDARD_SET_LOCAL();
+#ifdef USE_LOCALE_NUMERIC
+               if (!was_standard && maybe_tainted)
+                   *maybe_tainted = TRUE;
+#endif
                (void)sprintf(PL_efloatbuf, eptr, nv);
-               RESTORE_NUMERIC_LOCAL();
+               RESTORE_NUMERIC_STANDARD();
            }
 
            eptr = PL_efloatbuf;
@@ -8316,9 +8335,15 @@ do_clean_objs(pTHXo_ SV *sv)
 
     if (SvROK(sv) && SvOBJECT(rv = SvRV(sv))) {
        DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning object ref:\n "), sv_dump(sv));)
-       SvROK_off(sv);
-       SvRV(sv) = 0;
-       SvREFCNT_dec(rv);
+       if (SvWEAKREF(sv)) {
+           sv_del_backref(sv);
+           SvWEAKREF_off(sv);
+           SvRV(sv) = 0;
+       } else {
+           SvROK_off(sv);
+           SvRV(sv) = 0;
+           SvREFCNT_dec(rv);
+       }
     }
 
     /* XXX Might want to check arrays, etc. */