generic-library/msgpack
1
0
Fork 0
mirror of https://github.com/msgpack/msgpack-c.git synced 2025-05-02 07:31:38 +02:00
Code Issues Projects Releases Wiki Activity

perl: fix int64_t unpacking in both XS and PP

Browse Source
This commit is contained in:
gfx 2010-09-18 14:30:08 +09:00
parent 1f07721ec4
commit c707392a5a
3 changed files with 89 additions and 40 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

67
perl/lib/Data/MessagePack/PP.pm
View File

@ -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;

30
perl/t/data.pl
View File

@ -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
)

32
perl/xs-src/unpack.c
View File

@ -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;
}