diff options
| -rw-r--r-- | pod/perlfunc.pod | 21 | ||||
| -rw-r--r-- | pod/perltodo.pod | 4 | ||||
| -rw-r--r-- | pp_pack.c | 218 | ||||
| -rwxr-xr-x | t/op/pack.t | 31 |
4 files changed, 227 insertions, 47 deletions
diff --git a/pod/perlfunc.pod b/pod/perlfunc.pod index e0ca04f631..777f20a0ef 100644 --- a/pod/perlfunc.pod +++ b/pod/perlfunc.pod @@ -3151,9 +3151,19 @@ of values, as follows: integer values _and_ if Perl has been compiled to support those. Causes a fatal error otherwise.) + j A signed integer value (a Perl internal integer, IV). + J An unsigned integer value (a Perl internal unsigned integer, UV). + f A single-precision float in the native format. d A double-precision float in the native format. + F A floating point value in the native native format + (a Perl internal floating point value, NV). + D A long double-precision float in the native format. + (Long doubles are available only if your system supports long + double values _and_ if Perl has been compiled to support those. + Causes a fatal error otherwise.) + p A pointer to a null-terminated string. P A pointer to a structure (fixed-length string). @@ -3281,11 +3291,10 @@ The C</> template character allows packing and unpacking of strings where the packed structure contains a byte count followed by the string itself. You write I<length-item>C</>I<string-item>. -The I<length-item> can be any C<pack> template letter, -and describes how the length value is packed. -The ones likely to be of most use are integer-packing ones like -C<n> (for Java strings), C<w> (for ASN.1 or SNMP) -and C<N> (for Sun XDR). +The I<length-item> can be any C<pack> template letter, and describes +how the length value is packed. The ones likely to be of most use are +integer-packing ones like C<n> (for Java strings), C<w> (for ASN.1 or +SNMP) and C<N> (for Sun XDR). The I<string-item> must, at present, be C<"A*">, C<"a*"> or C<"Z*">. For C<unpack> the length of the string is obtained from the I<length-item>, @@ -3332,7 +3341,7 @@ not support long longs.) =item * -The integer formats C<s>, C<S>, C<i>, C<I>, C<l>, and C<L> +The integer formats C<s>, C<S>, C<i>, C<I>, C<l>, C<L>, C<j>, and C<J> are inherently non-portable between processors and operating systems because they obey the native byteorder and endianness. For example a 4-byte integer 0x12345678 (305419896 decimal) would be ordered natively diff --git a/pod/perltodo.pod b/pod/perltodo.pod index 8606f076b3..2f840555fb 100644 --- a/pod/perltodo.pod +++ b/pod/perltodo.pod @@ -303,10 +303,6 @@ properly on error. This is possible to do, but would be pretty messy to implement, as it would rely on even more sed hackery in F<perly.fixer>. -=head2 pack for IV, UVs, NVs, and long doubles - -j, J, g, G? - =head2 bitfields in pack =head2 Cross compilation @@ -293,6 +293,12 @@ S_measure_struct(pTHX_ char *pat, register char *patend) case 'I': size = sizeof(unsigned int); break; + case 'j': + size = IVSIZE; + break; + case 'J': + size = UVSIZE; + break; case 'l': #if LONGSIZE == SIZE32 size = SIZE32; @@ -325,13 +331,19 @@ S_measure_struct(pTHX_ char *pat, register char *patend) break; #endif case 'f': - case 'F': size = sizeof(float); break; case 'd': - case 'D': size = sizeof(double); break; + case 'F': + size = NVSIZE; + break; +#if defined(HAS_LONG_DOUBLE) && defined(USE_LONG_DOUBLE) + case 'D': + size = LONG_DOUBLESIZE; + break; +#endif } total += len * size; } @@ -430,15 +442,21 @@ Perl_unpack_str(pTHX_ char *pat, register char *patend, register char *s, char * float afloat; double adouble; I32 checksum = 0; - UV culong = 0; + UV cuv = 0; NV cdouble = 0.0; - const int bits_in_uv = 8 * sizeof(culong); + const int bits_in_uv = 8 * sizeof(cuv); int commas = 0; int star; /* 1 if count is *, -1 if no count given, -2 for / */ #ifdef PERL_NATINT_PACK int natint; /* native integer */ int unatint; /* unsigned native integer */ #endif + IV aiv; + UV auv; + NV anv; +#if defined(HAS_LONG_DOUBLE) && defined(USE_LONG_DOUBLE) + long double aldouble; +#endif bool do_utf8 = flags & UNPACK_DO_UTF8; while ((pat = next_symbol(pat, patend)) < patend) { @@ -488,7 +506,7 @@ Perl_unpack_str(pTHX_ char *pat, register char *patend, register char *s, char * if (len == 1 && pat[-1] != '1' && pat[-1] != ']') len = 16; /* len is not specified */ checksum = len; - culong = 0; + cuv = 0; cdouble = 0; continue; break; @@ -608,20 +626,20 @@ Perl_unpack_str(pTHX_ char *pat, register char *patend, register char *s, char * } } while (len >= 8) { - culong += PL_bitcount[*(unsigned char*)s++]; + cuv += PL_bitcount[*(unsigned char*)s++]; len -= 8; } if (len) { bits = *s; if (datumtype == 'b') { while (len-- > 0) { - if (bits & 1) culong++; + if (bits & 1) cuv++; bits >>= 1; } } else { while (len-- > 0) { - if (bits & 128) culong++; + if (bits & 128) cuv++; bits <<= 1; } } @@ -697,7 +715,7 @@ Perl_unpack_str(pTHX_ char *pat, register char *patend, register char *s, char * if (checksum > bits_in_uv) cdouble += (NV)aint; else - culong += aint; + cuv += aint; } } else { @@ -725,7 +743,7 @@ Perl_unpack_str(pTHX_ char *pat, register char *patend, register char *s, char * uchar_checksum: while (len-- > 0) { auint = *s++ & 255; - culong += auint; + cuv += auint; } } else { @@ -757,7 +775,7 @@ Perl_unpack_str(pTHX_ char *pat, register char *patend, register char *s, char * if (checksum > bits_in_uv) cdouble += (NV)auint; else - culong += auint; + cuv += auint; } } else { @@ -792,7 +810,7 @@ Perl_unpack_str(pTHX_ char *pat, register char *patend, register char *s, char * if (checksum > bits_in_uv) cdouble += (NV)ashort; else - culong += ashort; + cuv += ashort; } } @@ -809,7 +827,7 @@ Perl_unpack_str(pTHX_ char *pat, register char *patend, register char *s, char * if (checksum > bits_in_uv) cdouble += (NV)ashort; else - culong += ashort; + cuv += ashort; } } } @@ -865,7 +883,7 @@ Perl_unpack_str(pTHX_ char *pat, register char *patend, register char *s, char * if (checksum > bits_in_uv) cdouble += (NV)aushort; else - culong += aushort; + cuv += aushort; } } else @@ -885,7 +903,7 @@ Perl_unpack_str(pTHX_ char *pat, register char *patend, register char *s, char * if (checksum > bits_in_uv) cdouble += (NV)aushort; else - culong += aushort; + cuv += aushort; } } } @@ -935,7 +953,7 @@ Perl_unpack_str(pTHX_ char *pat, register char *patend, register char *s, char * if (checksum > bits_in_uv) cdouble += (NV)aint; else - culong += aint; + cuv += aint; } } else { @@ -986,7 +1004,7 @@ Perl_unpack_str(pTHX_ char *pat, register char *patend, register char *s, char * if (checksum > bits_in_uv) cdouble += (NV)auint; else - culong += auint; + cuv += auint; } } else { @@ -1008,6 +1026,58 @@ Perl_unpack_str(pTHX_ char *pat, register char *patend, register char *s, char * } } break; + case 'j': + along = (strend - s) / IVSIZE; + if (len > along) + len = along; + if (checksum) { + while (len-- > 0) { + Copy(s, &aiv, 1, IV); + s += IVSIZE; + if (checksum > bits_in_uv) + cdouble += (NV)aiv; + else + cuv += aiv; + } + } + else { + EXTEND(SP, len); + EXTEND_MORTAL(len); + while (len-- > 0) { + Copy(s, &aiv, 1, IV); + s += IVSIZE; + sv = NEWSV(40, 0); + sv_setiv(sv, aiv); + PUSHs(sv_2mortal(sv)); + } + } + break; + case 'J': + along = (strend - s) / UVSIZE; + if (len > along) + len = along; + if (checksum) { + while (len-- > 0) { + Copy(s, &auv, 1, UV); + s += UVSIZE; + if (checksum > bits_in_uv) + cdouble += (NV)auv; + else + cuv += auv; + } + } + else { + EXTEND(SP, len); + EXTEND_MORTAL(len); + while (len-- > 0) { + Copy(s, &auv, 1, UV); + s += UVSIZE; + sv = NEWSV(41, 0); + sv_setuv(sv, auv); + PUSHs(sv_2mortal(sv)); + } + } + break; case 'l': #if LONGSIZE == SIZE32 along = (strend - s) / SIZE32; @@ -1025,7 +1095,7 @@ Perl_unpack_str(pTHX_ char *pat, register char *patend, register char *s, char * if (checksum > bits_in_uv) cdouble += (NV)along; else - culong += along; + cuv += along; } } else @@ -1044,7 +1114,7 @@ Perl_unpack_str(pTHX_ char *pat, register char *patend, register char *s, char * if (checksum > bits_in_uv) cdouble += (NV)along; else - culong += along; + cuv += along; } } } @@ -1102,7 +1172,7 @@ Perl_unpack_str(pTHX_ char *pat, register char *patend, register char *s, char * if (checksum > bits_in_uv) cdouble += (NV)aulong; else - culong += aulong; + cuv += aulong; } } else @@ -1122,7 +1192,7 @@ Perl_unpack_str(pTHX_ char *pat, register char *patend, register char *s, char * if (checksum > bits_in_uv) cdouble += (NV)aulong; else - culong += aulong; + cuv += aulong; } } } @@ -1250,7 +1320,7 @@ Perl_unpack_str(pTHX_ char *pat, register char *patend, register char *s, char * if (checksum > bits_in_uv) cdouble += (NV)aquad; else - culong += aquad; + cuv += aquad; } } else { @@ -1260,12 +1330,12 @@ Perl_unpack_str(pTHX_ char *pat, register char *patend, register char *s, char * if (s + sizeof(Quad_t) > strend) aquad = 0; else { - Copy(s, &aquad, 1, Quad_t); - s += sizeof(Quad_t); + Copy(s, &aquad, 1, Quad_t); + s += sizeof(Quad_t); } sv = NEWSV(42, 0); if (aquad >= IV_MIN && aquad <= IV_MAX) - sv_setiv(sv, (IV)aquad); + sv_setiv(sv, (IV)aquad); else sv_setnv(sv, (NV)aquad); PUSHs(sv_2mortal(sv)); @@ -1283,7 +1353,7 @@ Perl_unpack_str(pTHX_ char *pat, register char *patend, register char *s, char * if (checksum > bits_in_uv) cdouble += (NV)auquad; else - culong += auquad; + cuv += auquad; } } else { @@ -1308,7 +1378,6 @@ Perl_unpack_str(pTHX_ char *pat, register char *patend, register char *s, char * #endif /* float and double added gnb@melba.bby.oz.au 22/11/89 */ case 'f': - case 'F': along = (strend - s) / sizeof(float); if (len > along) len = along; @@ -1332,7 +1401,6 @@ Perl_unpack_str(pTHX_ char *pat, register char *patend, register char *s, char * } break; case 'd': - case 'D': along = (strend - s) / sizeof(double); if (len > along) len = along; @@ -1355,6 +1423,54 @@ Perl_unpack_str(pTHX_ char *pat, register char *patend, register char *s, char * } } break; + case 'F': + along = (strend - s) / NVSIZE; + if (len > along) + len = along; + if (checksum) { + while (len-- > 0) { + Copy(s, &anv, 1, NV); + s += NVSIZE; + cdouble += anv; + } + } + else { + EXTEND(SP, len); + EXTEND_MORTAL(len); + while (len-- > 0) { + Copy(s, &anv, 1, NV); + s += NVSIZE; + sv = NEWSV(48, 0); + sv_setnv(sv, anv); + PUSHs(sv_2mortal(sv)); + } + } + break; +#if defined(HAS_LONG_DOUBLE) && defined(USE_LONG_DOUBLE) + case 'D': + along = (strend - s) / LONG_DOUBLESIZE; + if (len > along) + len = along; + if (checksum) { + while (len-- > 0) { + Copy(s, &aldouble, 1, long double); + s += LONG_DOUBLESIZE; + cdouble += aldouble; + } + } + else { + EXTEND(SP, len); + EXTEND_MORTAL(len); + while (len-- > 0) { + Copy(s, &aldouble, 1, long double); + s += LONG_DOUBLESIZE; + sv = NEWSV(48, 0); + sv_setnv(sv, (NV)aldouble); + PUSHs(sv_2mortal(sv)); + } + } + break; +#endif case 'u': /* MKS: * Initialise the decode mapping. By using a table driven @@ -1417,7 +1533,8 @@ Perl_unpack_str(pTHX_ char *pat, register char *patend, register char *s, char * if (checksum) { sv = NEWSV(42, 0); if (strchr("fFdD", datumtype) || - (checksum > bits_in_uv && strchr("csSiIlLnNUvVqQ", datumtype)) ) { + (checksum > bits_in_uv && + strchr("csSiIlLnNUvVqQjJ", datumtype)) ) { NV trouble; adouble = (NV) (1 << (checksum & 15)); @@ -1433,9 +1550,10 @@ Perl_unpack_str(pTHX_ char *pat, register char *patend, register char *s, char * else { if (checksum < bits_in_uv) { UV mask = ((UV)1 << checksum) - 1; - culong &= mask; + + cuv &= mask; } - sv_setuv(sv, (UV)culong); + sv_setuv(sv, cuv); } XPUSHs(sv_2mortal(sv)); checksum = 0; @@ -1610,6 +1728,12 @@ Perl_pack_cat(pTHX_ SV *cat, char *pat, register char *patend, register SV **beg unsigned int auint; I32 along; U32 aulong; + IV aiv; + UV auv; + NV anv; +#if defined(HAS_LONG_DOUBLE) && defined(USE_LONG_DOUBLE) + long double aldouble; +#endif #ifdef HAS_QUAD Quad_t aquad; Uquad_t auquad; @@ -1920,7 +2044,6 @@ Perl_pack_cat(pTHX_ SV *cat, char *pat, register char *patend, register SV **beg break; /* Float and double added by gnb@melba.bby.oz.au 22/11/89 */ case 'f': - case 'F': while (len-- > 0) { fromstr = NEXTFROM; afloat = (float)SvNV(fromstr); @@ -1928,13 +2051,28 @@ Perl_pack_cat(pTHX_ SV *cat, char *pat, register char *patend, register SV **beg } break; case 'd': - case 'D': while (len-- > 0) { fromstr = NEXTFROM; adouble = (double)SvNV(fromstr); sv_catpvn(cat, (char *)&adouble, sizeof (double)); } break; + case 'F': + while (len-- > 0) { + fromstr = NEXTFROM; + anv = SvNV(fromstr); + sv_catpvn(cat, (char *)&anv, NVSIZE); + } + break; +#if defined(HAS_LONG_DOUBLE) && defined(USE_LONG_DOUBLE) + case 'D': + while (len-- > 0) { + fromstr = NEXTFROM; + aldouble = (long double)SvNV(fromstr); + sv_catpvn(cat, (char *)&aldouble, LONG_DOUBLESIZE); + } + break; +#endif case 'n': while (len-- > 0) { fromstr = NEXTFROM; @@ -2007,6 +2145,20 @@ Perl_pack_cat(pTHX_ SV *cat, char *pat, register char *patend, register SV **beg sv_catpvn(cat, (char*)&auint, sizeof(unsigned int)); } break; + case 'j': + while (len-- > 0) { + fromstr = NEXTFROM; + aiv = SvIV(fromstr); + sv_catpvn(cat, (char*)&aiv, IVSIZE); + } + break; + case 'J': + while (len-- > 0) { + fromstr = NEXTFROM; + auv = SvUV(fromstr); + sv_catpvn(cat, (char*)&auv, UVSIZE); + } + break; case 'w': while (len-- > 0) { fromstr = NEXTFROM; diff --git a/t/op/pack.t b/t/op/pack.t index f21793420c..0782d46855 100755 --- a/t/op/pack.t +++ b/t/op/pack.t @@ -6,7 +6,7 @@ BEGIN { require './test.pl'; } -plan tests => 5179; +plan tests => 5619; use strict; use warnings; @@ -751,13 +751,19 @@ foreach ( } { # Repeat count [SUBEXPR] - my @codes = qw( x A Z a c C B b H h s v n S i I l V N L p P f F d D - s! S! i! I! l! L! ); + my @codes = qw( x A Z a c C B b H h s v n S i I l V N L p P f F d + s! S! i! I! l! L! j J); + my $G; if (eval { pack 'q', 1 } ) { push @codes, qw(q Q); } else { push @codes, qw(c C); # Keep the count the same } + if (eval { pack 'D', 1 } ) { + push @codes, 'D'; + } else { + push @codes, 'd'; # Keep the count the same + } my %val; @val{@codes} = map { / [Xx] (?{ undef }) @@ -766,7 +772,7 @@ foreach ( | c (?{ 114 }) | [Bb] (?{ '101' }) | [Hh] (?{ 'b8' }) - | [svnSiIlVNLqQ] (?{ 10111 }) + | [svnSiIlVNLqQjJ] (?{ 10111 }) | [FfDd] (?{ 1.36514538e67 }) | [pP] (?{ "try this buffer" }) /x; $^R } @codes; @@ -846,3 +852,20 @@ is(scalar unpack('A /A /A Z20', '3004bcde'), 'bcde'); is(scalar @b, scalar @a); is("@b", "@a"); } + +is(length(pack("j", 0)), $Config{ivsize}); +is(length(pack("J", 0)), $Config{uvsize}); +is(length(pack("F", 0)), $Config{nvsize}); + +numbers ('j', -2147483648, -1, 0, 1, 2147483647); +numbers ('J', 0, 1, 2147483647, 2147483648, 4294967295); +numbers ('F', -(2**34), -1, 0, 1, 2**34); +SKIP: { + my $t = eval { unpack("D*", pack("D", 12.34)) }; + + skip "Long doubles not in use", 56 if $@ =~ /Invalid type in pack/; + + is(length(pack("D", 0)), $Config{longdblsize}); + numbers ('D', -(2**34), -1, 0, 1, 2**34); +} + |