perl: fix int64_t unpacking in both XS and PP

1 files changed, 41 insertions, 26 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;