another pack "w" thing

Message-ID: <20020316215215.GF330@Bagpuss.unfortu.net>

p4raw-id: //depot/perl@15287

2 files changed, 28 insertions, 15 deletions

diff --git a/pp_pack.c b/pp_pack.c
index 51b8772bc9..b653362039 100644
--- a/pp_pack.c
+++ b/pp_pack.c
@@ -2163,26 +2163,21 @@ Perl_pack_cat(pTHX_ SV *cat, char *pat, register char *patend, register SV **beg
 	case 'w':
             while (len-- > 0) {
 		fromstr = NEXTFROM;
-		adouble = Perl_floor(SvNV(fromstr));
+		adouble = SvNV(fromstr);
 
 		if (adouble < 0)
 		    Perl_croak(aTHX_ "Cannot compress negative numbers");
 
-		if (
-#if UVSIZE > 4 && UVSIZE >= NVSIZE
-		    adouble <= 0xffffffff
-#else
-#   ifdef CXUX_BROKEN_CONSTANT_CONVERT
-		    adouble <= UV_MAX_cxux
-#   else
-		    adouble <= UV_MAX
-#   endif
-#endif
-		    )
+                /* 0xFFFFFFFFFFFFFFFF may cast to 18446744073709551616.0,
+                   which is == UV_MAX_P1. IOK is fine (instead of UV_only), as
+                   any negative IVs will have already been got by the croak()
+                   above. IOK is untrue for fractions, so we test them
+                   against UV_MAX_P1.  */
+		if (SvIOK(fromstr) || adouble < UV_MAX_P1)
 		{
 		    char   buf[1 + sizeof(UV)];
 		    char  *in = buf + sizeof(buf);
-		    UV     auv = U_V(adouble);
+		    UV     auv = SvUV(fromstr);
 
 		    do {
 			*--in = (auv & 0x7f) | 0x80;
@@ -2216,6 +2211,7 @@ Perl_pack_cat(pTHX_ SV *cat, char *pat, register char *patend, register SV **beg
 		    char   buf[sizeof(double) * 2];	/* 8/7 <= 2 */
 		    char  *in = buf + sizeof(buf);
 
+                    adouble = Perl_floor(adouble);
 		    do {
 			double next = floor(adouble / 128);
 			*--in = (unsigned char)(adouble - (next * 128)) | 0x80;
diff --git a/t/op/pack.t b/t/op/pack.t
index 6b812363b2..20fdb37eb7 100755
--- a/t/op/pack.t
+++ b/t/op/pack.t
@@ -6,7 +6,7 @@ BEGIN {
     require './test.pl';
 }
 
-plan tests => 5619;
+plan tests => 5625;
 
 use strict;
 use warnings;
@@ -122,11 +122,28 @@ sub list_eq ($$) {
     $y = pack('w*', Math::BigInt::->new(5000000000));
     };
     is($x, $y);
+
+    $x = pack 'w', ~0;
+    $y = pack 'w', (~0).'';
+    is($x, $y);
+    is(unpack ('w',$x), ~0);
+    is(unpack ('w',$y), ~0);
+
+    $x = pack 'w', ~0 - 1;
+    $y = pack 'w', (~0) - 2;
+
+    if (~0 - 1 == (~0) - 2) {
+        is($x, $y, "NV arithmetic");
+    } else {
+        isnt($x, $y, "IV/NV arithmetic");
+    }
+    cmp_ok(unpack ('w',$x), '==', ~0 - 1);
+    cmp_ok(unpack ('w',$y), '==', ~0 - 2);
 }
 
 
 {
-  # test exeptions
+  # test exceptions
   my $x;
   eval { $x = unpack 'w', pack 'C*', 0xff, 0xff};
   like($@, qr/^Unterminated compressed integer/);