From 987248ccbb4d18d532f2d07c28f47d37934b9c59 Mon Sep 17 00:00:00 2001 From: gfx Date: Wed, 15 Sep 2010 12:31:01 +0900 Subject: [PATCH 01/59] Use xshelper.h in all the C files --- perl/MANIFEST.SKIP | 1 - perl/perlxs.h | 76 --------------------------------------- perl/util.h | 11 ------ perl/xs-src/MessagePack.c | 14 +------- perl/xs-src/unpack.c | 8 ----- 5 files changed, 1 insertion(+), 109 deletions(-) delete mode 100644 perl/perlxs.h delete mode 100644 perl/util.h diff --git a/perl/MANIFEST.SKIP b/perl/MANIFEST.SKIP index 372742ca..71a24e5c 100644 --- a/perl/MANIFEST.SKIP +++ b/perl/MANIFEST.SKIP @@ -25,4 +25,3 @@ ^Data-MessagePack-[0-9.]+/ ^\.testenv/test_pp.pl ^ppport.h$ -^xshelper.h$ diff --git a/perl/perlxs.h b/perl/perlxs.h deleted file mode 100644 index 441682de..00000000 --- a/perl/perlxs.h +++ /dev/null @@ -1,76 +0,0 @@ -/* - perlxs.h - Standard XS header file - Copyright (c) Fuji, Goro (gfx) -*/ - -#ifdef __cplusplus -extern "C" { -#endif - -#define PERL_NO_GET_CONTEXT /* we want efficiency */ -#include - -#include -#define NO_XSLOCKS /* for exceptions */ -#include - -#ifdef __cplusplus -} /* extern "C" */ -#endif - -#include "ppport.h" - -/* portability stuff not supported by ppport.h yet */ - -#ifndef STATIC_INLINE /* from 5.13.4 */ -# if defined(__GNUC__) || defined(__cplusplus__) || (defined(__STDC_VERSION__) && (__STDC_VERSION__ >= 199901L)) -# define STATIC_INLINE static inline -# else -# define STATIC_INLINE static -# endif -#endif /* STATIC_INLINE */ - -#ifndef __attribute__format__ -#define __attribute__format__(a,b,c) /* nothing */ -#endif - -#ifndef LIKELY /* they are just a compiler's hint */ -#define LIKELY(x) (x) -#define UNLIKELY(x) (x) -#endif - -#ifndef newSVpvs_share -#define newSVpvs_share(s) Perl_newSVpvn_share(aTHX_ STR_WITH_LEN(s), 0U) -#endif - -#ifndef get_cvs -#define get_cvs(name, flags) get_cv(name, flags) -#endif - -#ifndef GvNAME_get -#define GvNAME_get GvNAME -#endif -#ifndef GvNAMELEN_get -#define GvNAMELEN_get GvNAMELEN -#endif - -#ifndef CvGV_set -#define CvGV_set(cv, gv) (CvGV(cv) = (gv)) -#endif - -/* general utility */ - -#if PERL_BCDVERSION >= 0x5008005 -#define LooksLikeNumber(x) looks_like_number(x) -#else -#define LooksLikeNumber(x) (SvPOKp(x) ? looks_like_number(x) : (I32)SvNIOKp(x)) -#endif - -#define newAV_mortal() (AV*)sv_2mortal((SV*)newAV()) -#define newHV_mortal() (HV*)sv_2mortal((SV*)newHV()) - -#define DECL_BOOT(name) EXTERN_C XS(CAT2(boot_, name)) -#define CALL_BOOT(name) STMT_START { \ - PUSHMARK(SP); \ - CALL_FPTR(CAT2(boot_, name))(aTHX_ cv); \ - } STMT_END diff --git a/perl/util.h b/perl/util.h deleted file mode 100644 index 2b4ed072..00000000 --- a/perl/util.h +++ /dev/null @@ -1,11 +0,0 @@ -#ifndef __PERL_MSGPACK_UTIL_H__ -#define __PERL_MSGPACK_UTIL_H__ - -#if __GNUC__ >= 3 -# define INLINE inline -#else -# define INLINE -#endif - -#endif // __PERL_MSGPACK_UTIL_H__ - diff --git a/perl/xs-src/MessagePack.c b/perl/xs-src/MessagePack.c index fd1b344d..259fd156 100644 --- a/perl/xs-src/MessagePack.c +++ b/perl/xs-src/MessagePack.c @@ -1,14 +1,4 @@ -#ifdef __cplusplus -extern "C" { -#endif -#include "EXTERN.h" -#include "perl.h" -#include "XSUB.h" -#define NEED_newCONSTSUB -#include "ppport.h" -#ifdef __cplusplus -}; -#endif +#include "xshelper.h" XS(xs_pack); XS(xs_unpack); @@ -24,13 +14,11 @@ void boot_Data__MessagePack_pack(void); XS(boot_Data__MessagePack) { dXSARGS; - HV * stash; boot_Data__MessagePack_pack(); newXS("Data::MessagePack::pack", xs_pack, __FILE__); newXS("Data::MessagePack::unpack", xs_unpack, __FILE__); - stash = gv_stashpvn("Data::MessagePack", strlen("Data::MessagePack"), TRUE); newXS("Data::MessagePack::Unpacker::new", xs_unpacker_new, __FILE__); newXS("Data::MessagePack::Unpacker::execute", xs_unpacker_execute, __FILE__); diff --git a/perl/xs-src/unpack.c b/perl/xs-src/unpack.c index c329e99c..2edfdf79 100644 --- a/perl/xs-src/unpack.c +++ b/perl/xs-src/unpack.c @@ -1,15 +1,7 @@ -#ifdef __cplusplus -extern "C" { -#endif - #define NEED_newRV_noinc #define NEED_sv_2pv_flags #include "xshelper.h" -#ifdef __cplusplus -}; -#endif - typedef struct { int finished; SV* source; From bebcc24ab8908a07449c8ff6992a5dea2371e136 Mon Sep 17 00:00:00 2001 From: gfx Date: Wed, 15 Sep 2010 12:32:01 +0900 Subject: [PATCH 02/59] Depends on XSUtil 0.32 --- perl/Makefile.PL | 1 + 1 file changed, 1 insertion(+) diff --git a/perl/Makefile.PL b/perl/Makefile.PL index 7053cf96..e7b8c474 100644 --- a/perl/Makefile.PL +++ b/perl/Makefile.PL @@ -1,4 +1,5 @@ use inc::Module::Install; +use Module::Install::XSUtil 0.32; use Config; name 'Data-MessagePack'; From 197205853fb552234250e1616af85b60552c9869 Mon Sep 17 00:00:00 2001 From: gfx Date: Wed, 15 Sep 2010 12:35:10 +0900 Subject: [PATCH 03/59] Use newSV(). NEWSV() is deprecated. --- perl/xs-src/pack.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/perl/xs-src/pack.c b/perl/xs-src/pack.c index 0aa32502..4378b056 100644 --- a/perl/xs-src/pack.c +++ b/perl/xs-src/pack.c @@ -252,7 +252,7 @@ XS(xs_pack) { if (items >= 3) depth = SvIV(ST(2)); enc_t enc; - enc.sv = sv_2mortal(NEWSV(0, INIT_SIZE)); + enc.sv = sv_2mortal(newSV(INIT_SIZE)); enc.cur = SvPVX(enc.sv); enc.end = SvEND(enc.sv); SvPOK_only(enc.sv); From 0768cf17b61465ebc2fe5e0132e0494399eb94d1 Mon Sep 17 00:00:00 2001 From: gfx Date: Wed, 15 Sep 2010 12:36:43 +0900 Subject: [PATCH 04/59] Taking NULL is a bug --- perl/xs-src/pack.c | 7 +++---- 1 file changed, 3 insertions(+), 4 deletions(-) diff --git a/perl/xs-src/pack.c b/perl/xs-src/pack.c index 4378b056..7bad6145 100644 --- a/perl/xs-src/pack.c +++ b/perl/xs-src/pack.c @@ -143,14 +143,13 @@ STATIC_INLINE int try_int(enc_t* enc, const char *p, size_t len) { static void _msgpack_pack_rv(enc_t *enc, SV* sv, int depth); -STATIC_INLINE void _msgpack_pack_sv(enc_t *enc, SV* sv, int depth) { +STATIC_INLINE void _msgpack_pack_sv(enc_t* const enc, SV* const sv, int const depth) { dTHX; + assert(sv); if (depth <= 0) Perl_croak(aTHX_ ERR_NESTING_EXCEEDED); SvGETMAGIC(sv); - if (sv==NULL) { - msgpack_pack_nil(enc); - } else if (SvPOKp(sv)) { + if (SvPOKp(sv)) { STRLEN len; char * csv = SvPV(sv, len); From 0f02ef20a9ff77e830d5f199a4deac1c9a4d7d87 Mon Sep 17 00:00:00 2001 From: gfx Date: Wed, 15 Sep 2010 12:46:11 +0900 Subject: [PATCH 05/59] Improve benchmarks --- perl/benchmark/deserialize.pl | 6 +++--- perl/benchmark/serialize.pl | 6 +++--- 2 files changed, 6 insertions(+), 6 deletions(-) diff --git a/perl/benchmark/deserialize.pl b/perl/benchmark/deserialize.pl index 750704e9..9658c0c8 100644 --- a/perl/benchmark/deserialize.pl +++ b/perl/benchmark/deserialize.pl @@ -9,7 +9,7 @@ my $a = { "method" => "handleMessage", "params" => [ "user1", "we were just talking" ], "id" => undef, - "array" => [ 1, 11, 234, -5, 1e5, 1e7, 1, 0 ] + "array" => [ 1, 11, 234, -5, 1e5, 1e7, 1, 0, 3.14, sqrt(2) ] }; my $j = JSON::XS::encode_json($a); my $m = Data::MessagePack->pack($a); @@ -19,8 +19,8 @@ print "-- deserialize\n"; print "JSON::XS: $JSON::XS::VERSION\n"; print "Data::MessagePack: $Data::MessagePack::VERSION\n"; print "Storable: $Storable::VERSION\n"; -timethese( - 1000000 => { +cmpthese timethese( + -1 => { json => sub { JSON::XS::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 c5ab15bc..ee9e7a45 100644 --- a/perl/benchmark/serialize.pl +++ b/perl/benchmark/serialize.pl @@ -9,15 +9,15 @@ my $a = { "method" => "handleMessage", "params" => [ "user1", "we were just talking" ], "id" => undef, - "array" => [ 1, 11, 234, -5, 1e5, 1e7, 1, 0 ] + "array" => [ 1, 11, 234, -5, 1e5, 1e7, 1, 0, 3.14, sqrt(2) ] }; print "-- serialize\n"; print "JSON::XS: $JSON::XS::VERSION\n"; print "Data::MessagePack: $Data::MessagePack::VERSION\n"; print "Storable: $Storable::VERSION\n"; -timethese( - 1000000 => { +cmpthese timethese( + -1 => { json => sub { JSON::XS::encode_json($a) }, storable => sub { Storable::freeze($a) }, mp => sub { Data::MessagePack->pack($a) }, From d86104ed5dc3b2a99542a8e6c4468b778200f5fc Mon Sep 17 00:00:00 2001 From: gfx Date: Wed, 15 Sep 2010 12:48:23 +0900 Subject: [PATCH 06/59] Tweaks --- perl/xs-src/pack.c | 20 ++++++++++++-------- 1 file changed, 12 insertions(+), 8 deletions(-) diff --git a/perl/xs-src/pack.c b/perl/xs-src/pack.c index 7bad6145..67483dcf 100644 --- a/perl/xs-src/pack.c +++ b/perl/xs-src/pack.c @@ -48,7 +48,7 @@ STATIC_INLINE void need(enc_t *enc, STRLEN len) dTHX; if (enc->cur + len >= enc->end) { STRLEN cur = enc->cur - (char *)SvPVX (enc->sv); - SvGROW (enc->sv, cur + (len < (cur >> 2) ? cur >> 2 : len) + 1); + sv_grow (enc->sv, cur + (len < (cur >> 2) ? cur >> 2 : len) + 1); enc->cur = SvPVX (enc->sv) + cur; enc->end = SvPVX (enc->sv) + SvLEN (enc->sv) - 1; } @@ -159,13 +159,17 @@ STATIC_INLINE void _msgpack_pack_sv(enc_t* const enc, SV* const sv, int const de msgpack_pack_raw(enc, len); msgpack_pack_raw_body(enc, csv, len); } - } else if (SvNOKp(sv)) { - /* XXX long double is not supported yet. */ - msgpack_pack_double(enc, (double)SvNVX(sv)); - } else if (SvIOK_UV(sv)) { - msgpack_pack_uint32(enc, SvUV(sv)); - } else if (SvIOKp(sv)) { - PACK_IV(enc, SvIV(sv)); + } else if (SvNIOKp(sv)) { + if(SvUOK(sv)) { + msgpack_pack_uint32(enc, SvUV(sv)); + } + else if(SvIOKp(sv)) { + PACK_IV(enc, SvIV(sv)); + } + else { + /* XXX long double is not supported yet. */ + msgpack_pack_double(enc, (double)SvNVX(sv)); + } } else if (SvROK(sv)) { _msgpack_pack_rv(enc, SvRV(sv), depth-1); } else if (!SvOK(sv)) { From 60b36ffaa38ba32c1a97b4143138bb2e511fb1ae Mon Sep 17 00:00:00 2001 From: gfx Date: Wed, 15 Sep 2010 12:50:11 +0900 Subject: [PATCH 07/59] Micro optimizations --- perl/xs-src/pack.c | 15 +++++++++------ 1 file changed, 9 insertions(+), 6 deletions(-) diff --git a/perl/xs-src/pack.c b/perl/xs-src/pack.c index 67483dcf..30bc0325 100644 --- a/perl/xs-src/pack.c +++ b/perl/xs-src/pack.c @@ -32,10 +32,13 @@ static void need(enc_t *enc, STRLEN len); #if IVSIZE == 8 # define PACK_IV msgpack_pack_int64 +# define PACK_UV msgpack_pack_uint64 #elif IVSIZE == 4 # define PACK_IV msgpack_pack_int32 +# define PACK_UV msgpack_pack_uint32 #elif IVSIZE == 2 # define PACK_IV msgpack_pack_int16 +# define PACK_UV msgpack_pack_uint16 #else # error "msgpack only supports IVSIZE = 8,4,2 environment." #endif @@ -150,21 +153,21 @@ STATIC_INLINE void _msgpack_pack_sv(enc_t* const enc, SV* const sv, int const de SvGETMAGIC(sv); if (SvPOKp(sv)) { - STRLEN len; - char * csv = SvPV(sv, len); + STRLEN const len = SvCUR(sv); + const char* const pv = SvPVX_const(sv); - if (s_pref_int && try_int(enc, csv, len)) { + if (s_pref_int && try_int(enc, pv, len)) { return; } else { msgpack_pack_raw(enc, len); - msgpack_pack_raw_body(enc, csv, len); + msgpack_pack_raw_body(enc, pv, len); } } else if (SvNIOKp(sv)) { if(SvUOK(sv)) { - msgpack_pack_uint32(enc, SvUV(sv)); + PACK_UV(enc, SvUVX(sv)); } else if(SvIOKp(sv)) { - PACK_IV(enc, SvIV(sv)); + PACK_IV(enc, SvIVX(sv)); } else { /* XXX long double is not supported yet. */ From 4adcdb5ba81544517d65953497f0b0ac17b95a0a Mon Sep 17 00:00:00 2001 From: gfx Date: Wed, 15 Sep 2010 12:51:33 +0900 Subject: [PATCH 08/59] Remove a duplicated depth check --- perl/xs-src/pack.c | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/perl/xs-src/pack.c b/perl/xs-src/pack.c index 30bc0325..c01ba44b 100644 --- a/perl/xs-src/pack.c +++ b/perl/xs-src/pack.c @@ -149,7 +149,7 @@ static void _msgpack_pack_rv(enc_t *enc, SV* sv, int depth); STATIC_INLINE void _msgpack_pack_sv(enc_t* const enc, SV* const sv, int const depth) { dTHX; assert(sv); - if (depth <= 0) Perl_croak(aTHX_ ERR_NESTING_EXCEEDED); + if (UNLIKELY(depth <= 0)) Perl_croak(aTHX_ ERR_NESTING_EXCEEDED); SvGETMAGIC(sv); if (SvPOKp(sv)) { @@ -188,7 +188,6 @@ STATIC_INLINE void _msgpack_pack_sv(enc_t* const enc, SV* const sv, int const de STATIC_INLINE void _msgpack_pack_rv(enc_t *enc, SV* sv, int depth) { svtype svt; dTHX; - if (depth <= 0) Perl_croak(aTHX_ ERR_NESTING_EXCEEDED); SvGETMAGIC(sv); svt = SvTYPE(sv); From c5e15123fd14fe448222689d460b0b02a7659e14 Mon Sep 17 00:00:00 2001 From: gfx Date: Wed, 15 Sep 2010 12:52:07 +0900 Subject: [PATCH 09/59] Add an assertion --- perl/xs-src/pack.c | 1 + 1 file changed, 1 insertion(+) diff --git a/perl/xs-src/pack.c b/perl/xs-src/pack.c index c01ba44b..5feba4ab 100644 --- a/perl/xs-src/pack.c +++ b/perl/xs-src/pack.c @@ -188,6 +188,7 @@ STATIC_INLINE void _msgpack_pack_sv(enc_t* const enc, SV* const sv, int const de STATIC_INLINE void _msgpack_pack_rv(enc_t *enc, SV* sv, int depth) { svtype svt; dTHX; + assert(sv); SvGETMAGIC(sv); svt = SvTYPE(sv); From 50c74103aaecaff6f72ada55a1c9dc683c3017ef Mon Sep 17 00:00:00 2001 From: gfx Date: Wed, 15 Sep 2010 12:56:13 +0900 Subject: [PATCH 10/59] Avoid compiler's warnings --- perl/xs-src/pack.c | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/perl/xs-src/pack.c b/perl/xs-src/pack.c index 5feba4ab..c0c610e7 100644 --- a/perl/xs-src/pack.c +++ b/perl/xs-src/pack.c @@ -60,7 +60,7 @@ STATIC_INLINE void need(enc_t *enc, STRLEN len) static int s_pref_int = 0; -STATIC_INLINE int pref_int_set(pTHX_ SV* sv, MAGIC* mg) { +STATIC_INLINE int pref_int_set(pTHX_ SV* sv, MAGIC* mg PERL_UNUSED_DECL) { if (SvTRUE(sv)) { s_pref_int = 1; } else { @@ -211,7 +211,7 @@ STATIC_INLINE void _msgpack_pack_rv(enc_t *enc, SV* sv, int depth) { msgpack_pack_map(enc, count); - while (he = hv_iternext(hval)) { + while ((he = hv_iternext(hval))) { _msgpack_pack_sv(enc, hv_iterkeysv(he), depth); _msgpack_pack_sv(enc, HeVAL(he), depth); } From 9953218de18a87173869e8ffe97aa274046ddae1 Mon Sep 17 00:00:00 2001 From: gfx Date: Wed, 15 Sep 2010 13:03:47 +0900 Subject: [PATCH 11/59] Tidy --- perl/xs-src/unpack.c | 117 +++++++++++++++++++++++++++++++++++-------- 1 file changed, 96 insertions(+), 21 deletions(-) diff --git a/perl/xs-src/unpack.c b/perl/xs-src/unpack.c index 2edfdf79..05d953a8 100644 --- a/perl/xs-src/unpack.c +++ b/perl/xs-src/unpack.c @@ -50,16 +50,31 @@ static int template_execute(msgpack_unpack_t* u, const char* data, size_t len, size_t* off); STATIC_INLINE SV* template_callback_root(unpack_user* u) -{ dTHX; return &PL_sv_undef; } +{ + dTHX; + return &PL_sv_undef; +} STATIC_INLINE int template_callback_uint8(unpack_user* u, uint8_t d, SV** o) -{ dTHX; *o = sv_2mortal(newSVuv(d)); return 0; } +{ + dTHX; + *o = sv_2mortal(newSVuv(d)); + return 0; +} STATIC_INLINE int template_callback_uint16(unpack_user* u, uint16_t d, SV** o) -{ dTHX; *o = sv_2mortal(newSVuv(d)); return 0; } +{ + dTHX; + *o = sv_2mortal(newSVuv(d)); + return 0; +} STATIC_INLINE int template_callback_uint32(unpack_user* u, uint32_t d, SV** o) -{ dTHX; *o = sv_2mortal(newSVuv(d)); return 0; } +{ + dTHX; + *o = sv_2mortal(newSVuv(d)); + return 0; +} STATIC_INLINE int template_callback_uint64(unpack_user* u, uint64_t d, SV** o) { @@ -72,49 +87,109 @@ STATIC_INLINE int template_callback_uint64(unpack_user* u, uint64_t d, SV** o) return 0; } -STATIC_INLINE int template_callback_int8(unpack_user* u, int8_t d, SV** o) -{ dTHX; *o = sv_2mortal(newSViv((long)d)); return 0; } +STATIC_INLINE int template_callback_int8(unpack_user* u PERL_UNUSED_DECL, int8_t d, SV** o) +{ + dTHX; + *o = sv_2mortal(newSViv(d)); + return 0; +} -STATIC_INLINE int template_callback_int16(unpack_user* u, int16_t d, SV** o) -{ dTHX; *o = sv_2mortal(newSViv((long)d)); return 0; } +STATIC_INLINE int template_callback_int16(unpack_user* u PERL_UNUSED_DECL, int16_t d, SV** o) +{ + dTHX; + *o = sv_2mortal(newSViv(d)); + return 0; +} STATIC_INLINE int template_callback_int32(unpack_user* u, int32_t d, SV** o) -{ dTHX; *o = sv_2mortal(newSViv((long)d)); return 0; } +{ + dTHX; + *o = sv_2mortal(newSViv(d)); + return 0; +} STATIC_INLINE int template_callback_int64(unpack_user* u, int64_t d, SV** o) -{ dTHX; *o = sv_2mortal(newSViv(d)); return 0; } +{ + dTHX; + *o = sv_2mortal(newSViv(d)); + return 0; +} STATIC_INLINE int template_callback_float(unpack_user* u, float d, SV** o) -{ dTHX; *o = sv_2mortal(newSVnv(d)); return 0; } +{ + dTHX; + *o = sv_2mortal(newSVnv(d)); + return 0; +} STATIC_INLINE int template_callback_double(unpack_user* u, double d, SV** o) -{ dTHX; *o = sv_2mortal(newSVnv(d)); return 0; } +{ + dTHX; + *o = sv_2mortal(newSVnv(d)); + return 0; +} /* &PL_sv_undef is not so good. see http://gist.github.com/387743 */ STATIC_INLINE int template_callback_nil(unpack_user* u, SV** o) -{ dTHX; *o = sv_newmortal(); return 0; } +{ + dTHX; + *o = sv_newmortal(); + return 0; +} STATIC_INLINE int template_callback_true(unpack_user* u, SV** o) -{ dTHX; *o = get_bool("Data::MessagePack::true") ; return 0; } +{ + dTHX; + *o = get_bool("Data::MessagePack::true"); + return 0; +} STATIC_INLINE int template_callback_false(unpack_user* u, SV** o) -{ dTHX; *o = get_bool("Data::MessagePack::false") ; return 0; } +{ + dTHX; *o = get_bool("Data::MessagePack::false"); + return 0; +} STATIC_INLINE int template_callback_array(unpack_user* u, unsigned int n, SV** o) -{ dTHX; AV* a = (AV*)sv_2mortal((SV*)newAV()); *o = sv_2mortal((SV*)newRV_inc((SV*)a)); av_extend(a, n); return 0; } +{ + dTHX; + AV* a = (AV*)sv_2mortal((SV*)newAV()); + *o = sv_2mortal((SV*)newRV_inc((SV*)a)); + av_extend(a, n); + return 0; +} STATIC_INLINE int template_callback_array_item(unpack_user* u, SV** c, SV* o) -{ dTHX; av_push((AV*)SvRV(*c), o); SvREFCNT_inc(o); return 0; } /* FIXME set value directry RARRAY_PTR(obj)[RARRAY_LEN(obj)++] */ +{ + dTHX; + av_push((AV*)SvRV(*c), o); + SvREFCNT_inc(o); + return 0; +} STATIC_INLINE int template_callback_map(unpack_user* u, unsigned int n, SV** o) -{ dTHX; HV * h = (HV*)sv_2mortal((SV*)newHV()); *o = sv_2mortal(newRV_inc((SV*)h)); return 0; } +{ + dTHX; + HV* h = (HV*)sv_2mortal((SV*)newHV()); + *o = sv_2mortal(newRV_inc((SV*)h)); + return 0; +} STATIC_INLINE int template_callback_map_item(unpack_user* u, SV** c, SV* k, SV* v) -{ dTHX; hv_store_ent((HV*)SvRV(*c), k, v, 0); SvREFCNT_inc(v); return 0; } +{ + dTHX; + hv_store_ent((HV*)SvRV(*c), k, v, 0); + SvREFCNT_inc(v); + return 0; +} STATIC_INLINE int template_callback_raw(unpack_user* u, const char* b, const char* p, unsigned int l, SV** o) -{ dTHX; *o = sv_2mortal((l==0) ? newSVpv("", 0) : newSVpv(p, l)); return 0; } -/* { *o = newSVpvn_flags(p, l, SVs_TEMP); return 0; } <= this does not works. */ +{ + dTHX; + /* *o = newSVpvn_flags(p, l, SVs_TEMP); <= this does not work. */ + *o = sv_2mortal((l==0) ? newSVpv("", 0) : newSVpv(p, l)); + return 0; +} #define UNPACKER(from, name) \ msgpack_unpack_t *name; \ From 10bf3ee9dec23337f30074785d7c21b81ffe2c40 Mon Sep 17 00:00:00 2001 From: gfx Date: Wed, 15 Sep 2010 13:07:44 +0900 Subject: [PATCH 12/59] Avoid compiler's warnings --- perl/xs-src/unpack.c | 43 +++++++++++++++++++++---------------------- 1 file changed, 21 insertions(+), 22 deletions(-) diff --git a/perl/xs-src/unpack.c b/perl/xs-src/unpack.c index 05d953a8..108f9fda 100644 --- a/perl/xs-src/unpack.c +++ b/perl/xs-src/unpack.c @@ -46,37 +46,37 @@ static void template_init(msgpack_unpack_t* u); static SV* template_data(msgpack_unpack_t* u); -static int template_execute(msgpack_unpack_t* u, +static int template_execute(msgpack_unpack_t* u PERL_UNUSED_DECL, const char* data, size_t len, size_t* off); -STATIC_INLINE SV* template_callback_root(unpack_user* u) +STATIC_INLINE SV* template_callback_root(unpack_user* u PERL_UNUSED_DECL) { dTHX; return &PL_sv_undef; } -STATIC_INLINE int template_callback_uint8(unpack_user* u, uint8_t d, SV** o) +STATIC_INLINE int template_callback_uint8(unpack_user* u PERL_UNUSED_DECL, uint8_t d, SV** o) { dTHX; *o = sv_2mortal(newSVuv(d)); return 0; } -STATIC_INLINE int template_callback_uint16(unpack_user* u, uint16_t d, SV** o) +STATIC_INLINE int template_callback_uint16(unpack_user* u PERL_UNUSED_DECL, uint16_t d, SV** o) { dTHX; *o = sv_2mortal(newSVuv(d)); return 0; } -STATIC_INLINE int template_callback_uint32(unpack_user* u, uint32_t d, SV** o) +STATIC_INLINE int template_callback_uint32(unpack_user* u PERL_UNUSED_DECL, uint32_t d, SV** o) { dTHX; *o = sv_2mortal(newSVuv(d)); return 0; } -STATIC_INLINE int template_callback_uint64(unpack_user* u, uint64_t d, SV** o) +STATIC_INLINE int template_callback_uint64(unpack_user* u PERL_UNUSED_DECL, uint64_t d, SV** o) { dTHX; #if IVSIZE==4 @@ -101,28 +101,28 @@ STATIC_INLINE int template_callback_int16(unpack_user* u PERL_UNUSED_DECL, int16 return 0; } -STATIC_INLINE int template_callback_int32(unpack_user* u, int32_t d, SV** o) +STATIC_INLINE int template_callback_int32(unpack_user* u PERL_UNUSED_DECL, int32_t d, SV** o) { dTHX; *o = sv_2mortal(newSViv(d)); return 0; } -STATIC_INLINE int template_callback_int64(unpack_user* u, int64_t d, SV** o) +STATIC_INLINE int template_callback_int64(unpack_user* u PERL_UNUSED_DECL, int64_t d, SV** o) { dTHX; *o = sv_2mortal(newSViv(d)); return 0; } -STATIC_INLINE int template_callback_float(unpack_user* u, float d, SV** o) +STATIC_INLINE int template_callback_float(unpack_user* u PERL_UNUSED_DECL, float d, SV** o) { dTHX; *o = sv_2mortal(newSVnv(d)); return 0; } -STATIC_INLINE int template_callback_double(unpack_user* u, double d, SV** o) +STATIC_INLINE int template_callback_double(unpack_user* u PERL_UNUSED_DECL, double d, SV** o) { dTHX; *o = sv_2mortal(newSVnv(d)); @@ -130,27 +130,27 @@ STATIC_INLINE int template_callback_double(unpack_user* u, double d, SV** o) } /* &PL_sv_undef is not so good. see http://gist.github.com/387743 */ -STATIC_INLINE int template_callback_nil(unpack_user* u, SV** o) +STATIC_INLINE int template_callback_nil(unpack_user* u PERL_UNUSED_DECL, SV** o) { dTHX; *o = sv_newmortal(); return 0; } -STATIC_INLINE int template_callback_true(unpack_user* u, SV** o) +STATIC_INLINE int template_callback_true(unpack_user* u PERL_UNUSED_DECL, SV** o) { dTHX; *o = get_bool("Data::MessagePack::true"); return 0; } -STATIC_INLINE int template_callback_false(unpack_user* u, SV** o) +STATIC_INLINE int template_callback_false(unpack_user* u PERL_UNUSED_DECL, SV** o) { dTHX; *o = get_bool("Data::MessagePack::false"); return 0; } -STATIC_INLINE int template_callback_array(unpack_user* u, unsigned int n, SV** o) +STATIC_INLINE int template_callback_array(unpack_user* u PERL_UNUSED_DECL, unsigned int n, SV** o) { dTHX; AV* a = (AV*)sv_2mortal((SV*)newAV()); @@ -159,7 +159,7 @@ STATIC_INLINE int template_callback_array(unpack_user* u, unsigned int n, SV** o return 0; } -STATIC_INLINE int template_callback_array_item(unpack_user* u, SV** c, SV* o) +STATIC_INLINE int template_callback_array_item(unpack_user* u PERL_UNUSED_DECL, SV** c, SV* o) { dTHX; av_push((AV*)SvRV(*c), o); @@ -167,7 +167,7 @@ STATIC_INLINE int template_callback_array_item(unpack_user* u, SV** c, SV* o) return 0; } -STATIC_INLINE int template_callback_map(unpack_user* u, unsigned int n, SV** o) +STATIC_INLINE int template_callback_map(unpack_user* u PERL_UNUSED_DECL, unsigned int n PERL_UNUSED_DECL, SV** o) { dTHX; HV* h = (HV*)sv_2mortal((SV*)newHV()); @@ -175,15 +175,15 @@ STATIC_INLINE int template_callback_map(unpack_user* u, unsigned int n, SV** o) return 0; } -STATIC_INLINE int template_callback_map_item(unpack_user* u, SV** c, SV* k, SV* v) +STATIC_INLINE int template_callback_map_item(unpack_user* u PERL_UNUSED_DECL, SV** c, SV* k, SV* v) { dTHX; - hv_store_ent((HV*)SvRV(*c), k, v, 0); + (void)hv_store_ent((HV*)SvRV(*c), k, v, 0); SvREFCNT_inc(v); return 0; } -STATIC_INLINE int template_callback_raw(unpack_user* u, const char* b, const char* p, unsigned int l, SV** o) +STATIC_INLINE int template_callback_raw(unpack_user* u PERL_UNUSED_DECL, const char* b PERL_UNUSED_DECL, const char* p, unsigned int l, SV** o) { dTHX; /* *o = newSVpvn_flags(p, l, SVs_TEMP); <= this does not work. */ @@ -203,7 +203,7 @@ STATIC_INLINE int template_callback_raw(unpack_user* u, const char* b, const cha STATIC_INLINE SV* _msgpack_unpack(SV* data, int limit) { msgpack_unpack_t mp; dTHX; - unpack_user u = {0, &PL_sv_undef}; + unpack_user u = {0, &PL_sv_undef, false}; int ret; size_t from = 0; STRLEN dlen; @@ -248,7 +248,6 @@ XS(xs_unpack_limit) { XS(xs_unpack) { dXSARGS; - msgpack_unpack_t mp; if (items != 2) { Perl_croak(aTHX_ "Usage: Data::MessagePack->unpack('datadata')"); @@ -300,7 +299,7 @@ STATIC_INLINE SV* _execute_impl(SV* self, SV* data, UV off, I32 limit) { long dlen = limit; int ret; - if(from >= dlen) { + if(from >= (size_t)dlen) { Perl_croak(aTHX_ "offset is bigger than data buffer size."); } From 6981234736b10631fc79ffe59933ee3a009c0cc2 Mon Sep 17 00:00:00 2001 From: gfx Date: Wed, 15 Sep 2010 13:09:14 +0900 Subject: [PATCH 13/59] Fix a possible mis-unpack on int64 --- perl/xs-src/unpack.c | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/perl/xs-src/unpack.c b/perl/xs-src/unpack.c index 108f9fda..4d4e965c 100644 --- a/perl/xs-src/unpack.c +++ b/perl/xs-src/unpack.c @@ -111,7 +111,11 @@ STATIC_INLINE int template_callback_int32(unpack_user* u PERL_UNUSED_DECL, int32 STATIC_INLINE int template_callback_int64(unpack_user* u PERL_UNUSED_DECL, int64_t d, SV** o) { dTHX; +#if IVSIZE==4 + *o = sv_2mortal(newSVnv(d)); +#else *o = sv_2mortal(newSViv(d)); +#endif return 0; } From d36543b20419fa87ec71c42ee5f80ca1e03f71a1 Mon Sep 17 00:00:00 2001 From: gfx Date: Wed, 15 Sep 2010 13:12:17 +0900 Subject: [PATCH 14/59] Micro optimizations --- perl/xs-src/unpack.c | 14 +++++++------- 1 file changed, 7 insertions(+), 7 deletions(-) diff --git a/perl/xs-src/unpack.c b/perl/xs-src/unpack.c index 4d4e965c..0a79ef5f 100644 --- a/perl/xs-src/unpack.c +++ b/perl/xs-src/unpack.c @@ -157,9 +157,9 @@ STATIC_INLINE int template_callback_false(unpack_user* u PERL_UNUSED_DECL, SV** STATIC_INLINE int template_callback_array(unpack_user* u PERL_UNUSED_DECL, unsigned int n, SV** o) { dTHX; - AV* a = (AV*)sv_2mortal((SV*)newAV()); - *o = sv_2mortal((SV*)newRV_inc((SV*)a)); - av_extend(a, n); + AV* const a = newAV(); + *o = sv_2mortal(newRV_noinc((SV*)a)); + av_extend(a, n + 1); return 0; } @@ -167,15 +167,15 @@ STATIC_INLINE int template_callback_array_item(unpack_user* u PERL_UNUSED_DECL, { dTHX; av_push((AV*)SvRV(*c), o); - SvREFCNT_inc(o); + SvREFCNT_inc_simple_void_NN(o); return 0; } STATIC_INLINE int template_callback_map(unpack_user* u PERL_UNUSED_DECL, unsigned int n PERL_UNUSED_DECL, SV** o) { dTHX; - HV* h = (HV*)sv_2mortal((SV*)newHV()); - *o = sv_2mortal(newRV_inc((SV*)h)); + HV* const h = newHV(); + *o = sv_2mortal(newRV_noinc((SV*)h)); return 0; } @@ -183,7 +183,7 @@ STATIC_INLINE int template_callback_map_item(unpack_user* u PERL_UNUSED_DECL, SV { dTHX; (void)hv_store_ent((HV*)SvRV(*c), k, v, 0); - SvREFCNT_inc(v); + SvREFCNT_inc_simple_void_NN(v); return 0; } From c694f1a4a9b5df801419d23265d6519c59f9e1ae Mon Sep 17 00:00:00 2001 From: gfx Date: Wed, 15 Sep 2010 13:16:13 +0900 Subject: [PATCH 15/59] Tweaks --- perl/xs-src/unpack.c | 18 ++++++++++++------ 1 file changed, 12 insertions(+), 6 deletions(-) diff --git a/perl/xs-src/unpack.c b/perl/xs-src/unpack.c index 0a79ef5f..e3bb901e 100644 --- a/perl/xs-src/unpack.c +++ b/perl/xs-src/unpack.c @@ -204,7 +204,7 @@ STATIC_INLINE int template_callback_raw(unpack_user* u PERL_UNUSED_DECL, const c #include "msgpack/unpack_template.h" -STATIC_INLINE SV* _msgpack_unpack(SV* data, int limit) { +STATIC_INLINE SV* _msgpack_unpack(SV* data, size_t limit PERL_UNUSED_DECL) { msgpack_unpack_t mp; dTHX; unpack_user u = {0, &PL_sv_undef, false}; @@ -252,14 +252,20 @@ XS(xs_unpack_limit) { XS(xs_unpack) { dXSARGS; + SV* const data = ST(1); + size_t limit; - if (items != 2) { - Perl_croak(aTHX_ "Usage: Data::MessagePack->unpack('datadata')"); + if (items == 2) { + limit = sv_len(data); + } + else if(items == 3) { + limit = SvUVx(ST(2)); + } + else { + Perl_croak(aTHX_ "Usage: Data::MessagePack->unpack('data' [, $limit])"); } - { - ST(0) = _msgpack_unpack(ST(1), sv_len(ST(1))); - } + ST(0) = _msgpack_unpack(data, limit); XSRETURN(1); } From 6852a8ca9d8585fd42ec761900d334ae964732c9 Mon Sep 17 00:00:00 2001 From: gfx Date: Wed, 15 Sep 2010 13:16:55 +0900 Subject: [PATCH 16/59] Remove an unused function: xs_unpack_limit --- perl/xs-src/unpack.c | 15 --------------- 1 file changed, 15 deletions(-) diff --git a/perl/xs-src/unpack.c b/perl/xs-src/unpack.c index e3bb901e..5e757173 100644 --- a/perl/xs-src/unpack.c +++ b/perl/xs-src/unpack.c @@ -235,21 +235,6 @@ STATIC_INLINE SV* _msgpack_unpack(SV* data, size_t limit PERL_UNUSED_DECL) { } } -XS(xs_unpack_limit) { - dXSARGS; - - if (items != 3) { - Perl_croak(aTHX_ "Usage: Data::MessagePack->unpack('datadata', $limit)"); - } - - { - int limit = SvIV(ST(2)); - ST(0) = _msgpack_unpack(ST(1), limit); - } - XSRETURN(1); -} - - XS(xs_unpack) { dXSARGS; SV* const data = ST(1); From 859969241a8695e306789ed30659d05571db8fe2 Mon Sep 17 00:00:00 2001 From: gfx Date: Wed, 15 Sep 2010 13:20:20 +0900 Subject: [PATCH 17/59] Tweaks --- perl/xs-src/unpack.c | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/perl/xs-src/unpack.c b/perl/xs-src/unpack.c index 5e757173..78942233 100644 --- a/perl/xs-src/unpack.c +++ b/perl/xs-src/unpack.c @@ -190,8 +190,8 @@ STATIC_INLINE int template_callback_map_item(unpack_user* u PERL_UNUSED_DECL, SV STATIC_INLINE int template_callback_raw(unpack_user* u PERL_UNUSED_DECL, const char* b PERL_UNUSED_DECL, const char* p, unsigned int l, SV** o) { dTHX; - /* *o = newSVpvn_flags(p, l, SVs_TEMP); <= this does not work. */ - *o = sv_2mortal((l==0) ? newSVpv("", 0) : newSVpv(p, l)); + /* newSVpvn_flags(p, l, SVs_TEMP) returns an undef if l == 0 */ + *o = ((l==0) ? newSVpvs_flags("", SVs_TEMP) : newSVpvn_flags(p, l, SVs_TEMP)); return 0; } From af73b9d11b0a8e0a0d1b6a02ee0b8213cca3867c Mon Sep 17 00:00:00 2001 From: gfx Date: Wed, 15 Sep 2010 13:22:39 +0900 Subject: [PATCH 18/59] Shortcut av_push() --- perl/xs-src/unpack.c | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/perl/xs-src/unpack.c b/perl/xs-src/unpack.c index 78942233..080c4bde 100644 --- a/perl/xs-src/unpack.c +++ b/perl/xs-src/unpack.c @@ -166,7 +166,8 @@ STATIC_INLINE int template_callback_array(unpack_user* u PERL_UNUSED_DECL, unsig STATIC_INLINE int template_callback_array_item(unpack_user* u PERL_UNUSED_DECL, SV** c, SV* o) { dTHX; - av_push((AV*)SvRV(*c), o); + AV* const a = (AV*)SvRV(*c); + (void)av_store(a, AvFILLp(a) + 1, o); // the same as av_push(a, o) SvREFCNT_inc_simple_void_NN(o); return 0; } From 0e0a2aa9810c22e3744694965e3d45cab6c135e6 Mon Sep 17 00:00:00 2001 From: gfx Date: Wed, 15 Sep 2010 13:34:18 +0900 Subject: [PATCH 19/59] Add various integers to benchmarks --- perl/benchmark/deserialize.pl | 4 +++- perl/benchmark/serialize.pl | 2 +- 2 files changed, 4 insertions(+), 2 deletions(-) diff --git a/perl/benchmark/deserialize.pl b/perl/benchmark/deserialize.pl index 9658c0c8..634a79ed 100644 --- a/perl/benchmark/deserialize.pl +++ b/perl/benchmark/deserialize.pl @@ -5,11 +5,13 @@ use JSON::XS; use Benchmark ':all'; use Storable; +#$Data::MessagePack::PreferInteger = 1; + my $a = { "method" => "handleMessage", "params" => [ "user1", "we were just talking" ], "id" => undef, - "array" => [ 1, 11, 234, -5, 1e5, 1e7, 1, 0, 3.14, sqrt(2) ] + "array" => [ 1, 1024, 70000, -5, 1e5, 1e7, 1, 0, 3.14, sqrt(2) ], }; my $j = JSON::XS::encode_json($a); my $m = Data::MessagePack->pack($a); diff --git a/perl/benchmark/serialize.pl b/perl/benchmark/serialize.pl index ee9e7a45..e0509ffa 100644 --- a/perl/benchmark/serialize.pl +++ b/perl/benchmark/serialize.pl @@ -9,7 +9,7 @@ my $a = { "method" => "handleMessage", "params" => [ "user1", "we were just talking" ], "id" => undef, - "array" => [ 1, 11, 234, -5, 1e5, 1e7, 1, 0, 3.14, sqrt(2) ] + "array" => [ 1, 1024, 70000, -5, 1e5, 1e7, 1, 0, 3.14, sqrt(2) ], }; print "-- serialize\n"; From 1de03fbe180e9abed96aec275cf67b6f7d46a232 Mon Sep 17 00:00:00 2001 From: gfx Date: Wed, 15 Sep 2010 13:41:10 +0900 Subject: [PATCH 20/59] Tweaks for unpacker --- perl/xs-src/unpack.c | 15 +++++++++------ 1 file changed, 9 insertions(+), 6 deletions(-) diff --git a/perl/xs-src/unpack.c b/perl/xs-src/unpack.c index 080c4bde..320eb45b 100644 --- a/perl/xs-src/unpack.c +++ b/perl/xs-src/unpack.c @@ -196,12 +196,15 @@ STATIC_INLINE int template_callback_raw(unpack_user* u PERL_UNUSED_DECL, const c return 0; } -#define UNPACKER(from, name) \ - msgpack_unpack_t *name; \ - name = INT2PTR(msgpack_unpack_t*, SvROK((from)) ? SvIV(SvRV((from))) : SvIV((from))); \ - if(name == NULL) { \ - Perl_croak(aTHX_ "NULL found for " # name " when shouldn't be."); \ - } +#define UNPACKER(from, name) \ + msgpack_unpack_t *name; \ + if(!(SvROK(from) && SvIOK(SvRV(from)))) { \ + Perl_croak(aTHX_ "Invalid unpacker instance for " #name); \ + } \ + name = INT2PTR(msgpack_unpack_t*, SvIVX(SvRV((from)))); \ + if(name == NULL) { \ + Perl_croak(aTHX_ "NULL found for " # name " when shouldn't be."); \ + } #include "msgpack/unpack_template.h" From 6a60cb4dc0d5c2e36a4aa8fd8dbe5b3c826a935d Mon Sep 17 00:00:00 2001 From: gfx Date: Wed, 15 Sep 2010 13:54:18 +0900 Subject: [PATCH 21/59] Add const --- perl/xs-src/pack.c | 23 ++++++++++++----------- 1 file changed, 12 insertions(+), 11 deletions(-) diff --git a/perl/xs-src/pack.c b/perl/xs-src/pack.c index c0c610e7..6926839b 100644 --- a/perl/xs-src/pack.c +++ b/perl/xs-src/pack.c @@ -13,17 +13,18 @@ static inline void msgpack_pack ## name typedef struct { - char *cur; /* SvPVX (sv) + current output position */ - char *end; /* SvEND (sv) */ - SV *sv; /* result scalar */ + char *cur; /* SvPVX (sv) + current output position */ + const char *end; /* SvEND (sv) */ + SV *sv; /* result scalar */ } enc_t; -static void need(enc_t *enc, STRLEN len); + +STATIC_INLINE void need(enc_t* const enc, STRLEN const len); #define msgpack_pack_user enc_t* #define msgpack_pack_append_buffer(enc, buf, len) \ - need(enc, len); \ - memcpy(enc->cur, buf, len); \ + need(enc, len); \ + memcpy(enc->cur, buf, len); \ enc->cur += len; #include "msgpack/pack_template.h" @@ -46,14 +47,14 @@ static void need(enc_t *enc, STRLEN len); #define ERR_NESTING_EXCEEDED "perl structure exceeds maximum nesting level (max_depth set too low?)" -STATIC_INLINE void need(enc_t *enc, STRLEN len) +STATIC_INLINE void need(enc_t* const enc, STRLEN const len) { - dTHX; if (enc->cur + len >= enc->end) { - STRLEN cur = enc->cur - (char *)SvPVX (enc->sv); + dTHX; + STRLEN const cur = enc->cur - SvPVX_const(enc->sv); sv_grow (enc->sv, cur + (len < (cur >> 2) ? cur >> 2 : len) + 1); - enc->cur = SvPVX (enc->sv) + cur; - enc->end = SvPVX (enc->sv) + SvLEN (enc->sv) - 1; + enc->cur = SvPVX_mutable(enc->sv) + cur; + enc->end = SvPVX_const(enc->sv) + SvLEN (enc->sv) - 1; } } From 83acd6529fe4902624117cab62c2377aa3fe2b27 Mon Sep 17 00:00:00 2001 From: gfx Date: Wed, 15 Sep 2010 14:06:10 +0900 Subject: [PATCH 22/59] Remove an unused user data: source (sv) --- perl/xs-src/unpack.c | 22 ++++++++-------------- 1 file changed, 8 insertions(+), 14 deletions(-) diff --git a/perl/xs-src/unpack.c b/perl/xs-src/unpack.c index 320eb45b..90cfa7b8 100644 --- a/perl/xs-src/unpack.c +++ b/perl/xs-src/unpack.c @@ -3,9 +3,8 @@ #include "xshelper.h" typedef struct { - int finished; - SV* source; - int incremented; + bool finished; + bool incremented; } unpack_user; #include "msgpack/unpack_define.h" @@ -211,7 +210,7 @@ STATIC_INLINE int template_callback_raw(unpack_user* u PERL_UNUSED_DECL, const c STATIC_INLINE SV* _msgpack_unpack(SV* data, size_t limit PERL_UNUSED_DECL) { msgpack_unpack_t mp; dTHX; - unpack_user u = {0, &PL_sv_undef, false}; + unpack_user u = {false, false}; int ret; size_t from = 0; STRLEN dlen; @@ -221,10 +220,7 @@ STATIC_INLINE SV* _msgpack_unpack(SV* data, size_t limit PERL_UNUSED_DECL) { template_init(&mp); mp.user = u; - mp.user.source = data; ret = template_execute(&mp, dptr, (size_t)dlen, &from); - mp.user.source = &PL_sv_undef; - obj = template_data(&mp); if(ret < 0) { @@ -264,7 +260,7 @@ XS(xs_unpack) { STATIC_INLINE void _reset(SV* self) { dTHX; - unpack_user u = {0, &PL_sv_undef, 0}; + unpack_user u = {false, false}; UNPACKER(self, mp); template_init(mp); @@ -302,17 +298,15 @@ STATIC_INLINE SV* _execute_impl(SV* self, SV* data, UV off, I32 limit) { Perl_croak(aTHX_ "offset is bigger than data buffer size."); } - mp->user.source = data; ret = template_execute(mp, dptr, (size_t)dlen, &from); - mp->user.source = &PL_sv_undef; if(ret < 0) { Perl_croak(aTHX_ "parse error."); } else if(ret > 0) { - mp->user.finished = 1; + mp->user.finished = true; return sv_2mortal(newSVuv(from)); } else { - mp->user.finished = 0; + mp->user.finished = false; return sv_2mortal(newSVuv(from)); } } @@ -335,7 +329,7 @@ XS(xs_unpacker_execute) { SV * d2 = template_data(mp); if (!mp->user.incremented && d2) { SvREFCNT_inc(d2); - mp->user.incremented = 1; + mp->user.incremented = true; } } } @@ -366,7 +360,7 @@ XS(xs_unpacker_is_finished) { } UNPACKER(ST(0), mp); - ST(0) = (mp->user.finished) ? &PL_sv_yes : &PL_sv_no; + ST(0) = boolSV(mp->user.finished); XSRETURN(1); } From f32234291e26301d4159b109b7fed78fb6e3ee56 Mon Sep 17 00:00:00 2001 From: gfx Date: Wed, 15 Sep 2010 14:07:33 +0900 Subject: [PATCH 23/59] Remove an useless local variable --- perl/xs-src/unpack.c | 11 +++++------ 1 file changed, 5 insertions(+), 6 deletions(-) diff --git a/perl/xs-src/unpack.c b/perl/xs-src/unpack.c index 90cfa7b8..85136d97 100644 --- a/perl/xs-src/unpack.c +++ b/perl/xs-src/unpack.c @@ -285,20 +285,19 @@ XS(xs_unpacker_new) { XSRETURN(1); } -STATIC_INLINE SV* _execute_impl(SV* self, SV* data, UV off, I32 limit) { +STATIC_INLINE SV* _execute_impl(SV* self, SV* data, UV off, size_t limit) { dTHX; UNPACKER(self, mp); size_t from = off; const char* dptr = SvPV_nolen_const(data); - long dlen = limit; int ret; - if(from >= (size_t)dlen) { + if(from >= limit) { Perl_croak(aTHX_ "offset is bigger than data buffer size."); } - ret = template_execute(mp, dptr, (size_t)dlen, &from); + ret = template_execute(mp, dptr, limit, &from); if(ret < 0) { Perl_croak(aTHX_ "parse error."); @@ -323,7 +322,7 @@ XS(xs_unpacker_execute) { SV* data = ST(1); IV off = SvIV(ST(2)); /* offset of $data. normaly, 0. */ - ST(0) = _execute_impl(self, data, off, sv_len(data)); + ST(0) = _execute_impl(self, data, off, (size_t)sv_len(data)); { SV * d2 = template_data(mp); @@ -348,7 +347,7 @@ XS(xs_unpacker_execute_limit) { IV off = SvIV(ST(2)); IV limit = SvIV(ST(3)); - ST(0) = _execute_impl(self, data, off, limit); + ST(0) = _execute_impl(self, data, off, (size_t)limit); XSRETURN(1); } From f0e044ecd8550a14a9fbda9448bd74a3dace4d1a Mon Sep 17 00:00:00 2001 From: gfx Date: Wed, 15 Sep 2010 14:09:03 +0900 Subject: [PATCH 24/59] Cleanup --- perl/xs-src/unpack.c | 5 +---- 1 file changed, 1 insertion(+), 4 deletions(-) diff --git a/perl/xs-src/unpack.c b/perl/xs-src/unpack.c index 85136d97..9500212c 100644 --- a/perl/xs-src/unpack.c +++ b/perl/xs-src/unpack.c @@ -301,11 +301,8 @@ STATIC_INLINE SV* _execute_impl(SV* self, SV* data, UV off, size_t limit) { if(ret < 0) { Perl_croak(aTHX_ "parse error."); - } else if(ret > 0) { - mp->user.finished = true; - return sv_2mortal(newSVuv(from)); } else { - mp->user.finished = false; + mp->user.finished = (ret > 0) ? true : false; return sv_2mortal(newSVuv(from)); } } From 5bdac96375f0cc5b75313cc3a9a7bbeb21594a0b Mon Sep 17 00:00:00 2001 From: gfx Date: Wed, 15 Sep 2010 14:18:38 +0900 Subject: [PATCH 25/59] The object root can be NULL --- perl/xs-src/unpack.c | 9 ++++----- 1 file changed, 4 insertions(+), 5 deletions(-) diff --git a/perl/xs-src/unpack.c b/perl/xs-src/unpack.c index 9500212c..dce6782c 100644 --- a/perl/xs-src/unpack.c +++ b/perl/xs-src/unpack.c @@ -50,8 +50,7 @@ static int template_execute(msgpack_unpack_t* u PERL_UNUSED_DECL, STATIC_INLINE SV* template_callback_root(unpack_user* u PERL_UNUSED_DECL) { - dTHX; - return &PL_sv_undef; + return NULL; } STATIC_INLINE int template_callback_uint8(unpack_user* u PERL_UNUSED_DECL, uint8_t d, SV** o) @@ -310,7 +309,7 @@ STATIC_INLINE SV* _execute_impl(SV* self, SV* data, UV off, size_t limit) { XS(xs_unpacker_execute) { dXSARGS; if (items != 3) { - Perl_croak(aTHX_ "Usage: $unpacker->execute_limit(data, off)"); + Perl_croak(aTHX_ "Usage: $unpacker->execute(data, off)"); } UNPACKER(ST(0), mp); @@ -398,8 +397,8 @@ XS(xs_unpacker_destroy) { } UNPACKER(ST(0), mp); - SV * data = template_data(mp); - if (SvOK(data)) { + SV* const data = template_data(mp); + if (data) { SvREFCNT_dec(data); } Safefree(mp); From 0ae206b1bb5233b7f4538dcf5fc40ff8080588bf Mon Sep 17 00:00:00 2001 From: gfx Date: Wed, 15 Sep 2010 14:19:22 +0900 Subject: [PATCH 26/59] Revert "The object root can be NULL" This reverts commit 5bdac96375f0cc5b75313cc3a9a7bbeb21594a0b. --- perl/xs-src/unpack.c | 9 +++++---- 1 file changed, 5 insertions(+), 4 deletions(-) diff --git a/perl/xs-src/unpack.c b/perl/xs-src/unpack.c index dce6782c..9500212c 100644 --- a/perl/xs-src/unpack.c +++ b/perl/xs-src/unpack.c @@ -50,7 +50,8 @@ static int template_execute(msgpack_unpack_t* u PERL_UNUSED_DECL, STATIC_INLINE SV* template_callback_root(unpack_user* u PERL_UNUSED_DECL) { - return NULL; + dTHX; + return &PL_sv_undef; } STATIC_INLINE int template_callback_uint8(unpack_user* u PERL_UNUSED_DECL, uint8_t d, SV** o) @@ -309,7 +310,7 @@ STATIC_INLINE SV* _execute_impl(SV* self, SV* data, UV off, size_t limit) { XS(xs_unpacker_execute) { dXSARGS; if (items != 3) { - Perl_croak(aTHX_ "Usage: $unpacker->execute(data, off)"); + Perl_croak(aTHX_ "Usage: $unpacker->execute_limit(data, off)"); } UNPACKER(ST(0), mp); @@ -397,8 +398,8 @@ XS(xs_unpacker_destroy) { } UNPACKER(ST(0), mp); - SV* const data = template_data(mp); - if (data) { + SV * data = template_data(mp); + if (SvOK(data)) { SvREFCNT_dec(data); } Safefree(mp); From 07e68aa6945e4be0820f9c53a3cc1bbbb041a556 Mon Sep 17 00:00:00 2001 From: gfx Date: Wed, 15 Sep 2010 14:20:32 +0900 Subject: [PATCH 27/59] Fix an usage message --- perl/xs-src/unpack.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/perl/xs-src/unpack.c b/perl/xs-src/unpack.c index 9500212c..c4ac22fd 100644 --- a/perl/xs-src/unpack.c +++ b/perl/xs-src/unpack.c @@ -310,7 +310,7 @@ STATIC_INLINE SV* _execute_impl(SV* self, SV* data, UV off, size_t limit) { XS(xs_unpacker_execute) { dXSARGS; if (items != 3) { - Perl_croak(aTHX_ "Usage: $unpacker->execute_limit(data, off)"); + Perl_croak(aTHX_ "Usage: $unpacker->execute(data, off)"); } UNPACKER(ST(0), mp); From 7644555d6bd0f17472f02c18dd65bd24aa14edd4 Mon Sep 17 00:00:00 2001 From: gfx Date: Wed, 15 Sep 2010 14:21:44 +0900 Subject: [PATCH 28/59] Use sv_mortalcopy() --- perl/xs-src/unpack.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/perl/xs-src/unpack.c b/perl/xs-src/unpack.c index c4ac22fd..2b6eafe2 100644 --- a/perl/xs-src/unpack.c +++ b/perl/xs-src/unpack.c @@ -368,7 +368,7 @@ XS(xs_unpacker_data) { } UNPACKER(ST(0), mp); - ST(0) = sv_2mortal(newSVsv(template_data(mp))); + ST(0) = sv_mortalcopy(template_data(mp)); XSRETURN(1); } From cd862409cc6028bac9fd5825cfdc0386804091de Mon Sep 17 00:00:00 2001 From: gfx Date: Wed, 15 Sep 2010 14:25:50 +0900 Subject: [PATCH 29/59] Clean up --- perl/xs-src/unpack.c | 4 +--- 1 file changed, 1 insertion(+), 3 deletions(-) diff --git a/perl/xs-src/unpack.c b/perl/xs-src/unpack.c index 2b6eafe2..2d659b4b 100644 --- a/perl/xs-src/unpack.c +++ b/perl/xs-src/unpack.c @@ -382,9 +382,7 @@ XS(xs_unpacker_reset) { UNPACKER(ST(0), mp); { SV * data = template_data(mp); - if (data) { - SvREFCNT_dec(data); - } + SvREFCNT_dec(data); } _reset(ST(0)); From 11cde61eab8e15f9936c3234897cef90fef05cd6 Mon Sep 17 00:00:00 2001 From: gfx Date: Wed, 15 Sep 2010 14:38:26 +0900 Subject: [PATCH 30/59] No debug output --- perl/xs-src/pack.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/perl/xs-src/pack.c b/perl/xs-src/pack.c index 6926839b..5eaf17e5 100644 --- a/perl/xs-src/pack.c +++ b/perl/xs-src/pack.c @@ -238,7 +238,7 @@ STATIC_INLINE void _msgpack_pack_rv(enc_t *enc, SV* sv, int depth) { else if (len == 1 && *pv == '0') msgpack_pack_false(enc); else { - sv_dump(sv); + //sv_dump(sv); croak("cannot encode reference to scalar '%s' unless the scalar is 0 or 1", SvPV_nolen (sv_2mortal (newRV_inc (sv)))); } From a11165830bc6075c39978adcb72af07d5d7c6234 Mon Sep 17 00:00:00 2001 From: gfx Date: Wed, 15 Sep 2010 15:06:03 +0900 Subject: [PATCH 31/59] More useful error messages --- perl/xs-src/unpack.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/perl/xs-src/unpack.c b/perl/xs-src/unpack.c index 2d659b4b..9ccc44ad 100644 --- a/perl/xs-src/unpack.c +++ b/perl/xs-src/unpack.c @@ -294,7 +294,7 @@ STATIC_INLINE SV* _execute_impl(SV* self, SV* data, UV off, size_t limit) { int ret; if(from >= limit) { - Perl_croak(aTHX_ "offset is bigger than data buffer size."); + Perl_croak(aTHX_ "offset (%lu) is bigger than data buffer size (%lu)", (unsigned long)off, (unsigned long)limit); } ret = template_execute(mp, dptr, limit, &from); From f8ee79ab72034223b0ae698b00e7e369d217cb47 Mon Sep 17 00:00:00 2001 From: gfx Date: Wed, 15 Sep 2010 15:25:48 +0900 Subject: [PATCH 32/59] Add failing tests --- perl/t/06_stream_unpack2.t | 26 +++++++++++++++++++++++++- 1 file changed, 25 insertions(+), 1 deletion(-) diff --git a/perl/t/06_stream_unpack2.t b/perl/t/06_stream_unpack2.t index eaf2cb4b..bc158cdd 100644 --- a/perl/t/06_stream_unpack2.t +++ b/perl/t/06_stream_unpack2.t @@ -3,7 +3,7 @@ use warnings; use Data::MessagePack; use Test::More tests => 6; -my $input = [(undef)x16]; +my $input = [42, "foo", { x => [ (undef)x16 ] }, 3.14 ]; my $packed = Data::MessagePack->pack($input); is_deeply(Data::MessagePack->unpack($packed), $input); @@ -17,9 +17,33 @@ is_deeply(Data::MessagePack->unpack($packed), $input); { my $up = Data::MessagePack::Unpacker->new(); is $up->execute(substr($packed, 0, 3), 0), 3; + ok !$up->is_finished; $up->execute($packed, 3); ok $up->is_finished; is_deeply $up->data, $input; } +{ + my $up = Data::MessagePack::Unpacker->new(); + my $offset = 0; + my $size = 5; + + note "length: ", length($packed); + while(not $up->is_finished) { + note "offset: ", $offset; + my $bytes = substr($packed, $offset, $size); + note join " ", map { unpack 'H2', $_ } split //, $bytes; + my $x = $up->execute($bytes, 0); + if($x <= 0) { + diag "Something's wrong: $x"; + last; + } + else { + $offset += $x; + } + } + ok $up->is_finished; + is_deeply $up->data, $input; +} + From fe7e7a8d077de47f3c92dad3ec6eb39e8c1ae077 Mon Sep 17 00:00:00 2001 From: gfx Date: Wed, 15 Sep 2010 15:26:02 +0900 Subject: [PATCH 33/59] Add leaktrace tests --- perl/xt/leaks/leaktrace.t | 40 +++++++++++++++++++++++++++++++++++++++ 1 file changed, 40 insertions(+) create mode 100755 perl/xt/leaks/leaktrace.t diff --git a/perl/xt/leaks/leaktrace.t b/perl/xt/leaks/leaktrace.t new file mode 100755 index 00000000..ff64f6ff --- /dev/null +++ b/perl/xt/leaks/leaktrace.t @@ -0,0 +1,40 @@ +#!perl -w +use strict; +use Test::Requires 'Test::LeakTrace'; +use Test::More; + +use Data::MessagePack; + +my $data = { + a => 'foo', + b => 42, + c => undef, + d => [qw(bar baz)], + e => 3.14, +}; + +no_leaks_ok { + my $s = Data::MessagePack->pack($data); +}; + +no_leaks_ok { + eval { Data::MessagePack->pack([\*STDIN]) }; + #note $@; + $@ or die "it must die"; +}; + +my $s = Data::MessagePack->pack($data); + +no_leaks_ok { + my $data = Data::MessagePack->unpack($s); +}; + +no_leaks_ok { + my $ss = $s; + chop $ss; + eval { Data::MessagePack->unpack($ss) }; + #note $@; + $@ or die "it must die"; +}; + +done_testing; From 4cb6d6995f4b07971078f684c035fa343b0cc567 Mon Sep 17 00:00:00 2001 From: gfx Date: Wed, 15 Sep 2010 15:27:26 +0900 Subject: [PATCH 34/59] Make the code clearer --- perl/xs-src/unpack.c | 32 +++++++++++++++----------------- 1 file changed, 15 insertions(+), 17 deletions(-) diff --git a/perl/xs-src/unpack.c b/perl/xs-src/unpack.c index 9ccc44ad..9219ed26 100644 --- a/perl/xs-src/unpack.c +++ b/perl/xs-src/unpack.c @@ -37,7 +37,6 @@ get_bool (const char *name) { } /* ---------------------------------------------------------------------- */ - struct template_context; typedef struct template_context msgpack_unpack_t; @@ -166,6 +165,7 @@ STATIC_INLINE int template_callback_array_item(unpack_user* u PERL_UNUSED_DECL, { dTHX; AV* const a = (AV*)SvRV(*c); + assert(SvTYPE(a) == SVt_PVAV); (void)av_store(a, AvFILLp(a) + 1, o); // the same as av_push(a, o) SvREFCNT_inc_simple_void_NN(o); return 0; @@ -182,7 +182,9 @@ STATIC_INLINE int template_callback_map(unpack_user* u PERL_UNUSED_DECL, unsigne STATIC_INLINE int template_callback_map_item(unpack_user* u PERL_UNUSED_DECL, SV** c, SV* k, SV* v) { dTHX; - (void)hv_store_ent((HV*)SvRV(*c), k, v, 0); + HV* const h = (HV*)SvRV(*c); + assert(SvTYPE(h) == SVt_PVHV); + (void)hv_store_ent(h, k, v, 0); SvREFCNT_inc_simple_void_NN(v); return 0; } @@ -321,12 +323,10 @@ XS(xs_unpacker_execute) { ST(0) = _execute_impl(self, data, off, (size_t)sv_len(data)); - { - SV * d2 = template_data(mp); - if (!mp->user.incremented && d2) { - SvREFCNT_inc(d2); - mp->user.incremented = true; - } + if (!mp->user.incremented) { + SV* tmp_obj = template_data(mp); + SvREFCNT_inc_simple_void_NN(tmp_obj); + mp->user.incremented = true; } } @@ -368,7 +368,7 @@ XS(xs_unpacker_data) { } UNPACKER(ST(0), mp); - ST(0) = sv_mortalcopy(template_data(mp)); + ST(0) = template_data(mp); XSRETURN(1); } @@ -380,10 +380,9 @@ XS(xs_unpacker_reset) { } UNPACKER(ST(0), mp); - { - SV * data = template_data(mp); - SvREFCNT_dec(data); - } + + SV* const data = template_data(mp); + SvREFCNT_dec(data); _reset(ST(0)); XSRETURN(0); @@ -396,10 +395,9 @@ XS(xs_unpacker_destroy) { } UNPACKER(ST(0), mp); - SV * data = template_data(mp); - if (SvOK(data)) { - SvREFCNT_dec(data); - } + + SV* const data = template_data(mp); + SvREFCNT_dec(data); Safefree(mp); XSRETURN(0); From afbddbfcda1ee0acde3c5343a77c4c575f73ad95 Mon Sep 17 00:00:00 2001 From: gfx Date: Thu, 16 Sep 2010 20:24:01 +0900 Subject: [PATCH 35/59] Fix the stream unpacker --- perl/t/06_stream_unpack2.t | 33 ++--- perl/xs-src/MessagePack.c | 1 + perl/xs-src/pack.c | 2 +- perl/xs-src/unpack.c | 254 +++++++++++++++++-------------------- perl/xt/leaks/leaktrace.t | 22 +++- 5 files changed, 148 insertions(+), 164 deletions(-) diff --git a/perl/t/06_stream_unpack2.t b/perl/t/06_stream_unpack2.t index bc158cdd..68a28731 100644 --- a/perl/t/06_stream_unpack2.t +++ b/perl/t/06_stream_unpack2.t @@ -1,9 +1,9 @@ use strict; use warnings; use Data::MessagePack; -use Test::More tests => 6; +use Test::More tests => 9; -my $input = [42, "foo", { x => [ (undef)x16 ] }, 3.14 ]; +my $input = [ 42, "foo", { x => [ (1) x 16 ] }, undef, 1 ]; my $packed = Data::MessagePack->pack($input); is_deeply(Data::MessagePack->unpack($packed), $input); @@ -26,24 +26,19 @@ is_deeply(Data::MessagePack->unpack($packed), $input); { my $up = Data::MessagePack::Unpacker->new(); - my $offset = 0; - my $size = 5; + my $size = 8; - note "length: ", length($packed); - while(not $up->is_finished) { - note "offset: ", $offset; - my $bytes = substr($packed, $offset, $size); - note join " ", map { unpack 'H2', $_ } split //, $bytes; - my $x = $up->execute($bytes, 0); - if($x <= 0) { - diag "Something's wrong: $x"; - last; - } - else { - $offset += $x; - } + note "packed size: ", length($packed); + open my $stream, '<:bytes :scalar', \$packed; + my $buff; + while( read($stream, $buff, $size) ) { + note "buff: ", join " ", map { unpack 'H2', $_ } split //, $buff; + + $up->execute($buff); } - ok $up->is_finished; - is_deeply $up->data, $input; + ok $up->is_finished, 'is_finished'; + my $data = $up->data; + note explain($data); + is_deeply $data, $input; } diff --git a/perl/xs-src/MessagePack.c b/perl/xs-src/MessagePack.c index 259fd156..aba8ef91 100644 --- a/perl/xs-src/MessagePack.c +++ b/perl/xs-src/MessagePack.c @@ -14,6 +14,7 @@ void boot_Data__MessagePack_pack(void); XS(boot_Data__MessagePack) { dXSARGS; + PERL_UNUSED_VAR(items); boot_Data__MessagePack_pack(); diff --git a/perl/xs-src/pack.c b/perl/xs-src/pack.c index 5eaf17e5..9a58ed05 100644 --- a/perl/xs-src/pack.c +++ b/perl/xs-src/pack.c @@ -145,7 +145,7 @@ STATIC_INLINE int try_int(enc_t* enc, const char *p, size_t len) { } -static void _msgpack_pack_rv(enc_t *enc, SV* sv, int depth); +STATIC_INLINE void _msgpack_pack_rv(enc_t *enc, SV* sv, int depth); STATIC_INLINE void _msgpack_pack_sv(enc_t* const enc, SV* const sv, int const depth) { dTHX; diff --git a/perl/xs-src/unpack.c b/perl/xs-src/unpack.c index 9219ed26..a429ecd9 100644 --- a/perl/xs-src/unpack.c +++ b/perl/xs-src/unpack.c @@ -26,14 +26,9 @@ typedef struct { /* utility functions */ STATIC_INLINE SV * -get_bool (const char *name) { +get_bool (const char* const name) { dTHX; - SV * sv = sv_mortalcopy(get_sv( name, 1 )); - - SvREADONLY_on(sv); - SvREADONLY_on( SvRV(sv) ); - - return sv; + return newSVsv(get_sv( name, GV_ADD )); } /* ---------------------------------------------------------------------- */ @@ -49,85 +44,76 @@ static int template_execute(msgpack_unpack_t* u PERL_UNUSED_DECL, STATIC_INLINE SV* template_callback_root(unpack_user* u PERL_UNUSED_DECL) { - dTHX; - return &PL_sv_undef; + return NULL; } -STATIC_INLINE int template_callback_uint8(unpack_user* u PERL_UNUSED_DECL, uint8_t d, SV** o) +#if IVSIZE == 4 + +STATIC_INLINE int template_callback_UV(unpack_user* u PERL_UNUSED_DECL, UV const d, SV** o) { dTHX; - *o = sv_2mortal(newSVuv(d)); + *o = newSVuv(d); return 0; } -STATIC_INLINE int template_callback_uint16(unpack_user* u PERL_UNUSED_DECL, uint16_t d, SV** o) +STATIC_INLINE int template_callback_uint64(unpack_user* u PERL_UNUSED_DECL, uint64_t const d, SV** o) { dTHX; - *o = sv_2mortal(newSVuv(d)); + *o = newSVnv((NV)d); return 0; } -STATIC_INLINE int template_callback_uint32(unpack_user* u PERL_UNUSED_DECL, uint32_t d, SV** o) +STATIC_INLINE int template_callback_IV(unpack_user* u PERL_UNUSED_DECL, IV const d, SV** o) { dTHX; - *o = sv_2mortal(newSVuv(d)); + *o = newSViv(d); return 0; } -STATIC_INLINE int template_callback_uint64(unpack_user* u PERL_UNUSED_DECL, uint64_t d, SV** o) +STATIC_INLINE int template_callback_int64(unpack_user* u PERL_UNUSED_DECL, int64_t const d, SV** o) { dTHX; -#if IVSIZE==4 - *o = sv_2mortal(newSVnv(d)); -#else - *o = sv_2mortal(newSVuv(d)); -#endif + *o = newSVnv((NV)d); return 0; } -STATIC_INLINE int template_callback_int8(unpack_user* u PERL_UNUSED_DECL, int8_t d, SV** o) +#else /* IVSIZE == 8 */ + + +STATIC_INLINE int template_callback_UV(unpack_user* u PERL_UNUSED_DECL, UV const d, SV** o) { dTHX; - *o = sv_2mortal(newSViv(d)); + *o = newSVuv(d); return 0; } -STATIC_INLINE int template_callback_int16(unpack_user* u PERL_UNUSED_DECL, int16_t d, SV** o) +#define template_callback_uint64 template_callback_UV + +STATIC_INLINE int template_callback_IV(unpack_user* u PERL_UNUSED_DECL, IV const d, SV** o) { dTHX; - *o = sv_2mortal(newSViv(d)); + *o = newSViv(d); return 0; } -STATIC_INLINE int template_callback_int32(unpack_user* u PERL_UNUSED_DECL, int32_t d, SV** o) -{ - dTHX; - *o = sv_2mortal(newSViv(d)); - return 0; -} +#define template_callback_uint64 template_callback_IV -STATIC_INLINE int template_callback_int64(unpack_user* u PERL_UNUSED_DECL, int64_t d, SV** o) -{ - dTHX; -#if IVSIZE==4 - *o = sv_2mortal(newSVnv(d)); -#else - *o = sv_2mortal(newSViv(d)); -#endif - return 0; -} +#endif /* IVSIZE */ -STATIC_INLINE int template_callback_float(unpack_user* u PERL_UNUSED_DECL, float d, SV** o) -{ - dTHX; - *o = sv_2mortal(newSVnv(d)); - return 0; -} +#define template_callback_uint8 template_callback_UV +#define template_callback_uint16 template_callback_UV +#define template_callback_uint32 template_callback_UV + +#define template_callback_int8 template_callback_IV +#define template_callback_int16 template_callback_IV +#define template_callback_int32 template_callback_IV + +#define template_callback_float template_callback_double STATIC_INLINE int template_callback_double(unpack_user* u PERL_UNUSED_DECL, double d, SV** o) { dTHX; - *o = sv_2mortal(newSVnv(d)); + *o = newSVnv(d); return 0; } @@ -135,7 +121,7 @@ STATIC_INLINE int template_callback_double(unpack_user* u PERL_UNUSED_DECL, doub STATIC_INLINE int template_callback_nil(unpack_user* u PERL_UNUSED_DECL, SV** o) { dTHX; - *o = sv_newmortal(); + *o = newSV(0); return 0; } @@ -148,7 +134,8 @@ STATIC_INLINE int template_callback_true(unpack_user* u PERL_UNUSED_DECL, SV** o STATIC_INLINE int template_callback_false(unpack_user* u PERL_UNUSED_DECL, SV** o) { - dTHX; *o = get_bool("Data::MessagePack::false"); + dTHX; + *o = get_bool("Data::MessagePack::false"); return 0; } @@ -156,7 +143,7 @@ STATIC_INLINE int template_callback_array(unpack_user* u PERL_UNUSED_DECL, unsig { dTHX; AV* const a = newAV(); - *o = sv_2mortal(newRV_noinc((SV*)a)); + *o = newRV_noinc((SV*)a); av_extend(a, n + 1); return 0; } @@ -167,7 +154,6 @@ STATIC_INLINE int template_callback_array_item(unpack_user* u PERL_UNUSED_DECL, AV* const a = (AV*)SvRV(*c); assert(SvTYPE(a) == SVt_PVAV); (void)av_store(a, AvFILLp(a) + 1, o); // the same as av_push(a, o) - SvREFCNT_inc_simple_void_NN(o); return 0; } @@ -175,7 +161,7 @@ STATIC_INLINE int template_callback_map(unpack_user* u PERL_UNUSED_DECL, unsigne { dTHX; HV* const h = newHV(); - *o = sv_2mortal(newRV_noinc((SV*)h)); + *o = newRV_noinc((SV*)h); return 0; } @@ -185,7 +171,7 @@ STATIC_INLINE int template_callback_map_item(unpack_user* u PERL_UNUSED_DECL, SV HV* const h = (HV*)SvRV(*c); assert(SvTYPE(h) == SVt_PVHV); (void)hv_store_ent(h, k, v, 0); - SvREFCNT_inc_simple_void_NN(v); + SvREFCNT_dec(k); return 0; } @@ -193,10 +179,12 @@ STATIC_INLINE int template_callback_raw(unpack_user* u PERL_UNUSED_DECL, const c { dTHX; /* newSVpvn_flags(p, l, SVs_TEMP) returns an undef if l == 0 */ - *o = ((l==0) ? newSVpvs_flags("", SVs_TEMP) : newSVpvn_flags(p, l, SVs_TEMP)); + *o = ((l==0) ? newSVpvs("") : newSVpvn(p, l)); return 0; } +#include "msgpack/unpack_template.h" + #define UNPACKER(from, name) \ msgpack_unpack_t *name; \ if(!(SvROK(from) && SvIOK(SvRV(from)))) { \ @@ -207,36 +195,6 @@ STATIC_INLINE int template_callback_raw(unpack_user* u PERL_UNUSED_DECL, const c Perl_croak(aTHX_ "NULL found for " # name " when shouldn't be."); \ } -#include "msgpack/unpack_template.h" - -STATIC_INLINE SV* _msgpack_unpack(SV* data, size_t limit PERL_UNUSED_DECL) { - msgpack_unpack_t mp; - dTHX; - unpack_user u = {false, false}; - int ret; - size_t from = 0; - STRLEN dlen; - const char * dptr = SvPV_const(data, dlen); - SV* obj; - - template_init(&mp); - mp.user = u; - - ret = template_execute(&mp, dptr, (size_t)dlen, &from); - obj = template_data(&mp); - - if(ret < 0) { - Perl_croak(aTHX_ "parse error."); - } else if(ret == 0) { - Perl_croak(aTHX_ "insufficient bytes."); - } else { - if(from < dlen) { - Perl_croak(aTHX_ "extra bytes."); - } - return obj; - } -} - XS(xs_unpack) { dXSARGS; SV* const data = ST(1); @@ -252,17 +210,40 @@ XS(xs_unpack) { Perl_croak(aTHX_ "Usage: Data::MessagePack->unpack('data' [, $limit])"); } - ST(0) = _msgpack_unpack(data, limit); + STRLEN dlen; + const char* const dptr = SvPV_const(data, dlen); + msgpack_unpack_t mp; + template_init(&mp); + + unpack_user const u = {false, false}; + mp.user = u; + + size_t from = 0; + int const ret = template_execute(&mp, dptr, (size_t)dlen, &from); + SV* const obj = template_data(&mp); + sv_2mortal(obj); + + if(ret < 0) { + Perl_croak(aTHX_ "Data::MessagePack->unpack: parse error"); + } else if(ret == 0) { + Perl_croak(aTHX_ "Data::MessagePack->unpack: insufficient bytes"); + } else { + if(from < dlen) { + Perl_croak(aTHX_ "Data::MessagePack->unpack: extra bytes"); + } + } + + ST(0) = obj; XSRETURN(1); } /* ------------------------------ stream -- */ /* http://twitter.com/frsyuki/status/13249304748 */ -STATIC_INLINE void _reset(SV* self) { +STATIC_INLINE void _reset(SV* const self) { dTHX; - unpack_user u = {false, false}; + unpack_user const u = {false, false}; UNPACKER(self, mp); template_init(mp); @@ -275,10 +256,10 @@ XS(xs_unpacker_new) { Perl_croak(aTHX_ "Usage: Data::MessagePack::Unpacker->new()"); } - SV* self = sv_newmortal(); - msgpack_unpack_t *mp; + SV* const self = sv_newmortal(); + msgpack_unpack_t *mp; - Newx(mp, 1, msgpack_unpack_t); + Newxz(mp, 1, msgpack_unpack_t); sv_setref_pv(self, "Data::MessagePack::Unpacker", mp); _reset(self); @@ -287,65 +268,64 @@ XS(xs_unpacker_new) { XSRETURN(1); } -STATIC_INLINE SV* _execute_impl(SV* self, SV* data, UV off, size_t limit) { +STATIC_INLINE SV* +_execute_impl(SV* const self, SV* const data, UV const offset, UV const limit) { dTHX; + + if(offset >= limit) { + Perl_croak(aTHX_ "offset (%"UVuf") is bigger than data buffer size (%"UVuf")", + offset, limit); + } + UNPACKER(self, mp); - size_t from = off; - const char* dptr = SvPV_nolen_const(data); - int ret; + size_t from = offset; + const char* const dptr = SvPV_nolen_const(data); - if(from >= limit) { - Perl_croak(aTHX_ "offset (%lu) is bigger than data buffer size (%lu)", (unsigned long)off, (unsigned long)limit); - } + int const ret = template_execute(mp, dptr, limit, &from); - ret = template_execute(mp, dptr, limit, &from); - - if(ret < 0) { - Perl_croak(aTHX_ "parse error."); - } else { - mp->user.finished = (ret > 0) ? true : false; - return sv_2mortal(newSVuv(from)); - } + if(ret < 0) { + Perl_croak(aTHX_ "Data::MessagePack::Unpacker: parse error while executing"); + } else { + mp->user.finished = (ret > 0) ? true : false; + return sv_2mortal(newSVuv(from)); + } } XS(xs_unpacker_execute) { dXSARGS; - if (items != 3) { - Perl_croak(aTHX_ "Usage: $unpacker->execute(data, off)"); + SV* const self = ST(0); + SV* const data = ST(1); + UV offset; + + if (items == 2) { + offset = 0; + } + else if (items == 3) { + offset = SvUVx(ST(2)); + } + else { + Perl_croak(aTHX_ "Usage: $unpacker->execute(data, offset = 0)"); } - UNPACKER(ST(0), mp); - { - SV* self = ST(0); - SV* data = ST(1); - IV off = SvIV(ST(2)); /* offset of $data. normaly, 0. */ - - ST(0) = _execute_impl(self, data, off, (size_t)sv_len(data)); - - if (!mp->user.incremented) { - SV* tmp_obj = template_data(mp); - SvREFCNT_inc_simple_void_NN(tmp_obj); - mp->user.incremented = true; - } - } + UNPACKER(self, mp); + ST(0) = _execute_impl(self, data, offset, sv_len(data)); XSRETURN(1); } XS(xs_unpacker_execute_limit) { dXSARGS; if (items != 4) { - Perl_croak(aTHX_ "Usage: $unpacker->execute_limit(data, off, limit)"); + Perl_croak(aTHX_ "Usage: $unpacker->execute_limit(data, offset, limit)"); } - SV* self = ST(0); - SV* data = ST(1); - IV off = SvIV(ST(2)); - IV limit = SvIV(ST(3)); - - ST(0) = _execute_impl(self, data, off, (size_t)limit); + SV* const self = ST(0); + SV* const data = ST(1); + UV const offset = SvUVx(ST(2)); + UV const limit = SvUVx(ST(3)); + ST(0) = _execute_impl(self, data, offset, limit); XSRETURN(1); } @@ -355,9 +335,8 @@ XS(xs_unpacker_is_finished) { Perl_croak(aTHX_ "Usage: $unpacker->is_finished()"); } - UNPACKER(ST(0), mp); + UNPACKER(ST(0), mp); ST(0) = boolSV(mp->user.finished); - XSRETURN(1); } @@ -367,9 +346,8 @@ XS(xs_unpacker_data) { Perl_croak(aTHX_ "Usage: $unpacker->data()"); } - UNPACKER(ST(0), mp); - ST(0) = template_data(mp); - + UNPACKER(ST(0), mp); + ST(0) = template_data(mp); XSRETURN(1); } @@ -379,10 +357,10 @@ XS(xs_unpacker_reset) { Perl_croak(aTHX_ "Usage: $unpacker->reset()"); } - UNPACKER(ST(0), mp); + UNPACKER(ST(0), mp); SV* const data = template_data(mp); - SvREFCNT_dec(data); + sv_2mortal(data); _reset(ST(0)); XSRETURN(0); @@ -394,10 +372,10 @@ XS(xs_unpacker_destroy) { Perl_croak(aTHX_ "Usage: $unpacker->DESTROY()"); } - UNPACKER(ST(0), mp); + UNPACKER(ST(0), mp); SV* const data = template_data(mp); - SvREFCNT_dec(data); + sv_2mortal(data); Safefree(mp); XSRETURN(0); diff --git a/perl/xt/leaks/leaktrace.t b/perl/xt/leaks/leaktrace.t index ff64f6ff..1836ad6b 100755 --- a/perl/xt/leaks/leaktrace.t +++ b/perl/xt/leaks/leaktrace.t @@ -5,7 +5,8 @@ use Test::More; use Data::MessagePack; -my $data = { +my $simple_data = "xyz"; +my $complex_data = { a => 'foo', b => 42, c => undef, @@ -13,8 +14,10 @@ my $data = { e => 3.14, }; +note 'pack'; + no_leaks_ok { - my $s = Data::MessagePack->pack($data); + my $s = Data::MessagePack->pack($complex_data); }; no_leaks_ok { @@ -23,16 +26,23 @@ no_leaks_ok { $@ or die "it must die"; }; -my $s = Data::MessagePack->pack($data); +note 'unpack'; + +my $s = Data::MessagePack->pack($simple_data); +my $c = Data::MessagePack->pack($complex_data); no_leaks_ok { my $data = Data::MessagePack->unpack($s); }; no_leaks_ok { - my $ss = $s; - chop $ss; - eval { Data::MessagePack->unpack($ss) }; + my $data = Data::MessagePack->unpack($c); +}; + +no_leaks_ok { + my $broken = $s; + chop $broken; + eval { Data::MessagePack->unpack($broken) }; #note $@; $@ or die "it must die"; }; From 7c1e0ea95d1aed954ee97bc3a72c7779e085f9ec Mon Sep 17 00:00:00 2001 From: gfx Date: Thu, 16 Sep 2010 20:27:25 +0900 Subject: [PATCH 36/59] Add binmode() for stream unpacking --- perl/t/06_stream_unpack2.t | 1 + 1 file changed, 1 insertion(+) diff --git a/perl/t/06_stream_unpack2.t b/perl/t/06_stream_unpack2.t index 68a28731..78ca8f7c 100644 --- a/perl/t/06_stream_unpack2.t +++ b/perl/t/06_stream_unpack2.t @@ -30,6 +30,7 @@ is_deeply(Data::MessagePack->unpack($packed), $input); note "packed size: ", length($packed); open my $stream, '<:bytes :scalar', \$packed; + binmode $stream; my $buff; while( read($stream, $buff, $size) ) { note "buff: ", join " ", map { unpack 'H2', $_ } split //, $buff; From bd887b660d9bcbdb6dd3458223331eea8dcdc654 Mon Sep 17 00:00:00 2001 From: gfx Date: Thu, 16 Sep 2010 20:31:34 +0900 Subject: [PATCH 37/59] Preallocate hv keys --- perl/xs-src/unpack.c | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/perl/xs-src/unpack.c b/perl/xs-src/unpack.c index a429ecd9..1d7de711 100644 --- a/perl/xs-src/unpack.c +++ b/perl/xs-src/unpack.c @@ -157,10 +157,11 @@ STATIC_INLINE int template_callback_array_item(unpack_user* u PERL_UNUSED_DECL, return 0; } -STATIC_INLINE int template_callback_map(unpack_user* u PERL_UNUSED_DECL, unsigned int n PERL_UNUSED_DECL, SV** o) +STATIC_INLINE int template_callback_map(unpack_user* u PERL_UNUSED_DECL, unsigned int n, SV** o) { dTHX; HV* const h = newHV(); + hv_ksplit(h, n); *o = newRV_noinc((SV*)h); return 0; } From e239bfda8add9d7fd42dcd5f2e2bfc01eae9e824 Mon Sep 17 00:00:00 2001 From: gfx Date: Thu, 16 Sep 2010 20:36:07 +0900 Subject: [PATCH 38/59] Make leaktrace.t as a regular test --- .../{xt/leaks/leaktrace.t => t/50_leaktrace.t} | 18 +++++++++++++----- 1 file changed, 13 insertions(+), 5 deletions(-) rename perl/{xt/leaks/leaktrace.t => t/50_leaktrace.t} (72%) diff --git a/perl/xt/leaks/leaktrace.t b/perl/t/50_leaktrace.t similarity index 72% rename from perl/xt/leaks/leaktrace.t rename to perl/t/50_leaktrace.t index 1836ad6b..29485270 100755 --- a/perl/xt/leaks/leaktrace.t +++ b/perl/t/50_leaktrace.t @@ -1,6 +1,6 @@ #!perl -w use strict; -use Test::Requires 'Test::LeakTrace'; +use Test::Requires { 'Test::LeakTrace' => 0.13 }; use Test::More; use Data::MessagePack; @@ -22,8 +22,8 @@ no_leaks_ok { no_leaks_ok { eval { Data::MessagePack->pack([\*STDIN]) }; - #note $@; - $@ or die "it must die"; + note $@; + $@ or warn "# it must die"; }; note 'unpack'; @@ -43,8 +43,16 @@ no_leaks_ok { my $broken = $s; chop $broken; eval { Data::MessagePack->unpack($broken) }; - #note $@; - $@ or die "it must die"; + note $@; + $@ or warn "# it must die"; +}; + +note 'stream'; + +no_leaks_ok { + my $up = Data::MessagePack::Unpacker->new(); + $up->execute($c); + my $data = $up->data(); }; done_testing; From 3cffd46008c8a25dcc77818dbc4fbfd675923ea2 Mon Sep 17 00:00:00 2001 From: gfx Date: Thu, 16 Sep 2010 20:41:52 +0900 Subject: [PATCH 39/59] Fix a comment --- perl/xs-src/unpack.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/perl/xs-src/unpack.c b/perl/xs-src/unpack.c index 1d7de711..da985e32 100644 --- a/perl/xs-src/unpack.c +++ b/perl/xs-src/unpack.c @@ -179,7 +179,7 @@ STATIC_INLINE int template_callback_map_item(unpack_user* u PERL_UNUSED_DECL, SV STATIC_INLINE int template_callback_raw(unpack_user* u PERL_UNUSED_DECL, const char* b PERL_UNUSED_DECL, const char* p, unsigned int l, SV** o) { dTHX; - /* newSVpvn_flags(p, l, SVs_TEMP) returns an undef if l == 0 */ + /* newSVpvn(p, l) returns an undef if p == NULL */ *o = ((l==0) ? newSVpvs("") : newSVpvn(p, l)); return 0; } From 8eaed95e027bcf66b61611871bc12e0cb110d859 Mon Sep 17 00:00:00 2001 From: gfx Date: Thu, 16 Sep 2010 20:44:51 +0900 Subject: [PATCH 40/59] Fix an use of execute() --- perl/t/06_stream_unpack2.t | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/perl/t/06_stream_unpack2.t b/perl/t/06_stream_unpack2.t index 78ca8f7c..25af21d4 100644 --- a/perl/t/06_stream_unpack2.t +++ b/perl/t/06_stream_unpack2.t @@ -35,7 +35,7 @@ is_deeply(Data::MessagePack->unpack($packed), $input); while( read($stream, $buff, $size) ) { note "buff: ", join " ", map { unpack 'H2', $_ } split //, $buff; - $up->execute($buff); + $up->execute($buff, 0); } ok $up->is_finished, 'is_finished'; my $data = $up->data; From 562de7926b87a027842e624fe385468145d09ed9 Mon Sep 17 00:00:00 2001 From: gfx Date: Thu, 16 Sep 2010 21:37:49 +0900 Subject: [PATCH 41/59] More tests; some fails now :( --- perl/.gitignore | 1 + perl/Makefile.PL | 5 +++++ perl/lib/Data/MessagePack.pm | 12 ++++++++++++ perl/t/06_stream_unpack2.t | 2 +- perl/t/09_stddata.t | 35 +++++++++++++++++++++++++++++++++++ ruby/test/test_pack_unpack.rb | 4 ++-- 6 files changed, 56 insertions(+), 3 deletions(-) create mode 100644 perl/t/09_stddata.t diff --git a/perl/.gitignore b/perl/.gitignore index b64dcdfe..3e0e73e5 100644 --- a/perl/.gitignore +++ b/perl/.gitignore @@ -6,6 +6,7 @@ MessagePack.o blib/ inc/ msgpack/ +t/std/ pack.o pm_to_blib unpack.o diff --git a/perl/Makefile.PL b/perl/Makefile.PL index e7b8c474..fafc3876 100644 --- a/perl/Makefile.PL +++ b/perl/Makefile.PL @@ -54,6 +54,11 @@ if ($Module::Install::AUTHOR && -d File::Spec->catfile('..', 'msgpack')) { for my $src (<../msgpack/*.h>) { File::Copy::copy($src, 'msgpack/') or die "copy failed: $!"; } + + mkdir 't/std'; + for my $data(<../test/*.{json,mpac}>) { + File::Copy::copy($data, 't/std') or die "copy failed: $!"; + } } requires 'Test::More' => 0.94; # done_testing diff --git a/perl/lib/Data/MessagePack.pm b/perl/lib/Data/MessagePack.pm index 3511628c..ece00505 100644 --- a/perl/lib/Data/MessagePack.pm +++ b/perl/lib/Data/MessagePack.pm @@ -6,6 +6,18 @@ use 5.008001; our $VERSION = '0.23'; our $PreferInteger = 0; +{ + package + Data::MessagePack::Boolean; + use overload + 'bool' => sub { ${ $_[0] } }, + '0+' => sub { ${ $_[0] } }, + '""' => sub { ${ $_[0] } ? 'true' : 'false' }, + + fallback => 1, + ; +} + our $true = do { bless \(my $dummy = 1), "Data::MessagePack::Boolean" }; our $false = do { bless \(my $dummy = 0), "Data::MessagePack::Boolean" }; sub true () { $true } diff --git a/perl/t/06_stream_unpack2.t b/perl/t/06_stream_unpack2.t index 25af21d4..78ca8f7c 100644 --- a/perl/t/06_stream_unpack2.t +++ b/perl/t/06_stream_unpack2.t @@ -35,7 +35,7 @@ is_deeply(Data::MessagePack->unpack($packed), $input); while( read($stream, $buff, $size) ) { note "buff: ", join " ", map { unpack 'H2', $_ } split //, $buff; - $up->execute($buff, 0); + $up->execute($buff); } ok $up->is_finished, 'is_finished'; my $data = $up->data; diff --git a/perl/t/09_stddata.t b/perl/t/09_stddata.t new file mode 100644 index 00000000..d035b4be --- /dev/null +++ b/perl/t/09_stddata.t @@ -0,0 +1,35 @@ +use strict; +use Test::More; +use Test::Requires qw(JSON); +use t::Util; + +use Data::MessagePack; + +sub slurp { + open my $fh, '<:raw', $_[0] or die "failed to open '$_[0]': $!"; + local $/; + return scalar <$fh>; +} + +my @data = @{ JSON::decode_json(slurp("t/std/cases.json")) }; + +my $mpac1 = slurp("t/std/cases.mpac"); +my $mpac2 = slurp("t/std/cases_compact.mpac"); + +my $mps = Data::MessagePack::Unpacker->new(); + +my $t = 1; +for my $mpac($mpac1, $mpac2) { + note "mpac", $t++; + + my $offset = 0; + my $i = 0; + while($offset < length($mpac)) { + $offset += $mps->execute($mpac, $offset); + is_deeply $mps->data, $data[$i], "data[$i]"; + $mps->reset; + $i++; + } +} + +done_testing; diff --git a/ruby/test/test_pack_unpack.rb b/ruby/test/test_pack_unpack.rb index 545e5939..f378c3c7 100644 --- a/ruby/test/test_pack_unpack.rb +++ b/ruby/test/test_pack_unpack.rb @@ -239,7 +239,7 @@ class MessagePackTestPackUnpack < Test::Unit::TestCase end it "gc mark" do - obj = [{["a","b"]=>["c","d"]}, ["e","f"], "d"] + obj = [1024, {["a","b"]=>["c","d"]}, ["e","f"], "d", 70000, 4.12, 1.5, 1.5, 1.5] num = 4 raw = obj.to_msgpack * num pac = MessagePack::Unpacker.new @@ -257,7 +257,7 @@ class MessagePackTestPackUnpack < Test::Unit::TestCase end it "streaming backward compatibility" do - obj = [{["a","b"]=>["c","d"]}, ["e","f"], "d"] + obj = [1024, {["a","b"]=>["c","d"]}, ["e","f"], "d", 70000, 4.12, 1.5, 1.5, 1.5] num = 4 raw = obj.to_msgpack * num pac = MessagePack::Unpacker.new From 599964ea5f1a064163ddda8940bb8c5b12ef022a Mon Sep 17 00:00:00 2001 From: gfx Date: Thu, 16 Sep 2010 21:45:06 +0900 Subject: [PATCH 42/59] Comments --- perl/t/09_stddata.t | 3 +++ 1 file changed, 3 insertions(+) diff --git a/perl/t/09_stddata.t b/perl/t/09_stddata.t index d035b4be..b6a612eb 100644 --- a/perl/t/09_stddata.t +++ b/perl/t/09_stddata.t @@ -1,3 +1,6 @@ +#!perl -w +# Testing standard dataset in msgpack/test/*.{json,mpac}. +# Don't edit msgpack/perl/t/std/*, which are just copies. use strict; use Test::More; use Test::Requires qw(JSON); From 5e602fb575b0941194be42504475208ca7d8d6ad Mon Sep 17 00:00:00 2001 From: gfx Date: Fri, 17 Sep 2010 13:10:54 +0900 Subject: [PATCH 43/59] Fix tests --- perl/t/06_stream_unpack2.t | 44 ++++++++++++++++++-------------------- perl/t/09_stddata.t | 2 +- perl/t/10_splitted_bytes.t | 40 ++++++++++++++++++++++++++++++++++ perl/t/Util.pm | 2 ++ 4 files changed, 64 insertions(+), 24 deletions(-) create mode 100755 perl/t/10_splitted_bytes.t diff --git a/perl/t/06_stream_unpack2.t b/perl/t/06_stream_unpack2.t index 78ca8f7c..bb6fe93d 100644 --- a/perl/t/06_stream_unpack2.t +++ b/perl/t/06_stream_unpack2.t @@ -2,8 +2,16 @@ use strict; use warnings; use Data::MessagePack; use Test::More tests => 9; +use t::Util; + +my $input = [ + false,true,null,0,0,0,0,0,0,0,0,0,-1,-1,-1,-1,-1, + 127,127,255,65535,4294967295,-32,-32,-128,-32768, + -2147483648,0.0,-0.0,1.0,-1.0,"a","a","a","","","", + [0],[0],[0],[],[],[],{},{},{}, + {"a" => 97},{"a" => 97},{"a" => 97},[[]],[["a"]] +]; -my $input = [ 42, "foo", { x => [ (1) x 16 ] }, undef, 1 ]; my $packed = Data::MessagePack->pack($input); is_deeply(Data::MessagePack->unpack($packed), $input); @@ -16,30 +24,20 @@ is_deeply(Data::MessagePack->unpack($packed), $input); { my $up = Data::MessagePack::Unpacker->new(); - is $up->execute(substr($packed, 0, 3), 0), 3; - ok !$up->is_finished; - $up->execute($packed, 3); - ok $up->is_finished; - is_deeply $up->data, $input; -} + $packed x= 3; + my $offset = 0; + for my $i(1 .. 3) { + note "block $i (offset: $offset/".length($packed).")"; + note "starting 3 bytes: ", join " ", map { unpack 'H2', $_ } + split //, substr($packed, $offset, 3); -{ - my $up = Data::MessagePack::Unpacker->new(); - my $size = 8; - - note "packed size: ", length($packed); - open my $stream, '<:bytes :scalar', \$packed; - binmode $stream; - my $buff; - while( read($stream, $buff, $size) ) { - note "buff: ", join " ", map { unpack 'H2', $_ } split //, $buff; - - $up->execute($buff); + $offset = $up->execute($packed, $offset); + ok $up->is_finished, 'finished'; + my $data = $up->data; + is_deeply $data, $input; + $up->reset(); } - ok $up->is_finished, 'is_finished'; - my $data = $up->data; - note explain($data); - is_deeply $data, $input; } + diff --git a/perl/t/09_stddata.t b/perl/t/09_stddata.t index b6a612eb..976fc5d3 100644 --- a/perl/t/09_stddata.t +++ b/perl/t/09_stddata.t @@ -28,7 +28,7 @@ for my $mpac($mpac1, $mpac2) { my $offset = 0; my $i = 0; while($offset < length($mpac)) { - $offset += $mps->execute($mpac, $offset); + $offset = $mps->execute($mpac, $offset); is_deeply $mps->data, $data[$i], "data[$i]"; $mps->reset; $i++; diff --git a/perl/t/10_splitted_bytes.t b/perl/t/10_splitted_bytes.t new file mode 100755 index 00000000..232d8707 --- /dev/null +++ b/perl/t/10_splitted_bytes.t @@ -0,0 +1,40 @@ +#!perl + +# This feature is not yet supported, but 0.23 (or former) caused SEGV in this code, +# so we put it here. + +use strict; +use warnings; +use Data::MessagePack; +use Test::More; +use t::Util; + +my $input = [ + false,true,null,0,0,0,0,0,0,0,0,0,-1,-1,-1,-1,-1, + 127,127,255,65535,4294967295,-32,-32,-128,-32768, + -2147483648,0.0,-0.0,1.0,-1.0,"a","a","a","","","", + [0],[0],[0],[],[],[],{},{},{}, + {"a" => 97},{"a" => 97},{"a" => 97},[[]],[["a"]] +]; + +my $packed = Data::MessagePack->pack($input); + +foreach my $size(1 .. 16) { + local $TODO = "Splitted byte streaming is not yet supported (bufer size: $size)"; + + my $up = Data::MessagePack::Unpacker->new(); + + open my $stream, '<:bytes :scalar', \$packed; + binmode $stream; + my $buff; + while( read($stream, $buff, $size) ) { + #note "buff: ", join " ", map { unpack 'H2', $_ } split //, $buff; + + $up->execute($buff); + } + ok $up->is_finished, 'is_finished'; + my $data = $up->data; + is_deeply $data, $input; +} + +done_testing; diff --git a/perl/t/Util.pm b/perl/t/Util.pm index c8debefb..ad69c4d5 100644 --- a/perl/t/Util.pm +++ b/perl/t/Util.pm @@ -1,6 +1,7 @@ package t::Util; use strict; use warnings; +use Data::MessagePack; sub import { my $pkg = caller(0); @@ -15,6 +16,7 @@ sub import { *{"$pkg\::false"} = sub () { Data::MessagePack::false() }; + *{"$pkg\::null"} = sub() { undef }; } 1; From d2962d8676060c8fdd5d474db7497910293d4f8a Mon Sep 17 00:00:00 2001 From: gfx Date: Fri, 17 Sep 2010 13:25:23 +0900 Subject: [PATCH 44/59] Split the boolean class into an outer module --- perl/lib/Data/MessagePack.pm | 27 +++++++------ perl/lib/Data/MessagePack/Boolean.pm | 14 +++++++ perl/xs-src/MessagePack.c | 10 ++++- perl/xs-src/pack.c | 3 +- perl/xs-src/unpack.c | 58 ++++++++++++++++++++++++---- 5 files changed, 87 insertions(+), 25 deletions(-) create mode 100755 perl/lib/Data/MessagePack/Boolean.pm diff --git a/perl/lib/Data/MessagePack.pm b/perl/lib/Data/MessagePack.pm index ece00505..b1e0174d 100644 --- a/perl/lib/Data/MessagePack.pm +++ b/perl/lib/Data/MessagePack.pm @@ -6,22 +6,21 @@ use 5.008001; our $VERSION = '0.23'; our $PreferInteger = 0; -{ - package - Data::MessagePack::Boolean; - use overload - 'bool' => sub { ${ $_[0] } }, - '0+' => sub { ${ $_[0] } }, - '""' => sub { ${ $_[0] } ? 'true' : 'false' }, - - fallback => 1, - ; +sub true () { + require Data::MessagePack::Boolean; + no warnings 'once', 'redefine'; + my $t = $Data::MessagePack::Boolean::true; + *true = sub (){ $t }; + return $t; } -our $true = do { bless \(my $dummy = 1), "Data::MessagePack::Boolean" }; -our $false = do { bless \(my $dummy = 0), "Data::MessagePack::Boolean" }; -sub true () { $true } -sub false () { $false } +sub false () { + require Data::MessagePack::Boolean; + no warnings 'once', 'redefine'; + my $f = $Data::MessagePack::Boolean::false; + *false = sub (){ $f }; + return $f; +} if ( !__PACKAGE__->can('pack') ) { # this idea comes from Text::Xslate my $backend = $ENV{ PERL_DATA_MESSAGEPACK } || ''; diff --git a/perl/lib/Data/MessagePack/Boolean.pm b/perl/lib/Data/MessagePack/Boolean.pm new file mode 100755 index 00000000..2bb3ecad --- /dev/null +++ b/perl/lib/Data/MessagePack/Boolean.pm @@ -0,0 +1,14 @@ +package Data::MessagePack::Boolean; +use strict; +use overload + 'bool' => sub { ${ $_[0] } }, + '0+' => sub { ${ $_[0] } }, + '""' => sub { ${ $_[0] } ? 'true' : 'false' }, + + fallback => 1, +; + +our $true = do { bless \(my $dummy = 1) }; +our $false = do { bless \(my $dummy = 0) }; + +1; diff --git a/perl/xs-src/MessagePack.c b/perl/xs-src/MessagePack.c index aba8ef91..69337f41 100644 --- a/perl/xs-src/MessagePack.c +++ b/perl/xs-src/MessagePack.c @@ -1,5 +1,9 @@ #include "xshelper.h" +#ifndef __cplusplus +#include +#endif + XS(xs_pack); XS(xs_unpack); XS(xs_unpacker_new); @@ -10,13 +14,15 @@ XS(xs_unpacker_data); XS(xs_unpacker_reset); XS(xs_unpacker_destroy); -void boot_Data__MessagePack_pack(void); +void init_Data__MessagePack_pack(pTHX_ bool const cloning); +void init_Data__MessagePack_unpack(pTHX_ bool const cloning); XS(boot_Data__MessagePack) { dXSARGS; PERL_UNUSED_VAR(items); - boot_Data__MessagePack_pack(); + init_Data__MessagePack_pack(aTHX_ false); + init_Data__MessagePack_unpack(aTHX_ false); newXS("Data::MessagePack::pack", xs_pack, __FILE__); newXS("Data::MessagePack::unpack", xs_unpack, __FILE__); diff --git a/perl/xs-src/pack.c b/perl/xs-src/pack.c index 9a58ed05..862808eb 100644 --- a/perl/xs-src/pack.c +++ b/perl/xs-src/pack.c @@ -83,8 +83,7 @@ MGVTBL pref_int_vtbl = { #endif }; -void boot_Data__MessagePack_pack(void) { - dTHX; +void init_Data__MessagePack_pack(pTHX_ bool const cloning) { SV* var = get_sv("Data::MessagePack::PreferInteger", 0); sv_magicext(var, NULL, PERL_MAGIC_ext, &pref_int_vtbl, NULL, 0); SvSETMAGIC(var); diff --git a/perl/xs-src/unpack.c b/perl/xs-src/unpack.c index da985e32..6ebb48c2 100644 --- a/perl/xs-src/unpack.c +++ b/perl/xs-src/unpack.c @@ -2,6 +2,13 @@ #define NEED_sv_2pv_flags #include "xshelper.h" +#define MY_CXT_KEY "Data::MessagePack::_unpack_guts" XS_VERSION +typedef struct { + SV* msgpack_true; + SV* msgpack_false; +} my_cxt_t; +START_MY_CXT + typedef struct { bool finished; bool incremented; @@ -22,13 +29,52 @@ typedef struct { #define msgpack_unpack_user unpack_user +void init_Data__MessagePack_unpack(pTHX_ bool const cloning) { + if(!cloning) { + MY_CXT_INIT; + MY_CXT.msgpack_true = NULL; + MY_CXT.msgpack_false = NULL; + } + else { + MY_CXT_CLONE; + MY_CXT.msgpack_true = NULL; + MY_CXT.msgpack_false = NULL; + } +} + + + /* ---------------------------------------------------------------------- */ /* utility functions */ -STATIC_INLINE SV * -get_bool (const char* const name) { +static SV* +load_bool(pTHX_ const char* const name) { + CV* const cv = get_cv(name, GV_ADD); + dSP; + PUSHMARK(SP); + call_sv((SV*)cv, G_SCALAR); + SPAGAIN; + SV* const sv = newSVsv(POPs); + PUTBACK; + return sv; +} + +static SV* +get_bool(bool const value) { dTHX; - return newSVsv(get_sv( name, GV_ADD )); + dMY_CXT; + if(value) { + if(!MY_CXT.msgpack_true) { + MY_CXT.msgpack_true = load_bool(aTHX_ "Data::MessagePack::true"); + } + return newSVsv(MY_CXT.msgpack_true); + } + else { + if(!MY_CXT.msgpack_false) { + MY_CXT.msgpack_false = load_bool(aTHX_ "Data::MessagePack::false"); + } + return newSVsv(MY_CXT.msgpack_false); + } } /* ---------------------------------------------------------------------- */ @@ -127,15 +173,13 @@ STATIC_INLINE int template_callback_nil(unpack_user* u PERL_UNUSED_DECL, SV** o) STATIC_INLINE int template_callback_true(unpack_user* u PERL_UNUSED_DECL, SV** o) { - dTHX; - *o = get_bool("Data::MessagePack::true"); + *o = get_bool(true); return 0; } STATIC_INLINE int template_callback_false(unpack_user* u PERL_UNUSED_DECL, SV** o) { - dTHX; - *o = get_bool("Data::MessagePack::false"); + *o = get_bool(false); return 0; } From eab7c877813e7c1dd7820307260221444773d116 Mon Sep 17 00:00:00 2001 From: gfx Date: Fri, 17 Sep 2010 13:37:17 +0900 Subject: [PATCH 45/59] Tidy PP --- perl/lib/Data/MessagePack/PP.pm | 119 ++++++++++++++++++-------------- 1 file changed, 68 insertions(+), 51 deletions(-) diff --git a/perl/lib/Data/MessagePack/PP.pm b/perl/lib/Data/MessagePack/PP.pm index 9e322991..c7eaadf5 100644 --- a/perl/lib/Data/MessagePack/PP.pm +++ b/perl/lib/Data/MessagePack/PP.pm @@ -1,11 +1,8 @@ package Data::MessagePack::PP; - -use 5.008000; +use 5.008001; use strict; use Carp (); -our $VERSION = '0.15'; - # See also # http://redmine.msgpack.org/projects/msgpack/wiki/FormatSpec # http://cpansearch.perl.org/src/YAPPO/Data-Model-0.00006/lib/Data/Model/Driver/Memcached.pm @@ -25,49 +22,74 @@ BEGIN { # 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 - # In really, since 5.9.2 '>' is introduced. but 'n!' and 'N!'? - *pack_uint64 = $bo_is_le ? sub { - my @v = unpack( 'V2', pack( 'Q', $_[0] ) ); - return pack 'CN2', 0xcf, @v[1,0]; - } : sub { pack 'CQ', 0xcf, $_[0]; }; - *pack_int64 = $bo_is_le ? sub { - my @v = unpack( 'V2', pack( 'q', $_[0] ) ); - return pack 'CN2', 0xd3, @v[1,0]; - } : sub { pack 'Cq', 0xd3, $_[0]; }; - *pack_double = $bo_is_le ? sub { - my @v = unpack( 'V2', pack( 'd', $_[0] ) ); - return pack 'CN2', 0xcb, @v[1,0]; - } : sub { pack 'Cd', 0xcb, $_[0]; }; - *unpack_float = $bo_is_le ? sub { - my @v = unpack( 'v2', substr( $_[0], $_[1], 4 ) ); - return unpack( 'f', pack( 'n2', @v[1,0] ) ); - } : sub { return unpack( 'f', substr( $_[0], $_[1], 4 ) ); }; - *unpack_double = $bo_is_le ? sub { - my @v = unpack( 'V2', substr( $_[0], $_[1], 8 ) ); - return unpack( 'd', pack( 'N2', @v[1,0] ) ); - } : 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 = $bo_is_le ? sub { - my @v = unpack( 'V*', substr( $_[0], $_[1], 8 ) ); - return unpack( 'q', pack( 'N2', @v[1,0] ) ); - } : sub { pack 'q', substr( $_[0], $_[1], 8 ); }; - *unpack_uint64 = $bo_is_le ? sub { - my @v = unpack( 'V*', substr( $_[0], $_[1], 8 ) ); - return unpack( 'Q', pack( 'N2', @v[1,0] ) ); - } : sub { pack 'Q', substr( $_[0], $_[1], 8 ); }; + + # In reality, since 5.9.2 '>' is introduced. but 'n!' and 'N!'? + if($bo_is_le) { + *pack_uint64 = sub { + my @v = unpack( 'V2', pack( 'Q', $_[0] ) ); + return pack 'CN2', 0xcf, @v[1,0]; + }; + *pack_int64 = sub { + my @v = unpack( 'V2', pack( 'q', $_[0] ) ); + return pack 'CN2', 0xd3, @v[1,0]; + }; + *pack_double = sub { + my @v = unpack( 'V2', pack( 'd', $_[0] ) ); + return pack 'CN2', 0xcb, @v[1,0]; + }; + + *unpack_float = sub { + my @v = unpack( 'v2', substr( $_[0], $_[1], 4 ) ); + return unpack( 'f', pack( 'n2', @v[1,0] ) ); + }; + *unpack_double = sub { + my @v = unpack( 'V2', substr( $_[0], $_[1], 8 ) ); + 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 { + my @v = unpack( 'V*', substr( $_[0], $_[1], 8 ) ); + return unpack( 'q', pack( 'N2', @v[1,0] ) ); + }; + *unpack_uint64 = sub { + my @v = unpack( 'V*', substr( $_[0], $_[1], 8 ) ); + return unpack( 'Q', pack( 'N2', @v[1,0] ) ); + }; + } + else { # big endian + *pack_uint64 = sub { return pack 'CQ', 0xcf, $_[0]; }; + *pack_int64 = sub { return pack 'Cq', 0xd3, $_[0]; }; + *pack_double = sub { return pack 'Cd', 0xcb, $_[0]; }; + + *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 ); }; + } } else { *pack_uint64 = sub { return pack 'CQ>', 0xcf, $_[0]; }; *pack_int64 = sub { return pack 'Cq>', 0xd3, $_[0]; }; *pack_double = sub { return pack 'Cd>', 0xcb, $_[0]; }; + *unpack_float = sub { return unpack( 'f>', substr( $_[0], $_[1], 4 ) ); }; *unpack_double = sub { return unpack( 'd>', substr( $_[0], $_[1], 8 ) ); }; *unpack_int16 = sub { return unpack( 'n!', substr( $_[0], $_[1], 2 ) ); }; @@ -75,11 +97,6 @@ BEGIN { *unpack_int64 = sub { return unpack( 'q>', substr( $_[0], $_[1], 8 ) ); }; *unpack_uint64 = sub { return unpack( 'Q>', substr( $_[0], $_[1], 8 ) ); }; } - # for 5.8 etc. - unless ( defined &utf8::is_utf8 ) { - require Encode; - *utf8::is_utf8 = *Encode::is_utf8; - } } @@ -92,7 +109,7 @@ BEGIN { my $max_depth; -sub pack { +sub pack :method { Carp::croak('Usage: Data::MessagePack->pack($dat [,$max_depth])') if @_ < 2; $max_depth = defined $_[2] ? $_[2] : 512; # init return _pack( $_[1] ); @@ -209,7 +226,7 @@ sub _pack { my $p; # position variables for speed. -sub unpack { +sub unpack :method { $p = 0; # init _unpack( $_[1] ); } @@ -370,7 +387,7 @@ sub execute_limit { sub execute { my ( $self, $data, $offset, $limit ) = @_; - my $value = substr( $data, $offset, $limit ? $limit : length $data ); + my $value = substr( $data, $offset || 0, $limit ? $limit : length $data ); my $len = length $value; $p = 0; @@ -509,7 +526,7 @@ sub is_finished { } -sub reset { +sub reset :method { $_[0]->{ stack } = []; $_[0]->{ data } = undef; $_[0]->{ remain } = undef; From d5a17a3c25068573b20a15ccaa22f6b8926e8d0b Mon Sep 17 00:00:00 2001 From: gfx Date: Fri, 17 Sep 2010 13:43:42 +0900 Subject: [PATCH 46/59] Fix stddata.t --- perl/t/09_stddata.t | 7 +++++-- 1 file changed, 5 insertions(+), 2 deletions(-) diff --git a/perl/t/09_stddata.t b/perl/t/09_stddata.t index 976fc5d3..a618787d 100644 --- a/perl/t/09_stddata.t +++ b/perl/t/09_stddata.t @@ -3,7 +3,6 @@ # Don't edit msgpack/perl/t/std/*, which are just copies. use strict; use Test::More; -use Test::Requires qw(JSON); use t::Util; use Data::MessagePack; @@ -14,7 +13,11 @@ sub slurp { return scalar <$fh>; } -my @data = @{ JSON::decode_json(slurp("t/std/cases.json")) }; +my @data = do { + my $json = slurp("t/std/cases.json"); + $json =~ s/:/=>/g; + @{ eval $json }; +}; my $mpac1 = slurp("t/std/cases.mpac"); my $mpac2 = slurp("t/std/cases_compact.mpac"); From 80058083b86919c02165e91719d7eca662b81db5 Mon Sep 17 00:00:00 2001 From: gfx Date: Fri, 17 Sep 2010 13:49:08 +0900 Subject: [PATCH 47/59] Tweaks --- perl/lib/Data/MessagePack/PP.pm | 15 ++++++--------- 1 file changed, 6 insertions(+), 9 deletions(-) diff --git a/perl/lib/Data/MessagePack/PP.pm b/perl/lib/Data/MessagePack/PP.pm index c7eaadf5..6a06c3c6 100644 --- a/perl/lib/Data/MessagePack/PP.pm +++ b/perl/lib/Data/MessagePack/PP.pm @@ -121,9 +121,7 @@ sub _pack { return CORE::pack( 'C', 0xc0 ) if ( not defined $value ); - my $b_obj = B::svref_2object( ref $value ? $value : \$value ); - - if ( $b_obj->isa('B::AV') ) { + if ( ref($value) eq 'ARRAY' ) { my $num = @$value; my $header = $num < 16 ? CORE::pack( 'C', 0x90 + $num ) @@ -137,7 +135,7 @@ sub _pack { return join( '', $header, map { _pack( $_ ) } @$value ); } - elsif ( $b_obj->isa('B::HV') ) { + elsif ( ref($value) eq 'HASH' ) { my $num = keys %$value; my $header = $num < 16 ? CORE::pack( 'C', 0x80 + $num ) @@ -151,10 +149,12 @@ sub _pack { return join( '', $header, map { _pack( $_ ) } %$value ); } - elsif ( blessed( $value ) and blessed( $value ) eq 'Data::MessagePack::Boolean' ) { - return CORE::pack( 'C', $$value ? 0xc3 : 0xc2 ); + elsif ( ref( $value ) eq 'Data::MessagePack::Boolean' ) { + return CORE::pack( 'C', ${$value} ? 0xc3 : 0xc2 ); } + + my $b_obj = B::svref_2object( \$value ); my $flags = $b_obj->FLAGS; if ( $flags & ( B::SVf_IOK | B::SVp_IOK ) ) { @@ -175,7 +175,6 @@ sub _pack { } } - elsif ( $flags & B::SVf_POK ) { # raw / check needs before dboule if ( $Data::MessagePack::PreferInteger ) { @@ -204,11 +203,9 @@ sub _pack { return $header . $value; } - elsif ( $flags & ( B::SVf_NOK | B::SVp_NOK ) ) { # double only return pack_double( $value ); } - else { die "???"; } From 8512f9eda168b37b8d362484a13480ef3d06f24b Mon Sep 17 00:00:00 2001 From: gfx Date: Fri, 17 Sep 2010 13:49:55 +0900 Subject: [PATCH 48/59] Add .gitignore --- .gitignore | 3 +++ 1 file changed, 3 insertions(+) create mode 100644 .gitignore diff --git a/.gitignore b/.gitignore new file mode 100644 index 00000000..d740b181 --- /dev/null +++ b/.gitignore @@ -0,0 +1,3 @@ +*.o +*.so +ruby/Makefile From b71cc5d7ee99259950602bdcddce68a0fb1dc52b Mon Sep 17 00:00:00 2001 From: gfx Date: Fri, 17 Sep 2010 13:59:52 +0900 Subject: [PATCH 49/59] chmod -x --- perl/lib/Data/MessagePack/Boolean.pm | 0 perl/t/10_splitted_bytes.t | 0 perl/t/50_leaktrace.t | 0 3 files changed, 0 insertions(+), 0 deletions(-) mode change 100755 => 100644 perl/lib/Data/MessagePack/Boolean.pm mode change 100755 => 100644 perl/t/10_splitted_bytes.t mode change 100755 => 100644 perl/t/50_leaktrace.t diff --git a/perl/lib/Data/MessagePack/Boolean.pm b/perl/lib/Data/MessagePack/Boolean.pm old mode 100755 new mode 100644 diff --git a/perl/t/10_splitted_bytes.t b/perl/t/10_splitted_bytes.t old mode 100755 new mode 100644 diff --git a/perl/t/50_leaktrace.t b/perl/t/50_leaktrace.t old mode 100755 new mode 100644 From a10eb2a0d760f0a2f3aaa16d539d621c0ec41de4 Mon Sep 17 00:00:00 2001 From: gfx Date: Fri, 17 Sep 2010 14:02:12 +0900 Subject: [PATCH 50/59] Changelogging --- perl/Changes | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/perl/Changes b/perl/Changes index 41203763..ce525818 100644 --- a/perl/Changes +++ b/perl/Changes @@ -1,3 +1,8 @@ + +0.24 + - Fixed a possible SEGV on streaming unpacking (gfx) + - Improve performance, esp. in unpacking (gfx) + 0.23 (NO FEATURE CHANGES) From 130d2064d583065c185e7d6d868c6c51b3731fa2 Mon Sep 17 00:00:00 2001 From: tokuhirom Date: Fri, 17 Sep 2010 15:28:24 +0900 Subject: [PATCH 51/59] perl: updated benchmark result! gfx++ # performance tuning --- perl/lib/Data/MessagePack.pm | 31 ++++++++++++++++++++----------- 1 file changed, 20 insertions(+), 11 deletions(-) diff --git a/perl/lib/Data/MessagePack.pm b/perl/lib/Data/MessagePack.pm index b1e0174d..7456c3a0 100644 --- a/perl/lib/Data/MessagePack.pm +++ b/perl/lib/Data/MessagePack.pm @@ -113,23 +113,32 @@ Pack the string as int when the value looks like int(EXPERIMENTAL). This is the result of benchmark/serialize.pl and benchmark/deserialize.pl on my SC440(Linux 2.6.32-23-server #37-Ubuntu SMP). + -- serialize JSON::XS: 2.3 - Data::MessagePack: 0.20 + Data::MessagePack: 0.24 Storable: 2.21 - Benchmark: timing 1000000 iterations of json, mp, storable... - json: 5 wallclock secs ( 3.95 usr + 0.00 sys = 3.95 CPU) @ 253164.56/s (n=1000000) - mp: 3 wallclock secs ( 2.69 usr + 0.00 sys = 2.69 CPU) @ 371747.21/s (n=1000000) - storable: 26 wallclock secs (27.21 usr + 0.00 sys = 27.21 CPU) @ 36751.19/s (n=1000000) - + Benchmark: running json, mp, storable for at least 1 CPU seconds... + json: 1 wallclock secs ( 1.00 usr + 0.01 sys = 1.01 CPU) @ 141939.60/s (n=143359) + mp: 1 wallclock secs ( 1.06 usr + 0.00 sys = 1.06 CPU) @ 355500.94/s (n=376831) + storable: 1 wallclock secs ( 1.12 usr + 0.00 sys = 1.12 CPU) @ 38399.11/s (n=43007) + Rate storable json mp + storable 38399/s -- -73% -89% + json 141940/s 270% -- -60% + mp 355501/s 826% 150% -- + -- deserialize JSON::XS: 2.3 - Data::MessagePack: 0.20 + Data::MessagePack: 0.24 Storable: 2.21 - Benchmark: timing 1000000 iterations of json, mp, storable... - json: 4 wallclock secs ( 4.45 usr + 0.00 sys = 4.45 CPU) @ 224719.10/s (n=1000000) - mp: 6 wallclock secs ( 5.45 usr + 0.00 sys = 5.45 CPU) @ 183486.24/s (n=1000000) - storable: 7 wallclock secs ( 7.77 usr + 0.00 sys = 7.77 CPU) @ 128700.13/s (n=1000000) + Benchmark: running json, mp, storable for at least 1 CPU seconds... + json: 0 wallclock secs ( 1.05 usr + 0.00 sys = 1.05 CPU) @ 179442.86/s (n=188415) + mp: 0 wallclock secs ( 1.01 usr + 0.00 sys = 1.01 CPU) @ 212909.90/s (n=215039) + storable: 2 wallclock secs ( 1.14 usr + 0.00 sys = 1.14 CPU) @ 114974.56/s (n=131071) + Rate storable json mp + storable 114975/s -- -36% -46% + json 179443/s 56% -- -16% + mp 212910/s 85% 19% -- =head1 AUTHORS From 2c9d90d463429902226eca593fccebec440a57ef Mon Sep 17 00:00:00 2001 From: gfx Date: Fri, 17 Sep 2010 18:08:15 +0900 Subject: [PATCH 52/59] perl: regen README --- perl/README | 28 ++++++++++++++++++---------- perl/lib/Data/MessagePack.pm | 2 +- 2 files changed, 19 insertions(+), 11 deletions(-) diff --git a/perl/README b/perl/README index e46323da..6272a3b2 100644 --- a/perl/README +++ b/perl/README @@ -56,21 +56,29 @@ SPEED -- serialize JSON::XS: 2.3 - Data::MessagePack: 0.20 + Data::MessagePack: 0.24 Storable: 2.21 - Benchmark: timing 1000000 iterations of json, mp, storable... - json: 5 wallclock secs ( 3.95 usr + 0.00 sys = 3.95 CPU) @ 253164.56/s (n=1000000) - mp: 3 wallclock secs ( 2.69 usr + 0.00 sys = 2.69 CPU) @ 371747.21/s (n=1000000) - storable: 26 wallclock secs (27.21 usr + 0.00 sys = 27.21 CPU) @ 36751.19/s (n=1000000) + Benchmark: running json, mp, storable for at least 1 CPU seconds... + json: 1 wallclock secs ( 1.00 usr + 0.01 sys = 1.01 CPU) @ 141939.60/s (n=143359) + mp: 1 wallclock secs ( 1.06 usr + 0.00 sys = 1.06 CPU) @ 355500.94/s (n=376831) + storable: 1 wallclock secs ( 1.12 usr + 0.00 sys = 1.12 CPU) @ 38399.11/s (n=43007) + Rate storable json mp + storable 38399/s -- -73% -89% + json 141940/s 270% -- -60% + mp 355501/s 826% 150% -- -- deserialize JSON::XS: 2.3 - Data::MessagePack: 0.20 + Data::MessagePack: 0.24 Storable: 2.21 - Benchmark: timing 1000000 iterations of json, mp, storable... - json: 4 wallclock secs ( 4.45 usr + 0.00 sys = 4.45 CPU) @ 224719.10/s (n=1000000) - mp: 6 wallclock secs ( 5.45 usr + 0.00 sys = 5.45 CPU) @ 183486.24/s (n=1000000) - storable: 7 wallclock secs ( 7.77 usr + 0.00 sys = 7.77 CPU) @ 128700.13/s (n=1000000) + Benchmark: running json, mp, storable for at least 1 CPU seconds... + json: 0 wallclock secs ( 1.05 usr + 0.00 sys = 1.05 CPU) @ 179442.86/s (n=188415) + mp: 0 wallclock secs ( 1.01 usr + 0.00 sys = 1.01 CPU) @ 212909.90/s (n=215039) + storable: 2 wallclock secs ( 1.14 usr + 0.00 sys = 1.14 CPU) @ 114974.56/s (n=131071) + Rate storable json mp + storable 114975/s -- -36% -46% + json 179443/s 56% -- -16% + mp 212910/s 85% 19% -- AUTHORS Tokuhiro Matsuno diff --git a/perl/lib/Data/MessagePack.pm b/perl/lib/Data/MessagePack.pm index 7456c3a0..609ea3cd 100644 --- a/perl/lib/Data/MessagePack.pm +++ b/perl/lib/Data/MessagePack.pm @@ -126,7 +126,7 @@ This is the result of benchmark/serialize.pl and benchmark/deserialize.pl on my storable 38399/s -- -73% -89% json 141940/s 270% -- -60% mp 355501/s 826% 150% -- - + -- deserialize JSON::XS: 2.3 Data::MessagePack: 0.24 From e8d8099563ced184991b188bfe7ed4189e24f334 Mon Sep 17 00:00:00 2001 From: gfx Date: Fri, 17 Sep 2010 18:08:34 +0900 Subject: [PATCH 53/59] Fix a macro redefinition --- perl/xs-src/unpack.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/perl/xs-src/unpack.c b/perl/xs-src/unpack.c index 6ebb48c2..e89b22c5 100644 --- a/perl/xs-src/unpack.c +++ b/perl/xs-src/unpack.c @@ -142,7 +142,7 @@ STATIC_INLINE int template_callback_IV(unpack_user* u PERL_UNUSED_DECL, IV const return 0; } -#define template_callback_uint64 template_callback_IV +#define template_callback_int64 template_callback_IV #endif /* IVSIZE */ From a0c18e4380a6c96688101e508acab43982dddfe1 Mon Sep 17 00:00:00 2001 From: gfx Date: Fri, 17 Sep 2010 18:16:33 +0900 Subject: [PATCH 54/59] Docs --- perl/lib/Data/MessagePack.pm | 19 +++++++++++-------- 1 file changed, 11 insertions(+), 8 deletions(-) diff --git a/perl/lib/Data/MessagePack.pm b/perl/lib/Data/MessagePack.pm index 609ea3cd..52021090 100644 --- a/perl/lib/Data/MessagePack.pm +++ b/perl/lib/Data/MessagePack.pm @@ -45,7 +45,7 @@ Data::MessagePack - MessagePack serialising/deserialising =head1 SYNOPSIS - my $packed = Data::MessagePack->pack($dat); + my $packed = Data::MessagePack->pack($dat); my $unpacked = Data::MessagePack->unpack($dat); =head1 DESCRIPTION @@ -61,11 +61,11 @@ It enables to exchange structured objects between many languages like JSON. But =over 4 -=item PORTABILITY +=item PORTABLE -Messagepack is language independent binary serialize format. +The MessagePack format does not depend on language nor byte order. -=item SMALL SIZE +=item SMALL IN SIZE say length(JSON::XS::encode_json({a=>1, b=>2})); # => 13 say length(Storable::nfreeze({a=>1, b=>2})); # => 21 @@ -76,6 +76,7 @@ The MessagePack format saves memory than JSON and Storable format. =item STREAMING DESERIALIZER MessagePack supports streaming deserializer. It is useful for networking such as RPC. +See L for details. =back @@ -105,13 +106,13 @@ unpack the $msgpackstr to a MessagePack format string. =item $Data::MessagePack::PreferInteger -Pack the string as int when the value looks like int(EXPERIMENTAL). +Packs a string as an integer, when it looks like an integer. =back =head1 SPEED -This is the result of benchmark/serialize.pl and benchmark/deserialize.pl on my SC440(Linux 2.6.32-23-server #37-Ubuntu SMP). +This is a result of benchmark/serialize.pl and benchmark/deserialize.pl on my SC440(Linux 2.6.32-23-server #37-Ubuntu SMP). -- serialize @@ -156,13 +157,15 @@ FURUHASHI Sadayuki hanekomu +gfx + =head1 LICENSE This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself. - =head1 SEE ALSO -L is official web site for MessagePack format. +L is the official web site for the MessagePack format. +=cut From 7c8f8703a19d77e23e07b777054d888eff49774a Mon Sep 17 00:00:00 2001 From: gfx Date: Fri, 17 Sep 2010 18:26:16 +0900 Subject: [PATCH 55/59] Add TODOs --- perl/lib/Data/MessagePack.pm | 19 +++++++++++++++++++ 1 file changed, 19 insertions(+) diff --git a/perl/lib/Data/MessagePack.pm b/perl/lib/Data/MessagePack.pm index 52021090..8c5cfac6 100644 --- a/perl/lib/Data/MessagePack.pm +++ b/perl/lib/Data/MessagePack.pm @@ -141,6 +141,25 @@ 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 TODO + +=over + +=item Error handling + +MessagePack cannot deal with complex scalars such as object references, +filehandles, and code references. We should report the errors more kindly. + +=item Streaming deserializer + +The current implementation of the streaming deserializer does not have internal +buffers while some other bindings (such as Ruby binding) does. This limitation +will astonish those who try to unpack byte streams with an arbitrary buffer size +(e.g. C<< while(read($socket, $buffer, $arbitrary_buffer_size)) { ... } >>). +We should implement the internal buffer for the unpacker. + +=back + =head1 AUTHORS Tokuhiro Matsuno From 845af014dce3c54c4294abefa8eb33b6bb39dd61 Mon Sep 17 00:00:00 2001 From: tokuhirom Date: Sat, 18 Sep 2010 06:15:51 +0900 Subject: [PATCH 56/59] perl: gfx is a author. --- 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 8c5cfac6..953bdf85 100644 --- a/perl/lib/Data/MessagePack.pm +++ b/perl/lib/Data/MessagePack.pm @@ -166,6 +166,8 @@ Tokuhiro Matsuno Makamaka Hannyaharamitu +gfx + =head1 THANKS TO Jun Kuriyama @@ -176,8 +178,6 @@ FURUHASHI Sadayuki hanekomu -gfx - =head1 LICENSE This library is free software; you can redistribute it and/or modify From 446266776eb1a36fd562307eb6de4c64e6cc36d1 Mon Sep 17 00:00:00 2001 From: tokuhirom Date: Sat, 18 Sep 2010 06:16:17 +0900 Subject: [PATCH 57/59] perl: regenerate README file --- perl/README | 36 ++++++++++++++++++++++++++---------- 1 file changed, 26 insertions(+), 10 deletions(-) diff --git a/perl/README b/perl/README index 6272a3b2..31052789 100644 --- a/perl/README +++ b/perl/README @@ -2,7 +2,7 @@ NAME Data::MessagePack - MessagePack serialising/deserialising SYNOPSIS - my $packed = Data::MessagePack->pack($dat); + my $packed = Data::MessagePack->pack($dat); my $unpacked = Data::MessagePack->unpack($dat); DESCRIPTION @@ -14,10 +14,10 @@ ABOUT MESSAGEPACK FORMAT But unlike JSON, it is very fast and small. ADVANTAGES - PORTABILITY - Messagepack is language independent binary serialize format. + PORTABLE + The MessagePack format does not depend on language nor byte order. - SMALL SIZE + SMALL IN SIZE say length(JSON::XS::encode_json({a=>1, b=>2})); # => 13 say length(Storable::nfreeze({a=>1, b=>2})); # => 21 say length(Data::MessagePack->pack({a=>1, b=>2})); # => 7 @@ -26,7 +26,7 @@ ABOUT MESSAGEPACK FORMAT STREAMING DESERIALIZER MessagePack supports streaming deserializer. It is useful for - networking such as RPC. + networking such as RPC. See Data::MessagePack::Unpacker for details. If you want to get more information about the MessagePack format, please visit to . @@ -47,12 +47,11 @@ METHODS Configuration Variables $Data::MessagePack::PreferInteger - Pack the string as int when the value looks like int(EXPERIMENTAL). + Packs a string as an integer, when it looks like an integer. SPEED - This is the result of benchmark/serialize.pl and - benchmark/deserialize.pl on my SC440(Linux 2.6.32-23-server #37-Ubuntu - SMP). + This is a result of benchmark/serialize.pl and benchmark/deserialize.pl + on my SC440(Linux 2.6.32-23-server #37-Ubuntu SMP). -- serialize JSON::XS: 2.3 @@ -80,11 +79,27 @@ SPEED json 179443/s 56% -- -16% mp 212910/s 85% 19% -- +TODO + Error handling + MessagePack cannot deal with complex scalars such as object + references, filehandles, and code references. We should report the + errors more kindly. + + Streaming deserializer + The current implementation of the streaming deserializer does not + have internal buffers while some other bindings (such as Ruby + binding) does. This limitation will astonish those who try to unpack + byte streams with an arbitrary buffer size (e.g. + "while(read($socket, $buffer, $arbitrary_buffer_size)) { ... }"). We + should implement the internal buffer for the unpacker. + AUTHORS Tokuhiro Matsuno Makamaka Hannyaharamitu + gfx + THANKS TO Jun Kuriyama @@ -99,5 +114,6 @@ LICENSE under the same terms as Perl itself. SEE ALSO - is official web site for MessagePack format. + is the official web site for the MessagePack + format. From 953aa95c648fef85f9c11c5ed251f3ddab988a83 Mon Sep 17 00:00:00 2001 From: tokuhirom Date: Sat, 18 Sep 2010 06:16:26 +0900 Subject: [PATCH 58/59] perl: added failing test case for streaming unpacker with PP. --- perl/t/11_stream_unpack3.t | 39 ++++++++++++++++++++++++++++++++++++++ 1 file changed, 39 insertions(+) create mode 100644 perl/t/11_stream_unpack3.t diff --git a/perl/t/11_stream_unpack3.t b/perl/t/11_stream_unpack3.t new file mode 100644 index 00000000..0eb8bff7 --- /dev/null +++ b/perl/t/11_stream_unpack3.t @@ -0,0 +1,39 @@ +use strict; +use warnings; +use Test::More; +use Data::MessagePack; + +my @data = ( [ 1, 2, 3 ], [ 4, 5, 6 ] ); + +# serialize +my $buffer = ''; +for my $d (@data) { + $buffer .= Data::MessagePack->pack($d); +} + +# deserialize +my $cb = sub { + my ($data) = @_; + + my $d = shift @data; + is_deeply $data, $d; +}; +my $unpacker = Data::MessagePack::Unpacker->new(); +my $nread = 0; +while (1) { + $nread = $unpacker->execute( $buffer, $nread ); + if ( $unpacker->is_finished ) { + my $ret = $unpacker->data; + $cb->( $ret ); + $unpacker->reset; + + $buffer = substr( $buffer, $nread ); + $nread = 0; + next if length($buffer) != 0; + } + last; +} +is scalar(@data), 0; + +done_testing; + From 2c9966a0a304dc4bdb5fc003100ec37b2ec3d70a Mon Sep 17 00:00:00 2001 From: tokuhirom Date: Sat, 18 Sep 2010 09:44:32 +0900 Subject: [PATCH 59/59] perl: fixed stream deserializer in pp. --- perl/lib/Data/MessagePack/PP.pm | 48 ++++++++++++++++++--------------- perl/t/03_stream_unpack.t | 4 +-- perl/t/09_stddata.t | 1 + perl/t/10_splitted_bytes.t | 6 +++-- perl/t/12_stream_unpack3.t | 23 ++++++++++++++++ 5 files changed, 57 insertions(+), 25 deletions(-) create mode 100644 perl/t/12_stream_unpack3.t diff --git a/perl/lib/Data/MessagePack/PP.pm b/perl/lib/Data/MessagePack/PP.pm index 6a06c3c6..0dd64272 100644 --- a/perl/lib/Data/MessagePack/PP.pm +++ b/perl/lib/Data/MessagePack/PP.pm @@ -370,7 +370,7 @@ package use strict; sub new { - bless { stack => [] }, shift; + bless { pos => 0 }, shift; } @@ -384,25 +384,30 @@ sub execute_limit { sub execute { my ( $self, $data, $offset, $limit ) = @_; - my $value = substr( $data, $offset || 0, $limit ? $limit : length $data ); + $offset ||= 0; + my $value = substr( $data, $offset, $limit ? $limit : length $data ); my $len = length $value; + $self->{data} .= $value; + local $self->{stack} = []; + $p = 0; - while ( $len > $p ) { - _count( $self, $value ) or last; + LOOP: while ( length($self->{data}) > $p ) { + _count( $self, $self->{data} ) or last; - if ( @{ $self->{stack} } > 0 ) { - pop @{ $self->{stack} } if --$self->{stack}->[-1] == 0; + while ( @{ $self->{stack} } > 0 && --$self->{stack}->[-1] == 0) { + pop @{ $self->{stack} }; + } + + if (@{$self->{stack}} == 0) { + $self->{is_finished}++; + last LOOP; } } + $self->{pos} = $p; - if ( $len == $p ) { - $self->{ data } .= substr( $value, 0, $p ); - $self->{ remain } = undef; - } - - return $p; + return $p + $offset; } @@ -424,7 +429,9 @@ sub _count { $num = $byte & ~0x90; } - push @{ $self->{stack} }, $num + 1; + if (defined($num) && $num > 0) { + push @{ $self->{stack} }, $num + 1; + } return 1; } @@ -443,7 +450,9 @@ sub _count { $num = $byte & ~0x80; } - push @{ $self->{stack} }, $num * 2 + 1; # a pair + if ($num > 0) { + push @{ $self->{stack} }, $num * 2 + 1; # a pair + } return 1; } @@ -511,22 +520,19 @@ sub _count { sub data { - my $data = Data::MessagePack->unpack( $_[0]->{ data } ); - $_[0]->reset; - return $data; + return Data::MessagePack->unpack( substr($_[0]->{ data }, 0, $_[0]->{pos}) ); } sub is_finished { my ( $self ) = @_; - ( scalar( @{ $self->{stack} } ) or defined $self->{ remain } ) ? 0 : 1; + return $self->{is_finished}; } - sub reset :method { - $_[0]->{ stack } = []; $_[0]->{ data } = undef; - $_[0]->{ remain } = undef; + $_[0]->{ pos } = 0; + $_[0]->{ is_finished } = 0; } 1; diff --git a/perl/t/03_stream_unpack.t b/perl/t/03_stream_unpack.t index a4ab4eba..646fc249 100644 --- a/perl/t/03_stream_unpack.t +++ b/perl/t/03_stream_unpack.t @@ -37,7 +37,7 @@ for (my $i=0; $iexecute("\xc0", 0); # nil } - ok $up->is_finished; - is_deeply $up->data, [undef, undef, undef, undef, undef]; + ok $up->is_finished, 'finished'; + is_deeply $up->data, [undef, undef, undef, undef, undef], 'array, is_deeply'; } diff --git a/perl/t/09_stddata.t b/perl/t/09_stddata.t index a618787d..f98d696b 100644 --- a/perl/t/09_stddata.t +++ b/perl/t/09_stddata.t @@ -32,6 +32,7 @@ for my $mpac($mpac1, $mpac2) { my $i = 0; while($offset < length($mpac)) { $offset = $mps->execute($mpac, $offset); + ok $mps->is_finished, "data[$i] : is_finished"; is_deeply $mps->data, $data[$i], "data[$i]"; $mps->reset; $i++; diff --git a/perl/t/10_splitted_bytes.t b/perl/t/10_splitted_bytes.t index 232d8707..15598f4e 100644 --- a/perl/t/10_splitted_bytes.t +++ b/perl/t/10_splitted_bytes.t @@ -27,12 +27,14 @@ foreach my $size(1 .. 16) { open my $stream, '<:bytes :scalar', \$packed; binmode $stream; my $buff; + my $done = 0; while( read($stream, $buff, $size) ) { #note "buff: ", join " ", map { unpack 'H2', $_ } split //, $buff; - $up->execute($buff); + $done = $up->execute($buff); } - ok $up->is_finished, 'is_finished'; + is $done, length($packed); + ok $up->is_finished, "is_finished: $size"; my $data = $up->data; is_deeply $data, $input; } diff --git a/perl/t/12_stream_unpack3.t b/perl/t/12_stream_unpack3.t new file mode 100644 index 00000000..118acc30 --- /dev/null +++ b/perl/t/12_stream_unpack3.t @@ -0,0 +1,23 @@ +use strict; +use warnings; +use Data::MessagePack; +use Test::More; +use t::Util; + +my @input = ( + +[[]], + [[],[]], + [{"a" => 97},{"a" => 97}], + [{"a" => 97},{"a" => 97},{"a" => 97}], +); + +plan tests => @input * 2; + +for my $input (@input) { + my $packed = Data::MessagePack->pack($input); + my $up = Data::MessagePack::Unpacker->new(); + $up->execute($packed, 0); + ok $up->is_finished, 'finished'; + is_deeply($up->data, $input); +} +