perl: fix int64_t unpacking in both XS and PP

3 files changed, 86 insertions, 37 deletions

diff --git a/perl/lib/Data/MessagePack/PP.pm b/perl/lib/Data/MessagePack/PP.pm
index abb6e9a..c3ce230 100644
--- a/perl/lib/Data/MessagePack/PP.pm
+++ b/perl/lib/Data/MessagePack/PP.pm
@@ -16,12 +16,44 @@ use strict;
 use B ();
 
 BEGIN {
+    my $unpack_int64_slow;
+    my $unpack_uint64_slow;
+
+    if(!eval { pack 'Q', 1 }) { # don't have quad types
+        $unpack_int64_slow = sub {
+            require Math::BigInt;
+            my $high = Math::BigInt->new( unpack_int32(  $_[0], $_[1]) );
+            my $low  = Math::BigInt->new( unpack_uint32( $_[0], $_[1] + 4) );
+
+            return +($high << 32 | $low)->bstr;
+        };
+        $unpack_uint64_slow = sub {
+            require Math::BigInt;
+            my $high = Math::BigInt->new( unpack_uint32(  $_[0], $_[1]) );
+            my $low  = Math::BigInt->new( unpack_uint32( $_[0], $_[1] + 4) );
+            return +($high << 32 | $low)->bstr;
+        };
+    }
+
+    *unpack_uint16 = sub { return unpack 'n', substr( $_[0], $_[1], 2 ) };
+    *unpack_uint32 = sub { return unpack 'N', substr( $_[0], $_[1], 4 ) };
+
     # for pack and unpack compatibility
     if ( $] < 5.010 ) {
         # require $Config{byteorder}; my $bo_is_le = ( $Config{byteorder} =~ /^1234/ );
         # which better?
         my $bo_is_le = unpack ( 'd', "\x00\x00\x00\x00\x00\x00\xf0\x3f") == 1; # 1.0LE
 
+        *unpack_int16  = sub {
+            my $v = unpack 'n', substr( $_[0], $_[1], 2 );
+            return $v ? $v - 0x10000 : 0;
+        };
+        *unpack_int32  = sub {
+            no warnings; # avoid for warning about Hexadecimal number
+            my $v = unpack 'N', substr( $_[0], $_[1], 4 );
+            return $v ? $v - 0x100000000 : 0;
+        };
+
         # In reality, since 5.9.2 '>' is introduced. but 'n!' and 'N!'?
         if($bo_is_le) {
             *pack_uint64 = sub {
@@ -46,20 +78,11 @@ BEGIN {
                 return unpack( 'd', pack( 'N2', @v[1,0] ) );
             };
 
-            *unpack_int16  = sub {
-                my $v = unpack 'n', substr( $_[0], $_[1], 2 );
-                return $v ? $v - 0x10000 : 0;
-            };
-            *unpack_int32  = sub {
-                no warnings; # avoid for warning about Hexadecimal number
-                my $v = unpack 'N', substr( $_[0], $_[1], 4 );
-                return $v ? $v - 0x100000000 : 0;
-            };
-            *unpack_int64 = sub {
+            *unpack_int64 = $unpack_int64_slow ||_sub {
                 my @v = unpack( 'V*', substr( $_[0], $_[1], 8 ) );
                 return unpack( 'q', pack( 'N2', @v[1,0] ) );
             };
-            *unpack_uint64 = sub {
+            *unpack_uint64 = $unpack_uint64_slow || sub {
                 my @v = unpack( 'V*', substr( $_[0], $_[1], 8 ) );
                 return unpack( 'Q', pack( 'N2', @v[1,0] ) );
             };
@@ -71,17 +94,8 @@ BEGIN {
 
             *unpack_float  = sub { return unpack( 'f', substr( $_[0], $_[1], 4 ) ); };
             *unpack_double = sub { return unpack( 'd', substr( $_[0], $_[1], 8 ) ); };
-            *unpack_int16  = sub {
-                my $v = unpack 'n', substr( $_[0], $_[1], 2 );
-                return $v ? $v - 0x10000 : 0;
-            };
-            *unpack_int32  = sub {
-                no warnings; # avoid for warning about Hexadecimal number
-                my $v = unpack 'N', substr( $_[0], $_[1], 4 );
-                return $v ? $v - 0x100000000 : 0;
-            };
-            *unpack_int64  = sub { pack 'q', substr( $_[0], $_[1], 8 ); };
-            *unpack_uint64 = sub { pack 'Q', substr( $_[0], $_[1], 8 ); };
+            *unpack_int64  = $unpack_int64_slow  || sub { pack 'q', substr( $_[0], $_[1], 8 ); };
+            *unpack_uint64 = $unpack_uint64_slow || sub { pack 'Q', substr( $_[0], $_[1], 8 ); };
         }
     }
     else {
@@ -93,8 +107,9 @@ BEGIN {
         *unpack_double = sub { return unpack( 'd>', substr( $_[0], $_[1], 8 ) ); };
         *unpack_int16  = sub { return unpack( 'n!', substr( $_[0], $_[1], 2 ) ); };
         *unpack_int32  = sub { return unpack( 'N!', substr( $_[0], $_[1], 4 ) ); };
-        *unpack_int64  = sub { return unpack( 'q>', substr( $_[0], $_[1], 8 ) ); };
-        *unpack_uint64 = sub { return unpack( 'Q>', substr( $_[0], $_[1], 8 ) ); };
+
+        *unpack_int64  = $unpack_int64_slow  || sub { return unpack( 'q>', substr( $_[0], $_[1], 8 ) ); };
+        *unpack_uint64 = $unpack_uint64_slow || sub { return unpack( 'Q>', substr( $_[0], $_[1], 8 ) ); };
     }
 }
 
@@ -283,11 +298,11 @@ sub _unpack {
     }
     elsif ( $byte == 0xcd ) { # uint16
         $p += 2;
-        return CORE::unpack 'n', substr( $value, $p - 2, 2 );
+        return unpack_uint16( $value, $p - 2 );
     }
     elsif ( $byte == 0xce ) { # unit32
         $p += 4;
-        return CORE::unpack 'N', substr( $value, $p - 4, 4 );
+        return unpack_uint32( $value, $p - 4 );
     }
     elsif ( $byte == 0xcf ) { # unit64
         $p += 8;
diff --git a/perl/t/data.pl b/perl/t/data.pl
index 2f58d38..8ffd25a 100644
--- a/perl/t/data.pl
+++ b/perl/t/data.pl
@@ -5,14 +5,34 @@ no warnings; # i need this, i need this.
     '92 90 91 91 c0', [[], [[undef]]],
     '93 c0 c2 c3', [undef, false, true],
     'ce 80 00 00 00', 2147483648,
-    '99 cc 00 cc 80 cc ff cd 00 00 cd 80 00 cd ff ff ce 00 00 00 00 ce 80 00 00 00 ce ff ff ff ff', [0, 128, 255, 0, 32768, 65535, 0, 2147483648, 4294967295],
+    '99 cc 00 cc 80 cc ff cd 00 00 cd 80 00 cd ff ff ce 00 00 00 00 ce 80 00 00 00 ce ff ff ff ff',
+        [0, 128, 255, 0, 32768, 65535, 0, 2147483648, 4294967295],
     '92 93 00 40 7f 93 e0 f0 ff', [[0, 64, 127], [-32, -16, -1]],
-    '96 dc 00 00 dc 00 01 c0 dc 00 02 c2 c3 dd 00 00 00 00 dd 00 00 00 01 c0 dd 00 00 00 02 c2 c3', [[], [undef], [false, true], [], [undef], [false, true]],
-    '96 da 00 00 da 00 01 61 da 00 02 61 62 db 00 00 00 00 db 00 00 00 01 61 db 00 00 00 02 61 62', ["", "a", "ab", "", "a", "ab"],
-    '99 d0 00 d0 80 d0 ff d1 00 00 d1 80 00 d1 ff ff d2 00 00 00 00 d2 80 00 00 00 d2 ff ff ff ff', [0, -128, -1, 0, -32768, -1, 0, -2147483648, -1],
+    '96 dc 00 00 dc 00 01 c0 dc 00 02 c2 c3 dd 00 00 00 00 dd 00 00 00 01 c0 dd 00 00 00 02 c2 c3',
+        [[], [undef], [false, true], [], [undef], [false, true]],
+    '96 da 00 00 da 00 01 61 da 00 02 61 62 db 00 00 00 00 db 00 00 00 01 61 db 00 00 00 02 61 62',
+        ["", "a", "ab", "", "a", "ab"],
+    '99 d0 00 d0 80 d0 ff d1 00 00 d1 80 00 d1 ff ff d2 00 00 00 00 d2 80 00 00 00 d2 ff ff ff ff',
+        [0, -128, -1, 0, -32768, -1, 0, -2147483648, -1],
     '82 c2 81 c0 c0 c3 81 c0 80', {false,{undef,undef}, true,{undef,{}}},
-    '96 de 00 00 de 00 01 c0 c2 de 00 02 c0 c2 c3 c2 df 00 00 00 00 df 00 00 00 01 c0 c2 df 00 00 00 02 c0 c2 c3 c2', [{}, {undef,false}, {true,false, undef,false}, {}, {undef,false}, {true,false, undef,false}],
+    '96 de 00 00 de 00 01 c0 c2 de 00 02 c0 c2 c3 c2 df 00 00 00 00 df 00 00 00 01 c0 c2 df 00 00 00 02 c0 c2 c3 c2',
+        [{}, {undef,false}, {true,false, undef,false}, {}, {undef,false}, {true,false, undef,false}],
     'ce 00 ff ff ff' => ''.0xFFFFFF,
     'aa 34 32 39 34 39 36 37 32 39 35' => ''.0xFFFFFFFF,
     'ab 36 38 37 31 39 34 37 36 37 33 35' => ''.0xFFFFFFFFF,
+
+    'd2 80 00 00 01' => '-2147483647', # int32_t
+    'ce 80 00 00 01' => '2147483649',  # uint32_t
+
+    'd2 ff ff ff ff' => '-1',          # int32_t
+    'ce ff ff ff ff' => '4294967295',  # uint32_t
+
+    'd3 00 00 00 00 80 00 00 01' => '2147483649', # int64_t
+    'cf 00 00 00 00 80 00 00 01' => '2147483649',  # uint64_t
+
+    'd3 ff 00 ff ff ff ff ff ff' => '-71776119061217281',    # int64_t
+    'cf ff 00 ff ff ff ff ff ff' => '18374967954648334335',  # uint64_t
+
+    'd3 ff ff ff ff ff ff ff ff' => '-1',                    # int64_t
+    'cf ff ff ff ff ff ff ff ff' => '18446744073709551615',  # uint64_t
 )
diff --git a/perl/xs-src/unpack.c b/perl/xs-src/unpack.c
index e89b22c..fefb52e 100644
--- a/perl/xs-src/unpack.c
+++ b/perl/xs-src/unpack.c
@@ -102,24 +102,38 @@ STATIC_INLINE int template_callback_UV(unpack_user* u PERL_UNUSED_DECL, UV const
     return 0;
 }
 
-STATIC_INLINE int template_callback_uint64(unpack_user* u PERL_UNUSED_DECL, uint64_t const d, SV** o)
+STATIC_INLINE int template_callback_IV(unpack_user* u PERL_UNUSED_DECL, IV const d, SV** o)
 {
     dTHX;
-    *o = newSVnv((NV)d);
+    *o = newSViv(d);
     return 0;
 }
 
-STATIC_INLINE int template_callback_IV(unpack_user* u PERL_UNUSED_DECL, IV const d, SV** o)
+static int template_callback_uint64(unpack_user* u PERL_UNUSED_DECL, uint64_t const d, SV** o)
 {
     dTHX;
-    *o = newSViv(d);
+    if((uint64_t)(NV)d == d) {
+        *o = newSVnv((NV)d);
+    }
+    else {
+        char tbuf[64];
+        STRLEN const len = my_snprintf(tbuf, sizeof(tbuf), "%llu", d);
+        *o = newSVpvn(tbuf, len);
+    }
     return 0;
 }
 
-STATIC_INLINE int template_callback_int64(unpack_user* u PERL_UNUSED_DECL, int64_t const d, SV** o)
+static int template_callback_int64(unpack_user* u PERL_UNUSED_DECL, int64_t const d, SV** o)
 {
     dTHX;
-    *o = newSVnv((NV)d);
+    if((uint64_t)(NV)d == (uint64_t)d) {
+        *o = newSVnv((NV)d);
+    }
+    else {
+        char tbuf[64];
+        STRLEN const len = my_snprintf(tbuf, sizeof(tbuf), "%lld", d);
+        *o = newSVpvn(tbuf, len);
+    }
     return 0;
 }