another pack "w" thing

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

p4raw-id: //depot/perl@15287

diff --git a/pp_pack.c b/pp_pack.c
index 51b8772..b653362 100644 (file)
--- 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 6b81236..20fdb37 100755 (executable)
--- 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/);