Missing "by" noticed by James Keenan.

[perl5.git] / pp_pack.c

diff --git a/pp_pack.c b/pp_pack.c
index e4211b1..d703a99 100644 (file)
--- a/pp_pack.c
+++ b/pp_pack.c
@@ -337,7 +337,6 @@ uni_to_bytes(pTHX_ const char **s, const char *end, const char *buf, int buf_len
 STATIC bool
 next_uni_uu(pTHX_ const char **s, const char *end, I32 *out)
 {
 STATIC bool
 next_uni_uu(pTHX_ const char **s, const char *end, I32 *out)
 {

-    dVAR;

     STRLEN retlen;
     const UV val = utf8n_to_uvchr((U8 *) *s, end-*s, &retlen, UTF8_CHECK_ONLY);
     if (val >= 0x100 || !ISUUCHAR(val) ||
     STRLEN retlen;
     const UV val = utf8n_to_uvchr((U8 *) *s, end-*s, &retlen, UTF8_CHECK_ONLY);
     if (val >= 0x100 || !ISUUCHAR(val) ||


@@ -448,7 +447,7 @@ S_measure_struct(pTHX_ tempsym_t* symptr)
          case e_star:
            Perl_croak(aTHX_ "Within []-length '*' not allowed in %s",
                         _action( symptr ) );
          case e_star:
            Perl_croak(aTHX_ "Within []-length '*' not allowed in %s",
                         _action( symptr ) );

-            break;
+

          default:
            /* e_no_len and e_number */
            len = symptr->length;
          default:
            /* e_no_len and e_number */
            len = symptr->length;


@@ -497,7 +496,7 @@ S_measure_struct(pTHX_ tempsym_t* symptr)
                if (!len)               /* Avoid division by 0 */
                    len = 1;
                len = total % len;      /* Assumed: the start is aligned. */
                if (!len)               /* Avoid division by 0 */
                    len = 1;
                len = total % len;      /* Assumed: the start is aligned. */

-               /* FALL THROUGH */
+               /* FALLTHROUGH */

            case 'X':
                size = -1;
                if (total < len)
            case 'X':
                size = -1;
                if (total < len)


@@ -511,7 +510,7 @@ S_measure_struct(pTHX_ tempsym_t* symptr)
                    len = len - star;
                else
                    len = 0;
                    len = len - star;
                else
                    len = 0;

-               /* FALL THROUGH */
+               /* FALLTHROUGH */

            case 'x':
            case 'A':
            case 'Z':
            case 'x':
            case 'A':
            case 'Z':


@@ -567,7 +566,7 @@ S_group_end(pTHX_ const char *patptr, const char *patend, char ender)
     }
     Perl_croak(aTHX_ "No group ending character '%c' found in template",
                ender);
     }
     Perl_croak(aTHX_ "No group ending character '%c' found in template",
                ender);

-    return 0;
+    NOT_REACHED; /* NOTREACHED */

 }
 
 
 }
 
 


@@ -810,6 +809,9 @@ first_symbol(const char *pat, const char *patend) {
 }
 
 /*
 }
 
 /*

+
+=head1 Pack and Unpack
+

 =for apidoc unpackstring
 
 The engine implementing the unpack() Perl function.
 =for apidoc unpackstring
 
 The engine implementing the unpack() Perl function.


@@ -859,7 +861,7 @@ Perl_unpackstring(pTHX_ const char *pat, const char *patend, const char *s, cons
 STATIC I32
 S_unpack_rec(pTHX_ tempsym_t* symptr, const char *s, const char *strbeg, const char *strend, const char **new_s )
 {
 STATIC I32
 S_unpack_rec(pTHX_ tempsym_t* symptr, const char *s, const char *strbeg, const char *strend, const char **new_s )
 {

-    dVAR; dSP;
+    dSP;

     SV *sv = NULL;
     const I32 start_sp_offset = SP - PL_stack_base;
     howlen_t howlen;
     SV *sv = NULL;
     const I32 start_sp_offset = SP - PL_stack_base;
     howlen_t howlen;


@@ -931,7 +933,7 @@ S_unpack_rec(pTHX_ tempsym_t* symptr, const char *s, const char *strbeg, const c
            cuv = 0;
            cdouble = 0;
            continue;
            cuv = 0;
            cdouble = 0;
            continue;

-           break;
+

        case '(':
        {
             tempsym_t savsym = *symptr;
        case '(':
        {
             tempsym_t savsym = *symptr;


@@ -1013,7 +1015,7 @@ S_unpack_rec(pTHX_ tempsym_t* symptr, const char *s, const char *strbeg, const c
                break;
            }
            len = (s - strbeg) % len;
                break;
            }
            len = (s - strbeg) % len;

-           /* FALL THROUGH */
+           /* FALLTHROUGH */

        case 'X':
            if (utf8) {
                while (len > 0) {
        case 'X':
            if (utf8) {
                while (len > 0) {


@@ -1040,7 +1042,7 @@ S_unpack_rec(pTHX_ tempsym_t* symptr, const char *s, const char *strbeg, const c
            if (ai32 == 0) break;
            len -= ai32;
             }
            if (ai32 == 0) break;
            len -= ai32;
             }

-           /* FALL THROUGH */
+           /* FALLTHROUGH */

        case 'x':
            if (utf8) {
                while (len>0) {
        case 'x':
            if (utf8) {
                while (len>0) {


@@ -1057,7 +1059,7 @@ S_unpack_rec(pTHX_ tempsym_t* symptr, const char *s, const char *strbeg, const c
            break;
        case '/':
            Perl_croak(aTHX_ "'/' must follow a numeric type in unpack");
            break;
        case '/':
            Perl_croak(aTHX_ "'/' must follow a numeric type in unpack");

-            break;
+

        case 'A':
        case 'Z':
        case 'a':
        case 'A':
        case 'Z':
        case 'a':


@@ -1232,7 +1234,7 @@ S_unpack_rec(pTHX_ tempsym_t* symptr, const char *s, const char *strbeg, const c
                    utf8 = (symptr->flags & FLAG_DO_UTF8) ? 1 : 0;
                break;
            }
                    utf8 = (symptr->flags & FLAG_DO_UTF8) ? 1 : 0;
                break;
            }

-           /* FALL THROUGH */
+           /* FALLTHROUGH */

        case 'c':
            while (len-- > 0 && s < strend) {
                int aint;
        case 'c':
            while (len-- > 0 && s < strend) {
                int aint;


@@ -1346,7 +1348,7 @@ S_unpack_rec(pTHX_ tempsym_t* symptr, const char *s, const char *strbeg, const c
            }
            break;
 #else
            }
            break;
 #else

-           /* Fallthrough! */
+           /* FALLTHROUGH */

 #endif
        case 's':
            while (len-- > 0) {
 #endif
        case 's':
            while (len-- > 0) {


@@ -1383,7 +1385,7 @@ S_unpack_rec(pTHX_ tempsym_t* symptr, const char *s, const char *strbeg, const c
            }
            break;
 #else
            }
            break;
 #else

-            /* Fallthrough! */
+            /* FALLTHROUGH */

 #endif
        case 'v':
        case 'n':
 #endif
        case 'v':
        case 'n':


@@ -1492,7 +1494,7 @@ S_unpack_rec(pTHX_ tempsym_t* symptr, const char *s, const char *strbeg, const c
            }
            break;
 #else
            }
            break;
 #else

-           /* Fallthrough! */
+           /* FALLTHROUGH */

 #endif
        case 'l':
            while (len-- > 0) {
 #endif
        case 'l':
            while (len-- > 0) {


@@ -1526,7 +1528,7 @@ S_unpack_rec(pTHX_ tempsym_t* symptr, const char *s, const char *strbeg, const c
            }
            break;
 #else
            }
            break;
 #else

-            /* Fall through! */
+            /* FALLTHROUGH */

 #endif
        case 'V':
        case 'N':
 #endif
        case 'V':
        case 'N':


@@ -1696,6 +1698,18 @@ S_unpack_rec(pTHX_ tempsym_t* symptr, const char *s, const char *strbeg, const c
                ld_bytes aldouble;
                 SHIFT_BYTES(utf8, s, strend, aldouble.bytes,
                             sizeof(aldouble.bytes), datumtype, needs_swap);
                ld_bytes aldouble;
                 SHIFT_BYTES(utf8, s, strend, aldouble.bytes,
                             sizeof(aldouble.bytes), datumtype, needs_swap);

+                /* The most common long double format, the x86 80-bit
+                 * extended precision, has either 2 or 6 unused bytes,
+                 * which may contain garbage, which may contain
+                 * unintentional data.  While we do zero the bytes of
+                 * the long double data in pack(), here in unpack() we
+                 * don't, because it's really hard to envision that
+                 * reading the long double off aldouble would be
+                 * affected by the unused bytes.
+                 *
+                 * Note that trying to unpack 'long doubles' of 'long
+                 * doubles' packed in another system is in the general
+                 * case doomed without having more detail. */

                if (!checksum)
                    mPUSHn(aldouble.ld);
                else
                if (!checksum)
                    mPUSHn(aldouble.ld);
                else


@@ -1839,7 +1853,6 @@ S_unpack_rec(pTHX_ tempsym_t* symptr, const char *s, const char *strbeg, const c
 
 PP(pp_unpack)
 {
 
 PP(pp_unpack)
 {

-    dVAR;

     dSP;
     dPOPPOPssrl;
     I32 gimme = GIMME_V;
     dSP;
     dPOPPOPssrl;
     I32 gimme = GIMME_V;


@@ -1972,7 +1985,6 @@ The engine implementing pack() Perl function.
 void
 Perl_packlist(pTHX_ SV *cat, const char *pat, const char *patend, SV **beglist, SV **endlist )
 {
 void
 Perl_packlist(pTHX_ SV *cat, const char *pat, const char *patend, SV **beglist, SV **endlist )
 {

-    dVAR;

     tempsym_t sym;
 
     PERL_ARGS_ASSERT_PACKLIST;
     tempsym_t sym;
 
     PERL_ARGS_ASSERT_PACKLIST;


@@ -2074,12 +2086,12 @@ STATIC
 SV **
 S_pack_rec(pTHX_ SV *cat, tempsym_t* symptr, SV **beglist, SV **endlist )
 {
 SV **
 S_pack_rec(pTHX_ SV *cat, tempsym_t* symptr, SV **beglist, SV **endlist )
 {

-    dVAR;

     tempsym_t lookahead;
     I32 items  = endlist - beglist;
     bool found = next_symbol(symptr);
     bool utf8 = (symptr->flags & FLAG_PARSE_UTF8) ? 1 : 0;
     bool warn_utf8 = ckWARN(WARN_UTF8);
     tempsym_t lookahead;
     I32 items  = endlist - beglist;
     bool found = next_symbol(symptr);
     bool utf8 = (symptr->flags & FLAG_PARSE_UTF8) ? 1 : 0;
     bool warn_utf8 = ckWARN(WARN_UTF8);

+    char* from;

 
     PERL_ARGS_ASSERT_PACK_REC;
 
 
     PERL_ARGS_ASSERT_PACK_REC;
 


@@ -2160,8 +2172,7 @@ S_pack_rec(pTHX_ SV *cat, tempsym_t* symptr, SV **beglist, SV **endlist )
                       (int) TYPE_NO_MODIFIERS(datumtype));
        case '%':
            Perl_croak(aTHX_ "'%%' may not be used in pack");
                       (int) TYPE_NO_MODIFIERS(datumtype));
        case '%':
            Perl_croak(aTHX_ "'%%' may not be used in pack");

-       {
-           char *from;
+

        case '.' | TYPE_IS_SHRIEKING:
        case '.':
            if (howlen == e_star) from = start;
        case '.' | TYPE_IS_SHRIEKING:
        case '.':
            if (howlen == e_star) from = start;


@@ -2210,7 +2221,7 @@ S_pack_rec(pTHX_ SV *cat, tempsym_t* symptr, SV **beglist, SV **endlist )
                goto shrink;
            }
            break;
                goto shrink;
            }
            break;

-       }
+

        case '(': {
             tempsym_t savsym = *symptr;
            U32 group_modifiers = TYPE_MODIFIERS(datumtype & ~symptr->flags);
        case '(': {
             tempsym_t savsym = *symptr;
            U32 group_modifiers = TYPE_MODIFIERS(datumtype & ~symptr->flags);


@@ -2256,7 +2267,7 @@ S_pack_rec(pTHX_ SV *cat, tempsym_t* symptr, SV **beglist, SV **endlist )
                break;
            }
            len = (cur-start) % len;
                break;
            }
            len = (cur-start) % len;

-           /* FALL THROUGH */
+           /* FALLTHROUGH */

        case 'X':
            if (utf8) {
                if (len < 1) goto no_change;
        case 'X':
            if (utf8) {
                if (len < 1) goto no_change;


@@ -2298,7 +2309,7 @@ S_pack_rec(pTHX_ SV *cat, tempsym_t* symptr, SV **beglist, SV **endlist )
            if (ai32 == 0) goto no_change;
            len -= ai32;
        }
            if (ai32 == 0) goto no_change;
            len -= ai32;
        }

-       /* FALL THROUGH */
+       /* FALLTHROUGH */

        case 'x':
            goto grow;
        case 'A':
        case 'x':
            goto grow;
        case 'A':


@@ -2541,7 +2552,15 @@ S_pack_rec(pTHX_ SV *cat, tempsym_t* symptr, SV **beglist, SV **endlist )
            while (len-- > 0) {
                IV aiv;
                fromstr = NEXTFROM;
            while (len-- > 0) {
                IV aiv;
                fromstr = NEXTFROM;

-               aiv = SvIV(fromstr);
+                if (SvNOK(fromstr) && Perl_isinfnan(SvNV(fromstr))) {
+                    /* 255 is a pretty arbitrary choice, but with
+                     * inf/-inf/nan and 256 bytes there is not much room. */
+                    aiv = 255;
+                   Perl_ck_warner(aTHX_ packWARN(WARN_PACK),
+                                  "Character in 'c' format overflow in pack");
+                }
+                else
+                    aiv = SvIV(fromstr);

                if ((-128 > aiv || aiv > 127))
                    Perl_ck_warner(aTHX_ packWARN(WARN_PACK),
                                   "Character in 'c' format wrapped in pack");
                if ((-128 > aiv || aiv > 127))
                    Perl_ck_warner(aTHX_ packWARN(WARN_PACK),
                                   "Character in 'c' format wrapped in pack");


@@ -2556,7 +2575,14 @@ S_pack_rec(pTHX_ SV *cat, tempsym_t* symptr, SV **beglist, SV **endlist )
            while (len-- > 0) {
                IV aiv;
                fromstr = NEXTFROM;
            while (len-- > 0) {
                IV aiv;
                fromstr = NEXTFROM;

-               aiv = SvIV(fromstr);
+                if (SvNOK(fromstr) && Perl_isinfnan(SvNV(fromstr))) {
+                    /* See the 'c' case. */
+                    aiv = 255;
+                   Perl_ck_warner(aTHX_ packWARN(WARN_PACK),
+                                  "Character in 'C' format overflow in pack");
+                }
+                else
+                    aiv = SvIV(fromstr);

                if ((0 > aiv || aiv > 0xff))
                    Perl_ck_warner(aTHX_ packWARN(WARN_PACK),
                                   "Character in 'C' format wrapped in pack");
                if ((0 > aiv || aiv > 0xff))
                    Perl_ck_warner(aTHX_ packWARN(WARN_PACK),
                                   "Character in 'C' format wrapped in pack");


@@ -2769,7 +2795,7 @@ S_pack_rec(pTHX_ SV *cat, tempsym_t* symptr, SV **beglist, SV **endlist )
            }
             break;
 #else
            }
             break;
 #else

-            /* Fall through! */
+            /* FALLTHROUGH */

 #endif
        case 'S':
            while (len-- > 0) {
 #endif
        case 'S':
            while (len-- > 0) {


@@ -2789,7 +2815,7 @@ S_pack_rec(pTHX_ SV *cat, tempsym_t* symptr, SV **beglist, SV **endlist )
            }
             break;
 #else
            }
             break;
 #else

-            /* Fall through! */
+            /* FALLTHROUGH */

 #endif
        case 's':
            while (len-- > 0) {
 #endif
        case 's':
            while (len-- > 0) {


@@ -3001,7 +3027,7 @@ S_pack_rec(pTHX_ SV *cat, tempsym_t* symptr, SV **beglist, SV **endlist )
        case 'P':
            len = 1;            /* assume SV is correct length */
            GROWING(utf8, cat, start, cur, sizeof(char *));
        case 'P':
            len = 1;            /* assume SV is correct length */
            GROWING(utf8, cat, start, cur, sizeof(char *));

-           /* Fall through! */
+           /* FALLTHROUGH */

        case 'p':
            while (len-- > 0) {
                const char *aptr;
        case 'p':
            while (len-- > 0) {
                const char *aptr;


@@ -3089,7 +3115,7 @@ S_pack_rec(pTHX_ SV *cat, tempsym_t* symptr, SV **beglist, SV **endlist )
 
 PP(pp_pack)
 {
 
 PP(pp_pack)
 {

-    dVAR; dSP; dMARK; dORIGMARK; dTARGET;
+    dSP; dMARK; dORIGMARK; dTARGET;

     SV *cat = TARG;
     STRLEN fromlen;
     SV *pat_sv = *++MARK;
     SV *cat = TARG;
     STRLEN fromlen;
     SV *pat_sv = *++MARK;