hexfp: printf %.13a 1.0

[perl5.git] / sv.c

diff --git a/sv.c b/sv.c
index aec1568..d080f1f 100644 (file)
--- a/sv.c
+++ b/sv.c
@@ -1525,7 +1525,11 @@ wrapper instead.
 =cut
 */
 
-int
+/* prior to 5.000 stable, this function returned the new OOK-less SvFLAGS
+   prior to 5.23.4 this function always returned 0
+*/
+
+void
 Perl_sv_backoff(SV *const sv)
 {
     STRLEN delta;
@@ -1541,9 +1545,9 @@ Perl_sv_backoff(SV *const sv)
     
     SvLEN_set(sv, SvLEN(sv) + delta);
     SvPV_set(sv, SvPVX(sv) - delta);
-    Move(s, SvPVX(sv), SvCUR(sv)+1, char);
     SvFLAGS(sv) &= ~SVf_OOK;
-    return 0;
+    Move(s, SvPVX(sv), SvCUR(sv)+1, char);
+    return;
 }
 
 /*
@@ -8769,6 +8773,10 @@ Perl_sv_inc_nomg(pTHX_ SV *const sv)
        return;
     }
 
+    /* treat AV/HV/CV/FM/IO and non-fake GVs as immutable */
+    if (SvTYPE(sv) >= SVt_PVAV || (isGV_with_GP(sv) && !SvFAKE(sv)))
+        Perl_croak_no_modify();
+
     if (!(flags & SVp_POK) || !*SvPVX_const(sv)) {
        if ((flags & SVTYPEMASK) < SVt_PVIV)
            sv_upgrade(sv, ((flags & SVTYPEMASK) > SVt_IV ? SVt_PVIV : SVt_IV));
@@ -8948,6 +8956,11 @@ Perl_sv_dec_nomg(pTHX_ SV *const sv)
            return;
        }
     }
+
+    /* treat AV/HV/CV/FM/IO and non-fake GVs as immutable */
+    if (SvTYPE(sv) >= SVt_PVAV || (isGV_with_GP(sv) && !SvFAKE(sv)))
+        Perl_croak_no_modify();
+
     if (!(flags & SVp_POK)) {
        if ((flags & SVTYPEMASK) < SVt_PVIV)
            sv_upgrade(sv, ((flags & SVTYPEMASK) > SVt_IV) ? SVt_PVIV : SVt_IV);
@@ -9929,6 +9942,9 @@ Perl_sv_pvutf8n_force(pTHX_ SV *const sv, STRLEN *const lp)
 
 Returns a string describing what the SV is a reference to.
 
+If ob is true and the SV is blessed, the string is the class name,
+otherwise it is the type of the SV, "SCALAR", "ARRAY" etc.
+
 =cut
 */
 
@@ -9987,6 +10003,12 @@ Perl_sv_reftype(pTHX_ const SV *const sv, const int ob)
 
 Returns a SV describing what the SV passed in is a reference to.
 
+dst can be a SV to be set to the description or NULL, in which case a
+mortal SV is returned.
+
+If ob is true and the SV is blessed, the description is the class
+name, otherwise it is the type of the SV, "SCALAR", "ARRAY" etc.
+
 =cut
 */
 
@@ -11444,9 +11466,10 @@ Perl_sv_vcatpvfn_flags(pTHX_ SV *const sv, const char *const pat, const STRLEN p
                   is safe. */
                is_utf8 = (bool)va_arg(*args, int);
                elen = va_arg(*args, UV);
-                if ((IV)elen < 0) {
-                    /* check if utf8 length is larger than 0 when cast to IV */
-                    assert( (IV)elen >= 0 ); /* in DEBUGGING build we want to crash */
+                /* if utf8 length is larger than 0x7ffff..., then it might
+                 * have been a signed value that wrapped */
+                if (elen  > ((~(STRLEN)0) >> 1)) {
+                    assert(0); /* in DEBUGGING build we want to crash */
                     elen= 0; /* otherwise we want to treat this as an empty string */
                 }
                eptr = va_arg(*args, char *);
@@ -12340,7 +12363,9 @@ Perl_sv_vcatpvfn_flags(pTHX_ SV *const sv, const char *const pat, const STRLEN p
 #  endif
 #endif
 
-                if (fv < 0)
+                if (fv < 0
+                    || Perl_signbit(fv)
+                  )
                     *p++ = '-';
                 else if (plus)
                     *p++ = plus;
@@ -12424,8 +12449,8 @@ Perl_sv_vcatpvfn_flags(pTHX_ SV *const sv, const char *const pat, const STRLEN p
                     *p++ = xdig[*v++];
 
                     /* The radix is always output after the first
-                     * non-zero xdigit, or if alt.  */
-                    if (vfnz < vlnz || alt) {
+                     * non-zero xdigit, or if precis, or if alt.  */
+                    if (vfnz < vlnz || precis > 0 || alt) {
 #ifndef USE_LOCALE_NUMERIC
                         *p++ = '.';
 #else
@@ -12562,7 +12587,7 @@ Perl_sv_vcatpvfn_flags(pTHX_ SV *const sv, const char *const pat, const STRLEN p
                     elen = quadmath_snprintf(PL_efloatbuf, PL_efloatsize,
                                              qfmt, nv);
                     if ((IV)elen == -1)
-                        Perl_croak_nocontext("panic: quadmath_snprintf failed, format \"%s|'", qfmt);
+                        Perl_croak_nocontext("panic: quadmath_snprintf failed, format \"%s\"", qfmt);
                     if (qfmt != ptr)
                         Safefree(qfmt);
                 }
@@ -12690,7 +12715,8 @@ Perl_sv_vcatpvfn_flags(pTHX_ SV *const sv, const char *const pat, const STRLEN p
            }
        }
 
-        assert((IV)elen >= 0); /* here zero elen is fine */
+        /* signed value that's wrapped? */
+        assert(elen  <= ((~(STRLEN)0) >> 1));
        have = esignlen + zeros + elen;
        if (have < zeros)
            croak_memory_wrap();
@@ -14408,7 +14434,7 @@ perl_clone(PerlInterpreter *proto_perl, UV flags)
    /* perlhost.h so we need to call into it
    to clone the host, CPerlHost should have a c interface, sky */
 
-#if !defined(__amigaos4__)
+#ifndef __amigaos4__
    if (flags & CLONEf_CLONE_HOST) {
        return perl_clone_host(proto_perl,flags);
    }