From: Nicholas Clark <nick@ccl4.org>
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<perlsub>.
 
+=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<perlfunc/pack>.
+
+=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<perlfunc/pack>.
+
+=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<perlfunc/pack>.
+
 =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%)");
+  }
+
 }
 
 #