(perl #129149) avoid a heap buffer overflow with pack "W"...

[perl5.git] / pp_pack.c

diff --git a/pp_pack.c b/pp_pack.c
index b1a0d85..737e019 100644 (file)
--- a/pp_pack.c
+++ b/pp_pack.c
@@ -791,20 +791,20 @@ first_symbol(const char *pat, const char *patend) {
 
 =for apidoc unpackstring
 
-The engine implementing the unpack() Perl function.
+The engine implementing the C<unpack()> Perl function.
 
-Using the template pat..patend, this function unpacks the string
-s..strend into a number of mortal SVs, which it pushes onto the perl
-argument (@_) stack (so you will need to issue a C<PUTBACK> before and
+Using the template C<pat..patend>, this function unpacks the string
+C<s..strend> into a number of mortal SVs, which it pushes onto the perl
+argument (C<@_>) stack (so you will need to issue a C<PUTBACK> before and
 C<SPAGAIN> after the call to this function).  It returns the number of
 pushed elements.
 
-The strend and patend pointers should point to the byte following the last
-character of each string.
+The C<strend> and C<patend> pointers should point to the byte following the
+last character of each string.
 
 Although this function returns its values on the perl argument stack, it
 doesn't take any parameters from that stack (and thus in particular
-there's no need to do a PUSHMARK before calling it, unlike L</call_pv> for
+there's no need to do a C<PUSHMARK> before calling it, unlike L</call_pv> for
 example).
 
 =cut */
@@ -1073,9 +1073,14 @@ S_unpack_rec(pTHX_ tempsym_t* symptr, const char *s, const char *strbeg, const c
                /* 'A' strips both nulls and spaces */
                const char *ptr;
                if (utf8 && (symptr->flags & FLAG_WAS_UTF8)) {
-                   for (ptr = s+len-1; ptr >= s; ptr--)
-                       if (*ptr != 0 && !UTF8_IS_CONTINUATION(*ptr) &&
-                           !isSPACE_utf8(ptr)) break;
+                    for (ptr = s+len-1; ptr >= s; ptr--) {
+                        if (   *ptr != 0
+                            && !UTF8_IS_CONTINUATION(*ptr)
+                            && !isSPACE_utf8_safe(ptr, strend))
+                        {
+                            break;
+                        }
+                    }
                    if (ptr >= s) ptr += UTF8SKIP(ptr);
                    else ptr++;
                    if (ptr > s+len)
@@ -1585,7 +1590,8 @@ S_unpack_rec(pTHX_ tempsym_t* symptr, const char *s, const char *strbeg, const c
                    if (++bytes >= sizeof(UV)) {        /* promote to string */
                        const char *t;
 
-                       sv = Perl_newSVpvf(aTHX_ "%.*"UVuf, (int)TYPE_DIGITS(UV), auv);
+                       sv = Perl_newSVpvf(aTHX_ "%.*" UVuf,
+                                                 (int)TYPE_DIGITS(UV), auv);
                        while (s < strend) {
                            ch = SHIFT_BYTE(utf8, s, strend, datumtype);
                            sv = mul128(sv, (U8)(ch & 0x7f));
@@ -1767,7 +1773,18 @@ S_unpack_rec(pTHX_ tempsym_t* symptr, const char *s, const char *strbeg, const c
                }
                while (cdouble < 0.0)
                    cdouble += anv;
-               cdouble = Perl_modf(cdouble / anv, &trouble) * anv;
+               cdouble = Perl_modf(cdouble / anv, &trouble);
+#ifdef LONGDOUBLE_DOUBLEDOUBLE
+                /* Workaround for powerpc doubledouble modfl bug:
+                 * close to 1.0L and -1.0L cdouble is 0, and trouble
+                 * is cdouble / anv. */
+                if (trouble != Perl_ceil(trouble)) {
+                  cdouble = trouble;
+                  if (cdouble >  1.0L) cdouble -= 1.0L;
+                  if (cdouble < -1.0L) cdouble += 1.0L;
+                }
+#endif
+                cdouble *= anv;
                sv = newSVnv(cdouble);
            }
            else {
@@ -1815,7 +1832,7 @@ PP(pp_unpack)
 {
     dSP;
     dPOPPOPssrl;
-    I32 gimme = GIMME_V;
+    U8 gimme = GIMME_V;
     STRLEN llen;
     STRLEN rlen;
     const char *pat = SvPV_const(left,  llen);
@@ -1937,7 +1954,7 @@ S_div128(pTHX_ SV *pnum, bool *done)
 /*
 =for apidoc packlist
 
-The engine implementing pack() Perl function.
+The engine implementing C<pack()> Perl function.
 
 =cut
 */
@@ -2052,9 +2069,9 @@ S_sv_check_infnan(pTHX_ SV *sv, I32 datumtype)
        const I32 c = TYPE_NO_MODIFIERS(datumtype);
        const NV nv = SvNV_nomg(sv);
        if (c == 'w')
-           Perl_croak(aTHX_ "Cannot compress %"NVgf" in pack", nv);
+           Perl_croak(aTHX_ "Cannot compress %" NVgf " in pack", nv);
        else
-           Perl_croak(aTHX_ "Cannot pack %"NVgf" with '%c'", nv, (int) c);
+           Perl_croak(aTHX_ "Cannot pack %" NVgf " with '%c'", nv, (int) c);
     }
     return sv;
 }
@@ -2344,7 +2361,7 @@ S_pack_rec(pTHX_ SV *cat, tempsym_t* symptr, SV **beglist, SV **endlist )
                if (!S_utf8_to_bytes(aTHX_ &aptr, end, cur, fromlen,
                                  datumtype | TYPE_IS_PACK))
                    Perl_croak(aTHX_ "panic: predicted utf8 length not available, "
-                              "for '%c', aptr=%p end=%p cur=%p, fromlen=%"UVuf,
+                              "for '%c', aptr=%p end=%p cur=%p, fromlen=%" UVuf,
                               (int)datumtype, aptr, end, cur, (UV)fromlen);
                cur += fromlen;
                len -= fromlen;
@@ -2477,7 +2494,7 @@ S_pack_rec(pTHX_ SV *cat, tempsym_t* symptr, SV **beglist, SV **endlist )
            if (howlen == e_star) len = fromlen;
            field_len = (len+1)/2;
            GROWING(utf8, cat, start, cur, field_len);
-           if (!utf8 && len > (I32)fromlen) len = fromlen;
+           if (!utf8_source && len > (I32)fromlen) len = fromlen;
            bits = 0;
            l = 0;
            if (datumtype == 'H')
@@ -2570,7 +2587,7 @@ S_pack_rec(pTHX_ SV *cat, tempsym_t* symptr, SV **beglist, SV **endlist )
                if (in_bytes) auv = auv % 0x100;
                if (utf8) {
                  W_utf8:
-                   if (cur > end) {
+                   if (cur >= end) {
                        *cur = '\0';
                        SvCUR_set(cat, cur - start);
 
@@ -2663,7 +2680,7 @@ S_pack_rec(pTHX_ SV *cat, tempsym_t* symptr, SV **beglist, SV **endlist )
                NV anv;
                fromstr = NEXTFROM;
                anv = SvNV(fromstr);
-# if defined(VMS) && !defined(_IEEE_FP)
+# if (defined(VMS) && !defined(_IEEE_FP)) || defined(DOUBLE_IS_VAX_FLOAT)
                /* IEEE fp overflow shenanigans are unavailable on VAX and optional
                 * on Alpha; fake it if we don't have them.
                 */
@@ -2673,15 +2690,17 @@ S_pack_rec(pTHX_ SV *cat, tempsym_t* symptr, SV **beglist, SV **endlist )
                    afloat = -FLT_MAX;
                else afloat = (float)anv;
 # else
-#if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
+#  if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
                if(Perl_isnan(anv))
                    afloat = (float)NV_NAN;
                else
-#endif
+#  endif
+#  ifdef NV_INF
                 /* a simple cast to float is undefined if outside
                  * the range of values that can be represented */
                afloat = (float)(anv >  FLT_MAX ?  NV_INF :
                                  anv < -FLT_MAX ? -NV_INF : anv);
+#  endif
 # endif
                 PUSH_VAR(utf8, cur, afloat, needs_swap);
            }
@@ -2692,7 +2711,7 @@ S_pack_rec(pTHX_ SV *cat, tempsym_t* symptr, SV **beglist, SV **endlist )
                NV anv;
                fromstr = NEXTFROM;
                anv = SvNV(fromstr);
-# if defined(VMS) && !defined(_IEEE_FP)
+# if (defined(VMS) && !defined(_IEEE_FP)) || defined(DOUBLE_IS_VAX_FLOAT)
                /* IEEE fp overflow shenanigans are unavailable on VAX and optional
                 * on Alpha; fake it if we don't have them.
                 */
@@ -3029,7 +3048,8 @@ S_pack_rec(pTHX_ SV *cat, tempsym_t* symptr, SV **beglist, SV **endlist )
                     * of pack() (and all copies of the result) are
                     * gone.
                     */
-                   if ((SvTEMP(fromstr) || (SvPADTMP(fromstr) &&
+                   if (((SvTEMP(fromstr) && SvREFCNT(fromstr) == 1)
+                        || (SvPADTMP(fromstr) &&
                             !SvREADONLY(fromstr)))) {
                        Perl_ck_warner(aTHX_ packWARN(WARN_PACK),
                                       "Attempt to pack pointer to temporary value");
@@ -3111,7 +3131,7 @@ PP(pp_pack)
     const char *patend = pat + fromlen;
 
     MARK++;
-    sv_setpvs(cat, "");
+    SvPVCLEAR(cat);
     SvUTF8_off(cat);
 
     packlist(cat, pat, patend, MARK, SP + 1);