From 4767e450351dfbc807e5346ceaa4252bd99ae866 Mon Sep 17 00:00:00 2001 From: gfx Date: Sat, 18 Sep 2010 13:18:25 +0900 Subject: [PATCH 01/20] perl: fix a test name --- perl/t/{12_stream_unpack3.t => 12_stream_unpack4.t} | 0 1 file changed, 0 insertions(+), 0 deletions(-) rename perl/t/{12_stream_unpack3.t => 12_stream_unpack4.t} (100%) diff --git a/perl/t/12_stream_unpack3.t b/perl/t/12_stream_unpack4.t similarity index 100% rename from perl/t/12_stream_unpack3.t rename to perl/t/12_stream_unpack4.t From 1f07721ec41147e02fa49aea19a3f6aa7b1eb723 Mon Sep 17 00:00:00 2001 From: gfx Date: Sat, 18 Sep 2010 13:33:27 +0900 Subject: [PATCH 02/20] perl: Scalar::Util is no longer used --- perl/lib/Data/MessagePack/PP.pm | 1 - 1 file changed, 1 deletion(-) diff --git a/perl/lib/Data/MessagePack/PP.pm b/perl/lib/Data/MessagePack/PP.pm index 0dd6427..abb6e9a 100644 --- a/perl/lib/Data/MessagePack/PP.pm +++ b/perl/lib/Data/MessagePack/PP.pm @@ -12,7 +12,6 @@ use Carp (); package Data::MessagePack; -use Scalar::Util qw( blessed ); use strict; use B (); From c707392a5a9307504595f6fb9f11930a6a514531 Mon Sep 17 00:00:00 2001 From: gfx Date: Sat, 18 Sep 2010 14:30:08 +0900 Subject: [PATCH 03/20] 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; } From a86c1624a70b8f8a5012065019d9f1ba4b44595b Mon Sep 17 00:00:00 2001 From: gfx Date: Sat, 18 Sep 2010 14:38:35 +0900 Subject: [PATCH 04/20] perl: More kind error messages in PP --- perl/lib/Data/MessagePack/PP.pm | 19 +++++++++++-------- perl/t/50_leaktrace.t | 6 +++++- 2 files changed, 16 insertions(+), 9 deletions(-) diff --git a/perl/lib/Data/MessagePack/PP.pm b/perl/lib/Data/MessagePack/PP.pm index c3ce230..31c0833 100644 --- a/perl/lib/Data/MessagePack/PP.pm +++ b/perl/lib/Data/MessagePack/PP.pm @@ -113,6 +113,9 @@ BEGIN { } } +sub _unexpected { + Carp::confess("Unexpected " . sprintf(shift, @_) . " found"); +} # # PACK @@ -141,7 +144,7 @@ sub _pack { $num < 16 ? CORE::pack( 'C', 0x90 + $num ) : $num < 2 ** 16 - 1 ? CORE::pack( 'Cn', 0xdc, $num ) : $num < 2 ** 32 - 1 ? CORE::pack( 'CN', 0xdd, $num ) - : die "" # don't arrivie here + : _unexpected("number %d", $num) ; if ( --$max_depth <= 0 ) { Carp::croak("perl structure exceeds maximum nesting level (max_depth set too low?)"); @@ -155,7 +158,7 @@ sub _pack { $num < 16 ? CORE::pack( 'C', 0x80 + $num ) : $num < 2 ** 16 - 1 ? CORE::pack( 'Cn', 0xde, $num ) : $num < 2 ** 32 - 1 ? CORE::pack( 'CN', 0xdf, $num ) - : die "" # don't arrivie here + : _unexpected("number %d", $num) ; if ( --$max_depth <= 0 ) { Carp::croak("perl structure exceeds maximum nesting level (max_depth set too low?)"); @@ -211,7 +214,7 @@ sub _pack { $num < 32 ? CORE::pack( 'C', 0xa0 + $num ) : $num < 2 ** 16 - 1 ? CORE::pack( 'Cn', 0xda, $num ) : $num < 2 ** 32 - 1 ? CORE::pack( 'CN', 0xdb, $num ) - : die "" # don't arrivie here + : _unexpected_number($num) ; return $header . $value; @@ -221,7 +224,7 @@ sub _pack { return pack_double( $value ); } else { - die "???"; + _unexpected("data type %s", $b_obj); } } @@ -365,7 +368,7 @@ sub _unpack { } else { - die "???"; + _unexpected("byte 0x%02x", $byte); } } @@ -484,7 +487,7 @@ sub _count { : $byte == 0xcd ? 2 : $byte == 0xce ? 4 : $byte == 0xcf ? 8 - : die; + : _unexpected("byte 0x%02x", $byte); return 1; } @@ -493,7 +496,7 @@ sub _count { : $byte == 0xd1 ? 2 : $byte == 0xd2 ? 4 : $byte == 0xd3 ? 8 - : die; + : _unexpected("byte 0x%02x", $byte); return 1; } @@ -524,7 +527,7 @@ sub _count { } else { - die "???"; + _unexpected("byte 0x%02x", $byte); } return 0; diff --git a/perl/t/50_leaktrace.t b/perl/t/50_leaktrace.t index 2948527..440ac90 100644 --- a/perl/t/50_leaktrace.t +++ b/perl/t/50_leaktrace.t @@ -2,8 +2,12 @@ use strict; use Test::Requires { 'Test::LeakTrace' => 0.13 }; use Test::More; - use Data::MessagePack; +BEGIN { + if($INC{'Data/MessagePack/PP.pm'}) { + plan skip_all => 'disabled in PP'; + } +} my $simple_data = "xyz"; my $complex_data = { From bab622de25042d11dc8c149da26e178c22398c56 Mon Sep 17 00:00:00 2001 From: gfx Date: Sat, 18 Sep 2010 14:46:10 +0900 Subject: [PATCH 05/20] perl: fix max depth checks in PP --- perl/lib/Data/MessagePack/PP.pm | 16 ++++++++-------- perl/t/12_stream_unpack4.t | 1 + 2 files changed, 9 insertions(+), 8 deletions(-) diff --git a/perl/lib/Data/MessagePack/PP.pm b/perl/lib/Data/MessagePack/PP.pm index 31c0833..8a904a9 100644 --- a/perl/lib/Data/MessagePack/PP.pm +++ b/perl/lib/Data/MessagePack/PP.pm @@ -124,11 +124,11 @@ sub _unexpected { { no warnings 'recursion'; - my $max_depth; + our $_max_depth; sub pack :method { Carp::croak('Usage: Data::MessagePack->pack($dat [,$max_depth])') if @_ < 2; - $max_depth = defined $_[2] ? $_[2] : 512; # init + $_max_depth = defined $_[2] ? $_[2] : 512; # init return _pack( $_[1] ); } @@ -136,6 +136,12 @@ sub pack :method { sub _pack { my ( $value ) = @_; + local $_max_depth = $_max_depth - 1; + + if ( $_max_depth < 0 ) { + Carp::croak("perl structure exceeds maximum nesting level (max_depth set too low?)"); + } + return CORE::pack( 'C', 0xc0 ) if ( not defined $value ); if ( ref($value) eq 'ARRAY' ) { @@ -146,9 +152,6 @@ sub _pack { : $num < 2 ** 32 - 1 ? CORE::pack( 'CN', 0xdd, $num ) : _unexpected("number %d", $num) ; - if ( --$max_depth <= 0 ) { - Carp::croak("perl structure exceeds maximum nesting level (max_depth set too low?)"); - } return join( '', $header, map { _pack( $_ ) } @$value ); } @@ -160,9 +163,6 @@ sub _pack { : $num < 2 ** 32 - 1 ? CORE::pack( 'CN', 0xdf, $num ) : _unexpected("number %d", $num) ; - if ( --$max_depth <= 0 ) { - Carp::croak("perl structure exceeds maximum nesting level (max_depth set too low?)"); - } return join( '', $header, map { _pack( $_ ) } %$value ); } diff --git a/perl/t/12_stream_unpack4.t b/perl/t/12_stream_unpack4.t index 118acc3..de76e81 100644 --- a/perl/t/12_stream_unpack4.t +++ b/perl/t/12_stream_unpack4.t @@ -9,6 +9,7 @@ my @input = ( [[],[]], [{"a" => 97},{"a" => 97}], [{"a" => 97},{"a" => 97},{"a" => 97}], + [ map { +{ "foo $_" => "bar $_" } } 'aa' .. 'zz' ], ); plan tests => @input * 2; From e6f6aba2071c0a55b67dc935fa876af6b23e6c11 Mon Sep 17 00:00:00 2001 From: gfx Date: Sat, 18 Sep 2010 14:50:52 +0900 Subject: [PATCH 06/20] perl: add portability stuff --- perl/xs-src/unpack.c | 1 + 1 file changed, 1 insertion(+) diff --git a/perl/xs-src/unpack.c b/perl/xs-src/unpack.c index fefb52e..a4929c0 100644 --- a/perl/xs-src/unpack.c +++ b/perl/xs-src/unpack.c @@ -1,5 +1,6 @@ #define NEED_newRV_noinc #define NEED_sv_2pv_flags +#define NEED_my_snprintf #include "xshelper.h" #define MY_CXT_KEY "Data::MessagePack::_unpack_guts" XS_VERSION From 4902bed4098a4c98fc02555584150b1822c90b6b Mon Sep 17 00:00:00 2001 From: gfx Date: Sat, 18 Sep 2010 14:51:17 +0900 Subject: [PATCH 07/20] perl: more kind testing messages --- perl/t/00_compile.t | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/perl/t/00_compile.t b/perl/t/00_compile.t index f91b29e..d465f8d 100644 --- a/perl/t/00_compile.t +++ b/perl/t/00_compile.t @@ -3,4 +3,5 @@ use warnings; use Test::More tests => 1; use_ok 'Data::MessagePack'; -diag ( $INC{'Data/MessagePack/PP.pm'} ? 'PP' : 'XS' ); +diag ( "Testing Data::MessagePack/$Data::MessagePack::VERSION (", + $INC{'Data/MessagePack/PP.pm'} ? 'PP' : 'XS', ")" ); From 8935ecfdb86ad7a44c4bbf34acdd99cf80457cf0 Mon Sep 17 00:00:00 2001 From: gfx Date: Sat, 18 Sep 2010 14:56:33 +0900 Subject: [PATCH 08/20] perl: requires the latest version of Math::BigInt for PP --- perl/Makefile.PL | 1 + 1 file changed, 1 insertion(+) diff --git a/perl/Makefile.PL b/perl/Makefile.PL index fafc387..586a052 100644 --- a/perl/Makefile.PL +++ b/perl/Makefile.PL @@ -37,6 +37,7 @@ NOT_SUPPORT_C99 } else { print "configure PP version\n\n"; + requires 'Math::BigInt' => 1.95; # old versions of BigInt were broken } clean_files qw{ From 1865898cd42c2745850e3fd502f32c4584968263 Mon Sep 17 00:00:00 2001 From: gfx Date: Sat, 18 Sep 2010 14:58:32 +0900 Subject: [PATCH 09/20] perl: Fix Makefile.PL --- perl/Makefile.PL | 11 +++++------ 1 file changed, 5 insertions(+), 6 deletions(-) diff --git a/perl/Makefile.PL b/perl/Makefile.PL index 586a052..b5d2701 100644 --- a/perl/Makefile.PL +++ b/perl/Makefile.PL @@ -1,3 +1,5 @@ +# Usage: Makefile.PL --pp # disable XS +# Makefile.PL -g # add -g to the compiler and disable optimization flags use inc::Module::Install; use Module::Install::XSUtil 0.32; use Config; @@ -21,8 +23,9 @@ if ( $] >= 5.008005 and want_xs() ) { if ( $has_c99 ) { use_xshelper(); cc_src_paths('xs-src'); - if ($ENV{DEBUG}) { - cc_append_to_ccflags '-g'; + + if($Module::Install::AUTHOR) { + postamble qq{test :: test_pp\n\n}; } } else { @@ -67,10 +70,6 @@ test_requires('Test::Requires'); test_with_env( test_pp => PERL_DATA_MESSAGEPACK => 'pp' ); -if($Module::Install::AUTHOR) { - postamble qq{test :: test_pp\n\n}; -} - repository('http://github.com/msgpack/msgpack'); auto_include; WriteAll; From 63f6c86b46464cd5ff0c48c691bbfe2cee0a484d Mon Sep 17 00:00:00 2001 From: gfx Date: Sat, 18 Sep 2010 15:05:22 +0900 Subject: [PATCH 10/20] perl: add a note about 64 bit integers --- perl/README | 6 ++++++ perl/lib/Data/MessagePack.pm | 8 ++++++++ 2 files changed, 14 insertions(+) diff --git a/perl/README b/perl/README index 3105278..3476960 100644 --- a/perl/README +++ b/perl/README @@ -79,6 +79,12 @@ SPEED json 179443/s 56% -- -16% mp 212910/s 85% 19% -- +CAVEAT + Unpacking 64 bit integers + This module can unpack 64 bit integers even if your perl does not + support them (i.e. where "perl -V:ivsize" is 4), but you cannot + calculate these values unless you use "Math::BigInt". + TODO Error handling MessagePack cannot deal with complex scalars such as object diff --git a/perl/lib/Data/MessagePack.pm b/perl/lib/Data/MessagePack.pm index 953bdf8..2998178 100644 --- a/perl/lib/Data/MessagePack.pm +++ b/perl/lib/Data/MessagePack.pm @@ -141,6 +141,14 @@ This is a result of benchmark/serialize.pl and benchmark/deserialize.pl on my SC json 179443/s 56% -- -16% mp 212910/s 85% 19% -- +=head1 CAVEAT + +=head2 Unpacking 64 bit integers + +This module can unpack 64 bit integers even if your perl does not support them +(i.e. where C<< perl -V:ivsize >> is 4), but you cannot calculate these values +unless you use C. + =head1 TODO =over From 49379140c7c431c3a27f11dc7565da118dd38f16 Mon Sep 17 00:00:00 2001 From: gfx Date: Sat, 18 Sep 2010 15:14:29 +0900 Subject: [PATCH 11/20] perl: PERL_ONLY=1 disables XS --- perl/lib/Data/MessagePack.pm | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/perl/lib/Data/MessagePack.pm b/perl/lib/Data/MessagePack.pm index 2998178..0f389b1 100644 --- a/perl/lib/Data/MessagePack.pm +++ b/perl/lib/Data/MessagePack.pm @@ -24,7 +24,7 @@ sub false () { if ( !__PACKAGE__->can('pack') ) { # this idea comes from Text::Xslate my $backend = $ENV{ PERL_DATA_MESSAGEPACK } || ''; - if ( $backend !~ /\b pp \b/xms ) { + if ( $backend !~ /\b pp \b/xms or $ENV{PERL_ONLY} ) { eval { require XSLoader; XSLoader::load(__PACKAGE__, $VERSION); From cb85dcfcb8bdaf706ab515bce4bc1991c990716c Mon Sep 17 00:00:00 2001 From: gfx Date: Sat, 18 Sep 2010 15:49:25 +0900 Subject: [PATCH 12/20] perl: tweaks for benchmarks --- perl/benchmark/data.pl | 6 ++++++ perl/benchmark/deserialize.pl | 8 ++------ perl/benchmark/serialize.pl | 7 +------ 3 files changed, 9 insertions(+), 12 deletions(-) create mode 100755 perl/benchmark/data.pl diff --git a/perl/benchmark/data.pl b/perl/benchmark/data.pl new file mode 100755 index 0000000..6908d1c --- /dev/null +++ b/perl/benchmark/data.pl @@ -0,0 +1,6 @@ ++{ + "method" => "handleMessage", + "params" => [ "user1", "we were just talking", "foo\nbar\nbaz\nqux" ], + "id" => undef, + "array" => [ 1, 1024, 70000, -5, 1e5, 1e7, 1, 0, 3.14, sqrt(2), 1 .. 100 ], +}; diff --git a/perl/benchmark/deserialize.pl b/perl/benchmark/deserialize.pl index 634a79e..b1d7fdf 100644 --- a/perl/benchmark/deserialize.pl +++ b/perl/benchmark/deserialize.pl @@ -7,12 +7,8 @@ use Storable; #$Data::MessagePack::PreferInteger = 1; -my $a = { - "method" => "handleMessage", - "params" => [ "user1", "we were just talking" ], - "id" => undef, - "array" => [ 1, 1024, 70000, -5, 1e5, 1e7, 1, 0, 3.14, sqrt(2) ], -}; +my $a = do 'benchmark/data.pl'; + my $j = JSON::XS::encode_json($a); my $m = Data::MessagePack->pack($a); my $s = Storable::freeze($a); diff --git a/perl/benchmark/serialize.pl b/perl/benchmark/serialize.pl index e0509ff..3374684 100644 --- a/perl/benchmark/serialize.pl +++ b/perl/benchmark/serialize.pl @@ -5,12 +5,7 @@ use JSON::XS; use Storable; use Benchmark ':all'; -my $a = { - "method" => "handleMessage", - "params" => [ "user1", "we were just talking" ], - "id" => undef, - "array" => [ 1, 1024, 70000, -5, 1e5, 1e7, 1, 0, 3.14, sqrt(2) ], -}; +my $a = do 'benchmark/data.pl'; print "-- serialize\n"; print "JSON::XS: $JSON::XS::VERSION\n"; From b40284955781a152221e6fe6e0d2568ef4fdc27a Mon Sep 17 00:00:00 2001 From: gfx Date: Sat, 18 Sep 2010 15:54:22 +0900 Subject: [PATCH 13/20] perl: docs --- perl/lib/Data/MessagePack.pm | 11 +++++++++-- 1 file changed, 9 insertions(+), 2 deletions(-) diff --git a/perl/lib/Data/MessagePack.pm b/perl/lib/Data/MessagePack.pm index 0f389b1..4e4064b 100644 --- a/perl/lib/Data/MessagePack.pm +++ b/perl/lib/Data/MessagePack.pm @@ -45,6 +45,8 @@ Data::MessagePack - MessagePack serialising/deserialising =head1 SYNOPSIS + use Data::MessagePack; + my $packed = Data::MessagePack->pack($dat); my $unpacked = Data::MessagePack->unpack($dat); @@ -55,7 +57,8 @@ This module converts Perl data structures to MessagePack and vice versa. =head1 ABOUT MESSAGEPACK FORMAT MessagePack is a binary-based efficient object serialization format. -It enables to exchange structured objects between many languages like JSON. But unlike JSON, it is very fast and small. +It enables to exchange structured objects between many languages like JSON. +But unlike JSON, it is very fast and small. =head2 ADVANTAGES @@ -113,7 +116,7 @@ Packs a string as an integer, when it looks like an integer. =head1 SPEED This is a result of benchmark/serialize.pl and benchmark/deserialize.pl on my SC440(Linux 2.6.32-23-server #37-Ubuntu SMP). - +(You should benchmark them with B data if the speed matters, of course.) -- serialize JSON::XS: 2.3 @@ -195,4 +198,8 @@ it under the same terms as Perl itself. L is the official web site for the MessagePack format. +L + +L + =cut From c2bf2a817410b013aecc30d6a5abc0cad0423dff Mon Sep 17 00:00:00 2001 From: gfx Date: Sat, 18 Sep 2010 16:16:51 +0900 Subject: [PATCH 14/20] perl: make pp benchmarks available --- perl/benchmark/deserialize.pl | 10 +++++----- perl/benchmark/serialize.pl | 6 +++--- 2 files changed, 8 insertions(+), 8 deletions(-) diff --git a/perl/benchmark/deserialize.pl b/perl/benchmark/deserialize.pl index b1d7fdf..faa2582 100644 --- a/perl/benchmark/deserialize.pl +++ b/perl/benchmark/deserialize.pl @@ -1,25 +1,25 @@ use strict; use warnings; use Data::MessagePack; -use JSON::XS; -use Benchmark ':all'; +use JSON; use Storable; +use Benchmark ':all'; #$Data::MessagePack::PreferInteger = 1; my $a = do 'benchmark/data.pl'; -my $j = JSON::XS::encode_json($a); +my $j = JSON::encode_json($a); my $m = Data::MessagePack->pack($a); my $s = Storable::freeze($a); print "-- deserialize\n"; -print "JSON::XS: $JSON::XS::VERSION\n"; +print "$JSON::Backend: ", $JSON::Backend->VERSION, "\n"; print "Data::MessagePack: $Data::MessagePack::VERSION\n"; print "Storable: $Storable::VERSION\n"; cmpthese timethese( -1 => { - json => sub { JSON::XS::decode_json($j) }, + json => sub { JSON::decode_json($j) }, mp => sub { Data::MessagePack->unpack($m) }, storable => sub { Storable::thaw($s) }, } diff --git a/perl/benchmark/serialize.pl b/perl/benchmark/serialize.pl index 3374684..4982ff6 100644 --- a/perl/benchmark/serialize.pl +++ b/perl/benchmark/serialize.pl @@ -1,19 +1,19 @@ use strict; use warnings; use Data::MessagePack; -use JSON::XS; +use JSON; use Storable; use Benchmark ':all'; my $a = do 'benchmark/data.pl'; print "-- serialize\n"; -print "JSON::XS: $JSON::XS::VERSION\n"; +print "$JSON::Backend: ", $JSON::Backend->VERSION, "\n"; print "Data::MessagePack: $Data::MessagePack::VERSION\n"; print "Storable: $Storable::VERSION\n"; cmpthese timethese( -1 => { - json => sub { JSON::XS::encode_json($a) }, + json => sub { JSON::encode_json($a) }, storable => sub { Storable::freeze($a) }, mp => sub { Data::MessagePack->pack($a) }, } From 29707bd2ead5fa41dd0908fd7039124be1f6c5d8 Mon Sep 17 00:00:00 2001 From: gfx Date: Sat, 18 Sep 2010 16:19:16 +0900 Subject: [PATCH 15/20] perl: fix bootstrap --- perl/lib/Data/MessagePack.pm | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/perl/lib/Data/MessagePack.pm b/perl/lib/Data/MessagePack.pm index 4e4064b..154c5b1 100644 --- a/perl/lib/Data/MessagePack.pm +++ b/perl/lib/Data/MessagePack.pm @@ -23,8 +23,8 @@ sub false () { } if ( !__PACKAGE__->can('pack') ) { # this idea comes from Text::Xslate - my $backend = $ENV{ PERL_DATA_MESSAGEPACK } || ''; - if ( $backend !~ /\b pp \b/xms or $ENV{PERL_ONLY} ) { + my $backend = $ENV{PERL_DATA_MESSAGEPACK} || ($ENV{PERL_ONLY} ? 'pp' : ''); + if ( $backend !~ /\b pp \b/xms ) { eval { require XSLoader; XSLoader::load(__PACKAGE__, $VERSION); From 8d182f1d79808812bd095125eee1a43c7f7904f5 Mon Sep 17 00:00:00 2001 From: gfx Date: Sat, 18 Sep 2010 16:30:07 +0900 Subject: [PATCH 16/20] perl: Changelogging --- perl/Changes | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/perl/Changes b/perl/Changes index ce52581..d338cf8 100644 --- a/perl/Changes +++ b/perl/Changes @@ -1,7 +1,8 @@ 0.24 - - Fixed a possible SEGV on streaming unpacking (gfx) - - Improve performance, esp. in unpacking (gfx) + - Fixed a lot of streaming unpacking issues (tokuhirom, gfx) + - Fixed unpacking issues for 64 bit integers on 32 bit perls (gfx) + - Improved performance, esp. in unpacking (gfx) 0.23 From a1c01c6722a50db0aedcc73f2bb6cdd6f16c8f3a Mon Sep 17 00:00:00 2001 From: gfx Date: Sun, 19 Sep 2010 15:15:31 +0900 Subject: [PATCH 17/20] perl: regen README --- perl/README | 9 ++++++++- 1 file changed, 8 insertions(+), 1 deletion(-) diff --git a/perl/README b/perl/README index 3476960..224ff08 100644 --- a/perl/README +++ b/perl/README @@ -2,6 +2,8 @@ NAME Data::MessagePack - MessagePack serialising/deserialising SYNOPSIS + use Data::MessagePack; + my $packed = Data::MessagePack->pack($dat); my $unpacked = Data::MessagePack->unpack($dat); @@ -51,7 +53,8 @@ Configuration Variables SPEED This is a result of benchmark/serialize.pl and benchmark/deserialize.pl - on my SC440(Linux 2.6.32-23-server #37-Ubuntu SMP). + on my SC440(Linux 2.6.32-23-server #37-Ubuntu SMP). (You should + benchmark them with your data if the speed matters, of course.) -- serialize JSON::XS: 2.3 @@ -123,3 +126,7 @@ SEE ALSO is the official web site for the MessagePack format. + Data::MessagePack::Unpacker + + AnyEvent::MPRPC + From d6a825981d14079bf4fa74a0605ecec8e873f94b Mon Sep 17 00:00:00 2001 From: gfx Date: Sun, 19 Sep 2010 15:16:08 +0900 Subject: [PATCH 18/20] perl: fix unpacking int64_t in PP (based on makamaka's patch) --- perl/lib/Data/MessagePack/PP.pm | 15 ++++++++++++--- perl/t/data.pl | 5 +++++ 2 files changed, 17 insertions(+), 3 deletions(-) diff --git a/perl/lib/Data/MessagePack/PP.pm b/perl/lib/Data/MessagePack/PP.pm index 8a904a9..44940de 100644 --- a/perl/lib/Data/MessagePack/PP.pm +++ b/perl/lib/Data/MessagePack/PP.pm @@ -22,10 +22,19 @@ BEGIN { 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) ); + my $high = unpack_uint32( $_[0], $_[1] ); + my $low = unpack_uint32( $_[0], $_[1] + 4); - return +($high << 32 | $low)->bstr; + if($high < 0xF0000000) { # positive + $high = Math::BigInt->new( $high ); + $low = Math::BigInt->new( $low ); + return +($high << 32 | $low)->bstr; + } + else { # negative + $high = Math::BigInt->new( ~$high ); + $low = Math::BigInt->new( ~$low ); + return +( -($high << 32 | $low + 1) )->bstr; + } }; $unpack_uint64_slow = sub { require Math::BigInt; diff --git a/perl/t/data.pl b/perl/t/data.pl index 8ffd25a..95eac41 100644 --- a/perl/t/data.pl +++ b/perl/t/data.pl @@ -35,4 +35,9 @@ no warnings; # i need this, i need this. 'd3 ff ff ff ff ff ff ff ff' => '-1', # int64_t 'cf ff ff ff ff ff ff ff ff' => '18446744073709551615', # uint64_t + + # int64_t + 'd3 00 00 00 10 00 00 00 00' => '68719476736', + 'd3 00 00 00 10 00 00 00 01' => '68719476737', + 'd3 10 00 00 00 00 00 00 00' => '1152921504606846976', ) From 5cd37e550533a4d12b3390ff161af83db9b21246 Mon Sep 17 00:00:00 2001 From: gfx Date: Sun, 19 Sep 2010 15:20:03 +0900 Subject: [PATCH 19/20] perl: always unpacking 64 bit ints as a string on 32 bit perls --- perl/xs-src/unpack.c | 22 ++++++---------------- 1 file changed, 6 insertions(+), 16 deletions(-) diff --git a/perl/xs-src/unpack.c b/perl/xs-src/unpack.c index a4929c0..20b345f 100644 --- a/perl/xs-src/unpack.c +++ b/perl/xs-src/unpack.c @@ -113,28 +113,18 @@ STATIC_INLINE int template_callback_IV(unpack_user* u PERL_UNUSED_DECL, IV const static int template_callback_uint64(unpack_user* u PERL_UNUSED_DECL, uint64_t const d, SV** o) { dTHX; - 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); - } + 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); - } + char tbuf[64]; + STRLEN const len = my_snprintf(tbuf, sizeof(tbuf), "%lld", d); + *o = newSVpvn(tbuf, len); return 0; } From afefbe4e564686ac3b9fac9e1d9782f0114c3383 Mon Sep 17 00:00:00 2001 From: gfx Date: Sun, 19 Sep 2010 15:21:25 +0900 Subject: [PATCH 20/20] perl: update .gitignore and MANIFEST.SKIP --- perl/.gitignore | 1 + perl/MANIFEST.SKIP | 1 + 2 files changed, 2 insertions(+) diff --git a/perl/.gitignore b/perl/.gitignore index 3e0e73e..1656847 100644 --- a/perl/.gitignore +++ b/perl/.gitignore @@ -1,4 +1,5 @@ META.yml +MYMETA.yml Makefile Makefile.old MessagePack.bs diff --git a/perl/MANIFEST.SKIP b/perl/MANIFEST.SKIP index 71a24e5..1d2192f 100644 --- a/perl/MANIFEST.SKIP +++ b/perl/MANIFEST.SKIP @@ -2,6 +2,7 @@ \bCVS\b ^MANIFEST\. ^Makefile$ +^MYMETA\.yml$ ~$ ^# \.old$