From c707392a5a9307504595f6fb9f11930a6a514531 Mon Sep 17 00:00:00 2001 From: gfx Date: Sat, 18 Sep 2010 14:30:08 +0900 Subject: [PATCH] perl: fix int64_t unpacking in both XS and PP --- perl/lib/Data/MessagePack/PP.pm | 67 ++++++++++++++++++++------------- perl/t/data.pl | 30 ++++++++++++--- perl/xs-src/unpack.c | 32 +++++++++++----- 3 files changed, 89 insertions(+), 40 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,13 +102,6 @@ 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) -{ - dTHX; - *o = newSVnv((NV)d); - return 0; -} - STATIC_INLINE int template_callback_IV(unpack_user* u PERL_UNUSED_DECL, IV const d, SV** o) { dTHX; @@ -116,10 +109,31 @@ STATIC_INLINE int template_callback_IV(unpack_user* u PERL_UNUSED_DECL, IV const return 0; } -STATIC_INLINE int template_callback_int64(unpack_user* u PERL_UNUSED_DECL, int64_t const d, SV** o) +static int template_callback_uint64(unpack_user* u PERL_UNUSED_DECL, uint64_t const d, SV** o) { dTHX; - *o = newSVnv((NV)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 int template_callback_int64(unpack_user* u PERL_UNUSED_DECL, int64_t const d, SV** o) +{ + dTHX; + 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; }