From: Nicholas Clark Date: Tue, 8 Oct 2002 21:52:53 +0000 (+0100) Subject: Re: [perl #17772] pack "w" /* this cannot happen ;-) */ is fallacious X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=0258719bae4c02bba26598151f1f335a54f43190;p=p5sagit%2Fp5-mst-13.2.git Re: [perl #17772] pack "w" /* this cannot happen ;-) */ is fallacious Message-ID: <20021008205253.GA283@Bagpuss.unfortu.net> p4raw-id: //depot/perl@18010 --- diff --git a/pod/perldiag.pod b/pod/perldiag.pod index d0626bf..4e7ff06 100644 --- a/pod/perldiag.pod +++ b/pod/perldiag.pod @@ -466,6 +466,24 @@ checking. Alternatively, if you are certain that you're calling the function correctly, you may put an ampersand before the name to avoid the warning. See L. +=item Can only compress unsigned integers + +(F) An argument to pack("w",...) was not an integer. The BER compressed +integer format can only be used with positive integers, and you attempted +to compress something else. See L. + +=item Cannot compress integer + +(F) An argument to pack("w",...) was too large to compress. The BER +compressed integer format can only be used with positive integers, and you +attempted to compress Infinity or a very large number (> 1e308). +See L. + +=item Cannot compress negative numbers + +(F) An argument to pack("w",...) was negative. The BER compressed integer +format can only be used with positive integers. See L. + =item / cannot take a count (F) You had an unpack template indicating a counted-length string, but diff --git a/pp_pack.c b/pp_pack.c index 486c4f7..4476454 100644 --- a/pp_pack.c +++ b/pp_pack.c @@ -2286,7 +2286,7 @@ Perl_pack_cat(pTHX_ SV *cat, char *pat, register char *patend, register SV **beg /* Copy string and check for compliance */ from = SvPV(fromstr, len); if ((norm = is_an_int(from, len)) == NULL) - Perl_croak(aTHX_ "can compress only unsigned integer"); + Perl_croak(aTHX_ "Can only compress unsigned integers"); New('w', result, len, char); in = result + len; @@ -2299,15 +2299,25 @@ Perl_pack_cat(pTHX_ SV *cat, char *pat, register char *patend, register SV **beg SvREFCNT_dec(norm); /* free norm */ } else if (SvNOKp(fromstr)) { - char buf[sizeof(NV) * 2]; /* 8/7 <= 2 */ + /* 10**NV_MAX_10_EXP is the largest power of 10 + so 10**(NV_MAX_10_EXP+1) is definately unrepresentable + given 10**(NV_MAX_10_EXP+1) == 128 ** x solve for x: + x = (NV_MAX_10_EXP+1) * log (10) / log (128) + And with that many bytes only Inf can overflow. + */ +#ifdef NV_MAX_10_EXP + char buf[1 + (int)((NV_MAX_10_EXP + 1) * 0.47456)]; +#else + char buf[1 + (int)((308 + 1) * 0.47456)]; +#endif char *in = buf + sizeof(buf); anv = Perl_floor(anv); do { NV next = Perl_floor(anv / 128); - *--in = (unsigned char)(anv - (next * 128)) | 0x80; if (in <= buf) /* this cannot happen ;-) */ Perl_croak(aTHX_ "Cannot compress integer"); + *--in = (unsigned char)(anv - (next * 128)) | 0x80; anv = next; } while (anv > 0); buf[sizeof(buf) - 1] &= 0x7f; /* clear continue bit */ @@ -2322,7 +2332,7 @@ Perl_pack_cat(pTHX_ SV *cat, char *pat, register char *patend, register SV **beg /* Copy string and check for compliance */ from = SvPV(fromstr, len); if ((norm = is_an_int(from, len)) == NULL) - Perl_croak(aTHX_ "can compress only unsigned integer"); + Perl_croak(aTHX_ "Can only compress unsigned integers"); New('w', result, len, char); in = result + len; diff --git a/t/op/pack.t b/t/op/pack.t index 1661da5..b7968df 100755 --- a/t/op/pack.t +++ b/t/op/pack.t @@ -6,7 +6,7 @@ BEGIN { require './test.pl'; } -plan tests => 5819; +plan tests => 5825; use strict; use warnings; @@ -170,6 +170,44 @@ sub list_eq ($$) { eval { $x = unpack 'w', pack 'C*', 0xff, 0xff, 0xff, 0xff, 0xff, 0xff, 0xff}; like($@, qr/^Unterminated compressed integer/); + + eval { $x = pack 'w', -1 }; + like ($@, qr/^Cannot compress negative numbers/); + + eval { $x = pack 'w', '1'x(1 + length ~0) . 'e0' }; + like ($@, qr/^Can only compress unsigned integers/); + + SKIP: { + # Is this a stupid thing to do on VMS, VOS and other unusual platforms? + my $inf = eval '2**10000'; + + skip "Couldn't generate infinity - got error '$@'" + unless defined $inf and $inf == $inf / 2; + + eval { $x = pack 'w', $inf }; + like ($@, qr/^Cannot compress integer/); + } + + SKIP: { + # This should be about the biggest thing possible on an IEEE double + my $big = eval '2**1023'; + + skip "Couldn't generate 2**1023 - got error '$@'" + unless defined $big and $big != $big / 2; + + eval { $x = pack 'w', $big }; + is ($@, '', "Should be able to pack 'w', $big # 2**1023"); + + my $y = eval {unpack 'w', $x}; + is ($@, '', + "Should be able to unpack 'w' the result of pack 'w', $big # 2**1023"); + + # I'm getting about 1e-16 on FreeBSD + my $quotient = int (100 * ($y - $big) / $big); + ok($quotient < 2 && $quotient > -2, + "Round trip pack, unpack 'w' of $big is withing 1% ($quotient%)"); + } + } #