From d36666bd983626fc27e86a66b45449ccc647640e Mon Sep 17 00:00:00 2001 From: Fuji Goro Date: Fri, 19 Aug 2011 12:37:03 +0900 Subject: [PATCH] Move perl/ to https://github.com/msgpack/msgpack-perl --- perl/.gitignore | 20 - perl/.shipit | 4 - perl/Changes | 169 ------- perl/MANIFEST.SKIP | 30 -- perl/Makefile.PL | 112 ----- perl/README | 139 ------ perl/benchmark/data.pl | 6 - perl/benchmark/deserialize.pl | 27 -- perl/benchmark/serialize.pl | 21 - perl/benchmark/size.pl | 37 -- perl/lib/Data/MessagePack.pm | 218 --------- perl/lib/Data/MessagePack/Boolean.pm | 14 - perl/lib/Data/MessagePack/PP.pm | 628 ------------------------- perl/lib/Data/MessagePack/Unpacker.pod | 76 --- perl/t/00_compile.t | 9 - perl/t/01_pack.t | 66 --- perl/t/02_unpack.t | 28 -- perl/t/03_stream_unpack.t | 43 -- perl/t/04_invert.t | 24 - perl/t/05_preferred_int.t | 66 --- perl/t/06_stream_unpack2.t | 60 --- perl/t/07_break.t | 23 - perl/t/08_cycle.t | 28 -- perl/t/09_stddata.t | 42 -- perl/t/10_splitted_bytes.t | 40 -- perl/t/11_stream_unpack3.t | 39 -- perl/t/12_stream_unpack4.t | 27 -- perl/t/13_booleans.t | 12 - perl/t/14_invalid_data.t | 18 - perl/t/15_utf8.t | 33 -- perl/t/16_unpacker_for_larges.t | 20 - perl/t/17_canonical.t | 32 -- perl/t/18_new_interface.t | 15 - perl/t/50_leaktrace.t | 62 --- perl/t/Util.pm | 18 - perl/t/data.pl | 55 --- perl/xs-src/MessagePack.c | 42 -- perl/xs-src/pack.c | 323 ------------- perl/xs-src/unpack.c | 513 -------------------- perl/xt/99_pod.t | 4 - perl/xt/leaks/normal.t | 93 ---- perl/xt/leaks/stream.t | 108 ----- 42 files changed, 3344 deletions(-) delete mode 100644 perl/.gitignore delete mode 100644 perl/.shipit delete mode 100644 perl/Changes delete mode 100644 perl/MANIFEST.SKIP delete mode 100644 perl/Makefile.PL delete mode 100644 perl/README delete mode 100755 perl/benchmark/data.pl delete mode 100644 perl/benchmark/deserialize.pl delete mode 100644 perl/benchmark/serialize.pl delete mode 100644 perl/benchmark/size.pl delete mode 100644 perl/lib/Data/MessagePack.pm delete mode 100644 perl/lib/Data/MessagePack/Boolean.pm delete mode 100644 perl/lib/Data/MessagePack/PP.pm delete mode 100644 perl/lib/Data/MessagePack/Unpacker.pod delete mode 100644 perl/t/00_compile.t delete mode 100644 perl/t/01_pack.t delete mode 100644 perl/t/02_unpack.t delete mode 100644 perl/t/03_stream_unpack.t delete mode 100644 perl/t/04_invert.t delete mode 100644 perl/t/05_preferred_int.t delete mode 100644 perl/t/06_stream_unpack2.t delete mode 100644 perl/t/07_break.t delete mode 100644 perl/t/08_cycle.t delete mode 100644 perl/t/09_stddata.t delete mode 100644 perl/t/10_splitted_bytes.t delete mode 100644 perl/t/11_stream_unpack3.t delete mode 100644 perl/t/12_stream_unpack4.t delete mode 100755 perl/t/13_booleans.t delete mode 100755 perl/t/14_invalid_data.t delete mode 100644 perl/t/15_utf8.t delete mode 100644 perl/t/16_unpacker_for_larges.t delete mode 100644 perl/t/17_canonical.t delete mode 100644 perl/t/18_new_interface.t delete mode 100644 perl/t/50_leaktrace.t delete mode 100644 perl/t/Util.pm delete mode 100644 perl/t/data.pl delete mode 100644 perl/xs-src/MessagePack.c delete mode 100644 perl/xs-src/pack.c delete mode 100644 perl/xs-src/unpack.c delete mode 100644 perl/xt/99_pod.t delete mode 100644 perl/xt/leaks/normal.t delete mode 100644 perl/xt/leaks/stream.t diff --git a/perl/.gitignore b/perl/.gitignore deleted file mode 100644 index bf67c8ff..00000000 --- a/perl/.gitignore +++ /dev/null @@ -1,20 +0,0 @@ -META.yml -MYMETA.* -Makefile -Makefile.old -MessagePack.bs -MessagePack.o -blib/ -inc/ -msgpack/ -t/std/ -pack.o -pm_to_blib -unpack.o -MANIFEST -ppport.h -.testenv/ -xshelper.h -*.swp -*~ - diff --git a/perl/.shipit b/perl/.shipit deleted file mode 100644 index 3a66936b..00000000 --- a/perl/.shipit +++ /dev/null @@ -1,4 +0,0 @@ -steps = FindVersion, ChangeVersion, CheckChangeLog, DistTest, Commit, Tag, MakeDist, UploadCPAN -MakeDist.destination=~/.shipit-dist/ -git.tagpattern = perl-%v -git.push_to = origin diff --git a/perl/Changes b/perl/Changes deleted file mode 100644 index d219b4a1..00000000 --- a/perl/Changes +++ /dev/null @@ -1,169 +0,0 @@ -0.35 - - - address issue/20 (cho45): Data::MessagePack did not finish correctly - when was given devided packed data - -0.34 - - - do not use the corrupt my_snprintf(%ll[du]) on win32(kazuho) - -0.33 - - - fix tests (gfx) - - optimize unpacking routines in Data::MessagePack::PP (gfx) - -0.32 - - - add tests to detect Alpha problems reported via CPAN testers (gfx) - -0.31 - - - update Module::Install::XSUtil for ccache support (gfx) - - add version check at bootstrap in order to avoid load old .so (gfx) - -0.30 - - - fix utf8 mode not to be reseted by $unpacker->reset method (gfx) - -0.29 - - - add $unpacker->utf8 mode, decoding strings as UTF-8 (gfx) - -0.28 - - - added more tests(gfx) - - refactor the PP code(gfx) - -0.27 - - - * 6d9a629 perl: modified trivial codes in PP::Unpacker(makamaka) - - * ead8edc modified be unpack_(u)int64 in PP(makamaka) - -0.26 - - - fixed a serious code typo in PP(makamaka) - -0.25 - - (NO FEATURE CHANGES) - - oops. I failed releng. - -0.24 - - Fixed a lot of streaming unpacking issues (tokuhirom, gfx) - - Fixed unpacking issues for 64 bit integers on 32 bit perls (gfx) - - Improved performance, esp. in unpacking (gfx) - -0.23 - - (NO FEATURE CHANGES) - - fixed english docs(hanekomu++) - -0.22 - - - fixed issue on ithreads(broken from 0.21) - -0.21 - - - doc enhancments - - micro performance tuning. - -0.20 - - - first production ready release with PP driver. - -0.16_04 - - - no feature changes - -0.16_02 - - - document enhancement(tokuhirom) - - M::I::XSUtil 0.26 is broken. use 0.27. - -0.16_01 - - - added PP version (used in cases PERL_DATA_MESSAGEPACK=pp or fail to load XS). - - made Makefile.PL PP configurable. - - test_pp in author's test - - modified t/05_preferred_int.t for Win32 - (makamaka) - -0.16 - - - tests on 64bit machines with -Duselongdouble - (reported by andk) - -0.15 - - - better argument validation. - (Dan Kogai) - -0.14 - - - fixed segv on serializing cyclic reference - (Dan Kogai) - -0.13 - - - clearly specify requires_c99(), because msgpack C header requires C99. - -0.12 - - - PERL_NO_GET_CONTEXT makes horrible dTHXs. remove it. - -0.11 - - - oops(no feature changes) - -0.10 - - - added more test cases. - - fixed portability issue - - (reviewed by gfx++) - -0.09_01 - - - fixed memory leak issue(reported by Maxime Soulé) - -0.09 - - - support NVTYPE=="long double" or IVTYPE=="long long" environment - (thanks to Jun Kuriyama++) - -0.08 - - - fixed PVNV issue... - -0.07 - - - do not use switch (SvTYPE(val)). - -0.06 - - - use SvNOK. - -0.05 - - - change type detection for old perl - -0.04 - - - check SvROK first(reported by yappo++) - - PreferInteger: faster string to integer conversion; support negative value - (frsyuki++) - - make PreferInteger variable magical and remove get_sv from _msgpack_pack_sv - (frsyuki++) - -0.03 - - - performance tuning for too long string - - fixed memory leaks in stream unpacker - -0.02 - - - added $Data::MessagePack::PreferInteger - (requested by yappo++) - -0.01 - - - initial release to CPAN diff --git a/perl/MANIFEST.SKIP b/perl/MANIFEST.SKIP deleted file mode 100644 index 2a184b51..00000000 --- a/perl/MANIFEST.SKIP +++ /dev/null @@ -1,30 +0,0 @@ -\bRCS\b -\bCVS\b -^MANIFEST\. -^Makefile$ -^MYMETA\.(?:yml|json)$ -~$ -^# -\.old$ -\.swp$ -~$ -^blib/ -^pm_to_blib -^MakeMaker-\d -\.gz$ -\.cvsignore -^t/9\d_.*\.t -^t/perlcritic -^tools/ -\.svn/ -^[^/]+\.yaml$ -^[^/]+\.pl$ -^\.shipit$ -^\.git/ -\.sw[pon]$ -^\.gitignore$ -\.o$ -\.bs$ -^Data-MessagePack-[0-9.]+/ -^\.testenv/test_pp.pl -^ppport.h$ diff --git a/perl/Makefile.PL b/perl/Makefile.PL deleted file mode 100644 index 111b705c..00000000 --- a/perl/Makefile.PL +++ /dev/null @@ -1,112 +0,0 @@ -# Usage: Makefile.PL --pp # disable XS -# Makefile.PL -g # add -g to the compiler and disable optimization flags -use inc::Module::Install; -use Module::Install::XSUtil 0.36; - -name 'Data-MessagePack'; -all_from 'lib/Data/MessagePack.pm'; -readme_from('lib/Data/MessagePack.pm'); - -perl_version '5.008000'; -license 'perl'; - -tests 't/*.t'; -recursive_author_tests('xt'); - - -if ( $] >= 5.008005 and want_xs() ) { - my $has_c99 = c99_available(); # msgpack C library requires C99. - - if ( $has_c99 ) { - requires_c99(); - use_xshelper(); - cc_warnings; - cc_src_paths('xs-src'); - - if($Module::Install::AUTHOR) { - postamble qq{test :: test_pp\n\n}; - } - } - else { - print < 1.89; # old versions of BigInt were broken -} - -clean_files qw{ - *.stackdump - *.gcov *.gcda *.gcno - *.out - nytprof - cover_db -}; - -# copy modules -if ($Module::Install::AUTHOR && -d File::Spec->catfile('..', 'msgpack')) { - mkdir 'msgpack' unless -d 'msgpack'; - require File::Copy; - 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 -test_requires('Test::Requires'); - -test_with_env( test_pp => PERL_DATA_MESSAGEPACK => 'pp' ); - -repository('http://github.com/msgpack/msgpack'); -auto_include; -WriteAll; - -# copied from Makefile.PL in Text::Xslate. -sub test_with_env { - my($name, %env) = @_; - - my $dir = '.testenv'; - if(not -e $dir) { - mkdir $dir or die "Cannot mkdir '.testenv': $!"; - } - clean_files($dir); - - { - open my $out, '>', "$dir/$name.pl" - or die "Cannot open '$dir/$name.pl' for writing: $!"; - print $out "# This file sets the env for 'make $name', \n"; - print $out "# generated by $0 at ", scalar(localtime), ".\n"; - print $out "# DO NOT EDIT THIS FILE DIRECTLY.\n"; - print $out "\n"; - - while(my($name, $value) = each %env) { - printf $out '$ENV{q{%s}} = q{%s};'."\n", $name, $value; - } - } - - # repeat testing for pure Perl mode - # see also ExtUtils::MM_Any::test_via_harness() - - my $t = q{$(FULLPERLRUN) -MExtUtils::Command::MM -e} - .q{ "do q[%s]; test_harness($(TEST_VERBOSE), '$(INST_LIB)', '$(INST_ARCHLIB)')"} - .q{ $(TEST_FILES)}; - - postamble qq{$name :: pure_all\n} - . qq{\t} . q{$(NOECHO) $(ECHO) TESTING: } . $name . qq{\n} - . qq{\t} . sprintf($t, "$dir/$name.pl") . qq{\n\n} - - . qq{testall :: $name\n\n}; - return; -} diff --git a/perl/README b/perl/README deleted file mode 100644 index 3f25f70c..00000000 --- a/perl/README +++ /dev/null @@ -1,139 +0,0 @@ -NAME - Data::MessagePack - MessagePack serialising/deserialising - -SYNOPSIS - use Data::MessagePack; - - my $packed = Data::MessagePack->pack($dat); - my $unpacked = Data::MessagePack->unpack($dat); - -DESCRIPTION - This module converts Perl data structures to MessagePack and vice versa. - -ABOUT MESSAGEPACK FORMAT - MessagePack is a binary-based efficient object serialization format. It - enables to exchange structured objects between many languages like JSON. - But unlike JSON, it is very fast and small. - - ADVANTAGES - PORTABLE - The MessagePack format does not depend on language nor byte order. - - 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 - - The MessagePack format saves memory than JSON and Storable format. - - STREAMING DESERIALIZER - MessagePack supports streaming deserializer. It is useful for - networking such as RPC. See Data::MessagePack::Unpacker for details. - - If you want to get more information about the MessagePack format, please - visit to . - -METHODS - my $packed = Data::MessagePack->pack($data[, $max_depth]); - Pack the $data to messagepack format string. - - This method throws an exception when the perl structure is nested - more than $max_depth levels(default: 512) in order to detect - circular references. - - Data::MessagePack->pack() throws an exception when encountering - blessed object, because MessagePack is language-independent format. - - my $unpacked = Data::MessagePack->unpack($msgpackstr); - unpack the $msgpackstr to a MessagePack format string. - -Configuration Variables - $Data::MessagePack::PreferInteger - Packs a string as an integer, when it looks like an integer. - -SPEED - This is a result of benchmark/serialize.pl and benchmark/deserialize.pl - on my SC440(Linux 2.6.32-23-server #37-Ubuntu SMP). (You should - benchmark them with your data if the speed matters, of course.) - - -- serialize - JSON::XS: 2.3 - Data::MessagePack: 0.24 - Storable: 2.21 - 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.24 - Storable: 2.21 - 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% -- - -CAVEAT - Unpacking 64 bit integers - This module can unpack 64 bit integers even if your perl does not - support them (i.e. where "perl -V:ivsize" is 4), but you cannot - calculate these values unless you use "Math::BigInt". - -TODO - Error handling - MessagePack cannot deal with complex scalars such as object - 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. - - UTF8 mode - Data::MessagePack::Unpacker supports utf8 mode, which decodes - strings as UTF8-8. << Data::MessagePack->unpack >> should support - utf8 mode in a future. - -AUTHORS - Tokuhiro Matsuno - - Makamaka Hannyaharamitu - - gfx - -THANKS TO - Jun Kuriyama - - Dan Kogai - - FURUHASHI Sadayuki - - hanekomu - - Kazuho Oku - -LICENSE - This library is free software; you can redistribute it and/or modify it - under the same terms as Perl itself. - -SEE ALSO - is the official web site for the MessagePack - format. - - Data::MessagePack::Unpacker - - AnyEvent::MPRPC - diff --git a/perl/benchmark/data.pl b/perl/benchmark/data.pl deleted file mode 100755 index 6908d1cc..00000000 --- a/perl/benchmark/data.pl +++ /dev/null @@ -1,6 +0,0 @@ -+{ - "method" => "handleMessage", - "params" => [ "user1", "we were just talking", "foo\nbar\nbaz\nqux" ], - "id" => undef, - "array" => [ 1, 1024, 70000, -5, 1e5, 1e7, 1, 0, 3.14, sqrt(2), 1 .. 100 ], -}; diff --git a/perl/benchmark/deserialize.pl b/perl/benchmark/deserialize.pl deleted file mode 100644 index faa2582f..00000000 --- a/perl/benchmark/deserialize.pl +++ /dev/null @@ -1,27 +0,0 @@ -use strict; -use warnings; -use Data::MessagePack; -use JSON; -use Storable; -use Benchmark ':all'; - -#$Data::MessagePack::PreferInteger = 1; - -my $a = do 'benchmark/data.pl'; - -my $j = JSON::encode_json($a); -my $m = Data::MessagePack->pack($a); -my $s = Storable::freeze($a); - -print "-- deserialize\n"; -print "$JSON::Backend: ", $JSON::Backend->VERSION, "\n"; -print "Data::MessagePack: $Data::MessagePack::VERSION\n"; -print "Storable: $Storable::VERSION\n"; -cmpthese timethese( - -1 => { - json => sub { JSON::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 deleted file mode 100644 index 4982ff61..00000000 --- a/perl/benchmark/serialize.pl +++ /dev/null @@ -1,21 +0,0 @@ -use strict; -use warnings; -use Data::MessagePack; -use JSON; -use Storable; -use Benchmark ':all'; - -my $a = do 'benchmark/data.pl'; - -print "-- serialize\n"; -print "$JSON::Backend: ", $JSON::Backend->VERSION, "\n"; -print "Data::MessagePack: $Data::MessagePack::VERSION\n"; -print "Storable: $Storable::VERSION\n"; -cmpthese timethese( - -1 => { - json => sub { JSON::encode_json($a) }, - storable => sub { Storable::freeze($a) }, - mp => sub { Data::MessagePack->pack($a) }, - } -); - diff --git a/perl/benchmark/size.pl b/perl/benchmark/size.pl deleted file mode 100644 index cf5c1ce6..00000000 --- a/perl/benchmark/size.pl +++ /dev/null @@ -1,37 +0,0 @@ -#!/usr/bin/perl -use strict; -use warnings; -use Data::MessagePack; -use Storable; -use Text::SimpleTable; - -my @entries = ( - '1', - '3.14', - '{}', - '[]', - "[('a')x10]", - "{('a')x10}", - "+{1,+{1,+{}}}", - "+[+[+[]]]", -); - -my $table = Text::SimpleTable->new([15, 'src'], [9, 'storable'], [7, 'msgpack']); - -for my $src (@entries) { - my $e = eval $src; - die $@ if $@; - - $table->row( - $src, - length(Storable::nfreeze(ref $e ? $e : \$e)), - length(Data::MessagePack->pack($e)), - ); -} - -print "perl: $]\n"; -print "Storable: $Storable::VERSION\n"; -print "Data::MessagePack: $Data::MessagePack::VERSION\n"; -print "\n"; -print $table->draw; - diff --git a/perl/lib/Data/MessagePack.pm b/perl/lib/Data/MessagePack.pm deleted file mode 100644 index 65c4bedf..00000000 --- a/perl/lib/Data/MessagePack.pm +++ /dev/null @@ -1,218 +0,0 @@ -package Data::MessagePack; -use strict; -use warnings; -use 5.008001; - -our $VERSION = '0.34'; -our $PreferInteger = 0; -our $Canonical = 0; - -sub true () { - require Data::MessagePack::Boolean; - no warnings 'once'; - return $Data::MessagePack::Boolean::true; -} - -sub false () { - require Data::MessagePack::Boolean; - no warnings 'once'; - return $Data::MessagePack::Boolean::false; -} - -if ( !__PACKAGE__->can('pack') ) { # this idea comes from Text::Xslate - my $backend = $ENV{PERL_DATA_MESSAGEPACK} || ($ENV{PERL_ONLY} ? 'pp' : ''); - if ( $backend !~ /\b pp \b/xms ) { - eval { - require XSLoader; - XSLoader::load(__PACKAGE__, $VERSION); - }; - die $@ if $@ && $backend =~ /\b xs \b/xms; # force XS - } - if ( !__PACKAGE__->can('pack') ) { - require 'Data/MessagePack/PP.pm'; - } -} - -sub new { - my($class) = @_; - return bless {}, $class; -} - -sub encode; *encode = __PACKAGE__->can('pack'); -sub decode; *decode = __PACKAGE__->can('unpack'); - -1; -__END__ - -=head1 NAME - -Data::MessagePack - MessagePack serialising/deserialising - -=head1 SYNOPSIS - - use Data::MessagePack; - - my $packed = Data::MessagePack->pack($dat); - my $unpacked = Data::MessagePack->unpack($dat); - -=head1 DESCRIPTION - -This module converts Perl data structures to MessagePack and vice versa. - -=head1 ABOUT MESSAGEPACK FORMAT - -MessagePack is a binary-based efficient object serialization format. -It enables to exchange structured objects between many languages like JSON. -But unlike JSON, it is very fast and small. - -=head2 ADVANTAGES - -=over 4 - -=item PORTABLE - -The MessagePack format does not depend on language nor byte order. - -=item 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 - -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 - -If you want to get more information about the MessagePack format, please visit to L. - -=head1 METHODS - -=over 4 - -=item my $packed = Data::MessagePack->pack($data[, $max_depth]); - -Pack the $data to messagepack format string. - -This method throws an exception when the perl structure is nested more than $max_depth levels(default: 512) in order to detect circular references. - -Data::MessagePack->pack() throws an exception when encountering blessed object, because MessagePack is language-independent format. - -=item my $unpacked = Data::MessagePack->unpack($msgpackstr); - -unpack the $msgpackstr to a MessagePack format string. - -=back - -=head1 Configuration Variables - -=over 4 - -=item $Data::MessagePack::PreferInteger - -Packs a string as an integer, when it looks like an integer. - -=back - -=head1 SPEED - -This is a result of benchmark/serialize.pl and benchmark/deserialize.pl on my SC440(Linux 2.6.32-23-server #37-Ubuntu SMP). -(You should benchmark them with B data if the speed matters, of course.) - - -- serialize - JSON::XS: 2.3 - Data::MessagePack: 0.24 - Storable: 2.21 - 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.24 - Storable: 2.21 - 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 CAVEAT - -=head2 Unpacking 64 bit integers - -This module can unpack 64 bit integers even if your perl does not support them -(i.e. where C<< perl -V:ivsize >> is 4), but you cannot calculate these values -unless you use C. - -=head1 TODO - -=over - -=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. - -=item UTF8 mode - -Data::MessagePack::Unpacker supports utf8 mode, which decodes strings -as UTF8-8. << Data::MessagePack->unpack >> should support utf8 mode in a -future. - -=back - -=head1 AUTHORS - -Tokuhiro Matsuno - -Makamaka Hannyaharamitu - -gfx - -=head1 THANKS TO - -Jun Kuriyama - -Dan Kogai - -FURUHASHI Sadayuki - -hanekomu - -Kazuho Oku - -=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 the official web site for the MessagePack format. - -L - -L - -=cut diff --git a/perl/lib/Data/MessagePack/Boolean.pm b/perl/lib/Data/MessagePack/Boolean.pm deleted file mode 100644 index 2bb3ecad..00000000 --- a/perl/lib/Data/MessagePack/Boolean.pm +++ /dev/null @@ -1,14 +0,0 @@ -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/lib/Data/MessagePack/PP.pm b/perl/lib/Data/MessagePack/PP.pm deleted file mode 100644 index 65ce24b4..00000000 --- a/perl/lib/Data/MessagePack/PP.pm +++ /dev/null @@ -1,628 +0,0 @@ -package Data::MessagePack::PP; -use 5.008001; -use strict; -use warnings; -no warnings 'recursion'; - -use Carp (); -use B (); - -# 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 -# http://frox25.no-ip.org/~mtve/wiki/MessagePack.html : reference to using CORE::pack, CORE::unpack - -BEGIN { - my $unpack_int64_slow; - my $unpack_uint64_slow; - - if(!eval { pack 'Q', 1 }) { # don't have quad types - # emulates quad types with Math::BigInt. - # very slow but works well. - $unpack_int64_slow = sub { - require Math::BigInt; - my $high = unpack_uint32( $_[0], $_[1] ); - my $low = unpack_uint32( $_[0], $_[1] + 4); - - if($high < 0xF0000000) { # positive - $high = Math::BigInt->new( $high ); - $low = Math::BigInt->new( $low ); - return +($high << 32 | $low)->bstr; - } - else { # negative - $high = Math::BigInt->new( ~$high ); - $low = Math::BigInt->new( ~$low ); - return +( -($high << 32 | $low + 1) )->bstr; - } - }; - $unpack_uint64_slow = sub { - require Math::BigInt; - my $high = Math::BigInt->new( unpack_uint32( $_[0], $_[1]) ); - my $low = Math::BigInt->new( unpack_uint32( $_[0], $_[1] + 4) ); - return +($high << 32 | $low)->bstr; - }; - } - - *unpack_uint16 = sub { return unpack 'n', substr( $_[0], $_[1], 2 ) }; - *unpack_uint32 = sub { return unpack 'N', substr( $_[0], $_[1], 4 ) }; - - # for pack and unpack compatibility - if ( $] < 5.010 ) { - # require $Config{byteorder}; my $bo_is_le = ( $Config{byteorder} =~ /^1234/ ); - # which better? - my $bo_is_le = unpack ( 'd', "\x00\x00\x00\x00\x00\x00\xf0\x3f") == 1; # 1.0LE - - *unpack_int16 = sub { - my $v = unpack 'n', substr( $_[0], $_[1], 2 ); - return $v ? $v - 0x10000 : 0; - }; - *unpack_int32 = sub { - no warnings; # avoid for warning about Hexadecimal number - my $v = unpack 'N', substr( $_[0], $_[1], 4 ); - return $v ? $v - 0x100000000 : 0; - }; - - # In reality, since 5.9.2 '>' is introduced. but 'n!' and 'N!'? - if($bo_is_le) { - *pack_uint64 = sub { - 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_int64 = $unpack_int64_slow || sub { - my @v = unpack( 'V*', substr( $_[0], $_[1], 8 ) ); - return unpack( 'q', pack( 'N2', @v[1,0] ) ); - }; - *unpack_uint64 = $unpack_uint64_slow || 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_int64 = $unpack_int64_slow || sub { unpack 'q', substr( $_[0], $_[1], 8 ); }; - *unpack_uint64 = $unpack_uint64_slow || sub { unpack 'Q', substr( $_[0], $_[1], 8 ); }; - } - } - else { # 5.10.0 or later - # pack_int64/uint64 are used only when the perl support quad types - *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 ) ); }; - *unpack_int32 = sub { return unpack( 'N!', substr( $_[0], $_[1], 4 ) ); }; - - *unpack_int64 = $unpack_int64_slow || sub { return unpack( 'q>', substr( $_[0], $_[1], 8 ) ); }; - *unpack_uint64 = $unpack_uint64_slow || sub { return unpack( 'Q>', substr( $_[0], $_[1], 8 ) ); }; - } - - # fixin package symbols - no warnings 'once'; - sub pack :method; - sub unpack :method; - *Data::MessagePack::pack = \&pack; - *Data::MessagePack::unpack = \&unpack; - - @Data::MessagePack::Unpacker::ISA = qw(Data::MessagePack::PP::Unpacker); - - *true = \&Data::MessagePack::true; - *false = \&Data::MessagePack::false; -} - -sub _unexpected { - Carp::confess("Unexpected " . sprintf(shift, @_) . " found"); -} - - -# -# PACK -# - -our $_max_depth; - -sub pack :method { - Carp::croak('Usage: Data::MessagePack->pack($dat [,$max_depth])') if @_ < 2; - $_max_depth = defined $_[2] ? $_[2] : 512; # init - return _pack( $_[1] ); -} - - -sub _pack { - my ( $value ) = @_; - - local $_max_depth = $_max_depth - 1; - - if ( $_max_depth < 0 ) { - Carp::croak("perl structure exceeds maximum nesting level (max_depth set too low?)"); - } - - return CORE::pack( 'C', 0xc0 ) if ( not defined $value ); - - if ( ref($value) eq 'ARRAY' ) { - my $num = @$value; - my $header = - $num < 16 ? CORE::pack( 'C', 0x90 + $num ) - : $num < 2 ** 16 - 1 ? CORE::pack( 'Cn', 0xdc, $num ) - : $num < 2 ** 32 - 1 ? CORE::pack( 'CN', 0xdd, $num ) - : _unexpected("number %d", $num) - ; - return join( '', $header, map { _pack( $_ ) } @$value ); - } - - elsif ( ref($value) eq 'HASH' ) { - my $num = keys %$value; - my $header = - $num < 16 ? CORE::pack( 'C', 0x80 + $num ) - : $num < 2 ** 16 - 1 ? CORE::pack( 'Cn', 0xde, $num ) - : $num < 2 ** 32 - 1 ? CORE::pack( 'CN', 0xdf, $num ) - : _unexpected("number %d", $num) - ; - - if ($Data::MessagePack::Canonical) { - return join( '', $header, map { _pack( $_ ), _pack($value->{$_}) } sort { $a cmp $b } keys %$value ); - } else { - return join( '', $header, map { _pack( $_ ) } %$value ); - } - } - - 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 ) ) { - - if ($value >= 0) { - return $value <= 127 ? CORE::pack 'C', $value - : $value < 2 ** 8 ? CORE::pack 'CC', 0xcc, $value - : $value < 2 ** 16 ? CORE::pack 'Cn', 0xcd, $value - : $value < 2 ** 32 ? CORE::pack 'CN', 0xce, $value - : pack_uint64( $value ); - } - else { - return -$value <= 32 ? CORE::pack 'C', ($value & 255) - : -$value <= 2 ** 7 ? CORE::pack 'Cc', 0xd0, $value - : -$value <= 2 ** 15 ? CORE::pack 'Cn', 0xd1, $value - : -$value <= 2 ** 31 ? CORE::pack 'CN', 0xd2, $value - : pack_int64( $value ); - } - - } - elsif ( $flags & B::SVf_POK ) { # raw / check needs before dboule - - if ( $Data::MessagePack::PreferInteger ) { - if ( $value =~ /^-?[0-9]+$/ ) { # ok? - # checks whether $value is in (u)int32 - my $ivalue = 0 + $value; - if (!( - $ivalue > 0xFFFFFFFF - or $ivalue < '-'.0x80000000 # for XS compat - or $ivalue != B::svref_2object(\$ivalue)->int_value - )) { - return _pack( $ivalue ); - } - # fallthrough - } - # fallthrough - } - - utf8::encode( $value ) if utf8::is_utf8( $value ); - - my $num = length $value; - my $header = - $num < 32 ? CORE::pack( 'C', 0xa0 + $num ) - : $num < 2 ** 16 - 1 ? CORE::pack( 'Cn', 0xda, $num ) - : $num < 2 ** 32 - 1 ? CORE::pack( 'CN', 0xdb, $num ) - : _unexpected('number %d', $num) - ; - - return $header . $value; - - } - elsif ( $flags & ( B::SVf_NOK | B::SVp_NOK ) ) { # double only - return pack_double( $value ); - } - else { - _unexpected("data type %s", $b_obj); - } - -} - -# -# UNPACK -# - -our $_utf8 = 0; -my $p; # position variables for speed. - -sub _insufficient { - Carp::confess("Insufficient bytes (pos=$p, type=@_)"); -} - -sub unpack :method { - $p = 0; # init - my $data = _unpack( $_[1] ); - if($p < length($_[1])) { - Carp::croak("Data::MessagePack->unpack: extra bytes"); - } - return $data; -} - -my $T_RAW = 0x01; -my $T_ARRAY = 0x02; -my $T_MAP = 0x04; -my $T_DIRECT = 0x08; # direct mapping (e.g. 0xc0 <-> nil) - -my @typemap = ( (0x00) x 256 ); - -$typemap[$_] |= $T_ARRAY for - 0x90 .. 0x9f, # fix array - 0xdc, # array16 - 0xdd, # array32 -; -$typemap[$_] |= $T_MAP for - 0x80 .. 0x8f, # fix map - 0xde, # map16 - 0xdf, # map32 -; -$typemap[$_] |= $T_RAW for - 0xa0 .. 0xbf, # fix raw - 0xda, # raw16 - 0xdb, # raw32 -; - -my @byte2value; -foreach my $pair( - [0xc3, true], - [0xc2, false], - [0xc0, undef], - - (map { [ $_, $_ ] } 0x00 .. 0x7f), # positive fixnum - (map { [ $_, $_ - 0x100 ] } 0xe0 .. 0xff), # negative fixnum -) { - $typemap[ $pair->[0] ] |= $T_DIRECT; - $byte2value[ $pair->[0] ] = $pair->[1]; -} - -sub _fetch_size { - my($value_ref, $byte, $x16, $x32, $x_fixbits) = @_; - if ( $byte == $x16 ) { - $p += 2; - $p <= length(${$value_ref}) or _insufficient('x/16'); - return unpack 'n', substr( ${$value_ref}, $p - 2, 2 ); - } - elsif ( $byte == $x32 ) { - $p += 4; - $p <= length(${$value_ref}) or _insufficient('x/32'); - return unpack 'N', substr( ${$value_ref}, $p - 4, 4 ); - } - else { # fix raw - return $byte & ~$x_fixbits; - } -} - -sub _unpack { - my ( $value ) = @_; - $p < length($value) or _insufficient('header byte'); - # get a header byte - my $byte = ord( substr $value, $p, 1 ); - $p++; - - # +/- fixnum, nil, true, false - return $byte2value[$byte] if $typemap[$byte] & $T_DIRECT; - - if ( $typemap[$byte] & $T_RAW ) { - my $size = _fetch_size(\$value, $byte, 0xda, 0xdb, 0xa0); - my $s = substr( $value, $p, $size ); - length($s) == $size or _insufficient('raw'); - $p += $size; - utf8::decode($s) if $_utf8; - return $s; - } - elsif ( $typemap[$byte] & $T_ARRAY ) { - my $size = _fetch_size(\$value, $byte, 0xdc, 0xdd, 0x90); - my @array; - push @array, _unpack( $value ) while --$size >= 0; - return \@array; - } - elsif ( $typemap[$byte] & $T_MAP ) { - my $size = _fetch_size(\$value, $byte, 0xde, 0xdf, 0x80); - my %map; - while(--$size >= 0) { - no warnings; # for undef key case - my $key = _unpack( $value ); - my $val = _unpack( $value ); - $map{ $key } = $val; - } - return \%map; - } - - elsif ( $byte == 0xcc ) { # uint8 - $p++; - $p <= length($value) or _insufficient('uint8'); - return CORE::unpack( 'C', substr( $value, $p - 1, 1 ) ); - } - elsif ( $byte == 0xcd ) { # uint16 - $p += 2; - $p <= length($value) or _insufficient('uint16'); - return unpack_uint16( $value, $p - 2 ); - } - elsif ( $byte == 0xce ) { # unit32 - $p += 4; - $p <= length($value) or _insufficient('uint32'); - return unpack_uint32( $value, $p - 4 ); - } - elsif ( $byte == 0xcf ) { # unit64 - $p += 8; - $p <= length($value) or _insufficient('uint64'); - return unpack_uint64( $value, $p - 8 ); - } - elsif ( $byte == 0xd3 ) { # int64 - $p += 8; - $p <= length($value) or _insufficient('int64'); - return unpack_int64( $value, $p - 8 ); - } - elsif ( $byte == 0xd2 ) { # int32 - $p += 4; - $p <= length($value) or _insufficient('int32'); - return unpack_int32( $value, $p - 4 ); - } - elsif ( $byte == 0xd1 ) { # int16 - $p += 2; - $p <= length($value) or _insufficient('int16'); - return unpack_int16( $value, $p - 2 ); - } - elsif ( $byte == 0xd0 ) { # int8 - $p++; - $p <= length($value) or _insufficient('int8'); - return CORE::unpack 'c', substr( $value, $p - 1, 1 ); - } - elsif ( $byte == 0xcb ) { # double - $p += 8; - $p <= length($value) or _insufficient('double'); - return unpack_double( $value, $p - 8 ); - } - elsif ( $byte == 0xca ) { # float - $p += 4; - $p <= length($value) or _insufficient('float'); - return unpack_float( $value, $p - 4 ); - } - else { - _unexpected("byte 0x%02x", $byte); - } -} - - -# -# Data::MessagePack::Unpacker -# - -package - Data::MessagePack::PP::Unpacker; - -sub new { - bless { - pos => 0, - utf8 => 0, - buff => '', - }, shift; -} - -sub utf8 { - my $self = shift; - $self->{utf8} = (@_ ? shift : 1); - return $self; -} - -sub get_utf8 { - my($self) = @_; - return $self->{utf8}; -} - -sub execute_limit { - execute( @_ ); -} - -sub execute { - my ( $self, $data, $offset, $limit ) = @_; - $offset ||= 0; - my $value = substr( $data, $offset, $limit ? $limit : length $data ); - my $len = length $value; - - $self->{buff} .= $value; - local $self->{stack} = []; - - #$p = 0; - #eval { Data::MessagePack::PP::_unpack($self->{buff}) }; - #warn "[$p][$@]"; - $p = 0; - - while ( length($self->{buff}) > $p ) { - _count( $self, $self->{buff} ) or last; - - while ( @{ $self->{stack} } > 0 && --$self->{stack}->[-1] == 0) { - pop @{ $self->{stack} }; - } - - if (@{$self->{stack}} == 0) { - $self->{is_finished}++; - last; - } - } - $self->{pos} = $p; - - return $p + $offset; -} - - -sub _count { - my ( $self, $value ) = @_; - no warnings; # FIXME - my $byte = unpack( 'C', substr( $value, $p++, 1 ) ); # get header - - Carp::croak('invalid data') unless defined $byte; - - # +/- fixnum, nil, true, false - return 1 if $typemap[$byte] & $T_DIRECT; - - if ( $typemap[$byte] & $T_RAW ) { - my $num; - if ( $byte == 0xda ) { - $num = unpack 'n', substr( $value, $p, 2 ); - $p += 2; - } - elsif ( $byte == 0xdb ) { - $num = unpack 'N', substr( $value, $p, 4 ); - $p += 4; - } - else { # fix raw - $num = $byte & ~0xa0; - } - $p += $num; - return 1; - } - elsif ( $typemap[$byte] & $T_ARRAY ) { - my $num; - if ( $byte == 0xdc ) { # array 16 - $num = unpack 'n', substr( $value, $p, 2 ); - $p += 2; - } - elsif ( $byte == 0xdd ) { # array 32 - $num = unpack 'N', substr( $value, $p, 4 ); - $p += 4; - } - else { # fix array - $num = $byte & ~0x90; - } - - if ( $num ) { - push @{ $self->{stack} }, $num + 1; - } - - return 1; - } - elsif ( $typemap[$byte] & $T_MAP ) { - my $num; - if ( $byte == 0xde ) { # map 16 - $num = unpack 'n', substr( $value, $p, 2 ); - $p += 2; - } - elsif ( $byte == 0xdf ) { # map 32 - $num = unpack 'N', substr( $value, $p, 4 ); - $p += 4; - } - else { # fix map - $num = $byte & ~0x80; - } - - if ( $num ) { - push @{ $self->{stack} }, $num * 2 + 1; # a pair - } - - return 1; - } - - elsif ( $byte >= 0xcc and $byte <= 0xcf ) { # uint - $p += $byte == 0xcc ? 1 - : $byte == 0xcd ? 2 - : $byte == 0xce ? 4 - : $byte == 0xcf ? 8 - : Data::MessagePack::PP::_unexpected("byte 0x%02x", $byte); - return 1; - } - - elsif ( $byte >= 0xd0 and $byte <= 0xd3 ) { # int - $p += $byte == 0xd0 ? 1 - : $byte == 0xd1 ? 2 - : $byte == 0xd2 ? 4 - : $byte == 0xd3 ? 8 - : Data::MessagePack::PP::_unexpected("byte 0x%02x", $byte); - return 1; - } - elsif ( $byte == 0xca or $byte == 0xcb ) { # float, double - $p += $byte == 0xca ? 4 : 8; - return 1; - } - else { - Data::MessagePack::PP::_unexpected("byte 0x%02x", $byte); - } - - return 0; -} - - -sub data { - my($self) = @_; - local $Data::MessagePack::PP::_utf8 = $self->{utf8}; - return Data::MessagePack->unpack( substr($self->{buff}, 0, $self->{pos}) ); -} - - -sub is_finished { - my ( $self ) = @_; - return $self->{is_finished}; -} - -sub reset :method { - $_[0]->{buff} = ''; - $_[0]->{pos} = 0; - $_[0]->{is_finished} = 0; -} - -1; -__END__ - -=pod - -=head1 NAME - -Data::MessagePack::PP - Pure Perl implementation of Data::MessagePack - -=head1 DESCRIPTION - -This module is used by L internally. - -=head1 SEE ALSO - -L, -L, -L, - -=head1 AUTHOR - -makamaka - -=head1 COPYRIGHT AND LICENSE - -This library is free software; you can redistribute it and/or modify -it under the same terms as Perl itself. - -=cut diff --git a/perl/lib/Data/MessagePack/Unpacker.pod b/perl/lib/Data/MessagePack/Unpacker.pod deleted file mode 100644 index 04cb0a47..00000000 --- a/perl/lib/Data/MessagePack/Unpacker.pod +++ /dev/null @@ -1,76 +0,0 @@ -=head1 NAME - -Data::MessagePack::Unpacker - messagepack streaming deserializer - -=head1 SYNOPSIS - - use Data::Dumper; - my $up = Data::MessagePack::Unpacker->new; - - open my $fh, $data or die $!; - - my $offset = 0; - while( read($fh, my $buf, 1024) ) { - $offset = $up->execute($buf, $offset); - if($up->is_finished) { - print Dumper($up->data); - } - } - -=head1 DESCRIPTION - -This is a streaming deserializer for messagepack. - -=head1 METHODS - -=over 4 - -=item my $up = Data::MessagePack::Unpacker->new() - -creates a new instance of the stream deserializer. - -=item $up->utf8([$bool]) - -sets utf8 mode. true if I<$bool> is omitted. -returns I<$up> itself. - -If utf8 mode is enabled, strings will be decoded as UTF-8. - -The utf8 mode is disabled by default. - -=item my $ret = $up->get_utf8() - -returns the utf8 mode flag of I<$up>. - -=item $offset = $up->execute($data, $offset); - -=item $offset = $up->execute_limit($data, $offset, $limit) - -parses unpacked I<$data> from I<$offset> to I<$limit>. -returns a new offset of I<$data>, which is for the next . - -If I<$data> is insufficient, I<$offset> does not change, saving -I<$data> in internal buffers. - -=item my $bool = $up->is_finished(); - -is this deserializer finished? - -=item my $data = $up->data(); - -returns the deserialized object. - -=item $up->reset(); - -resets the stream deserializer, without memory zone. - -=back - -=head1 AUTHORS - -Tokuhiro Matsuno - -=head1 SEE ALSO - -L - diff --git a/perl/t/00_compile.t b/perl/t/00_compile.t deleted file mode 100644 index 29c6ca05..00000000 --- a/perl/t/00_compile.t +++ /dev/null @@ -1,9 +0,0 @@ -use strict; -use warnings; -use Test::More tests => 1; -use Config; -use_ok 'Data::MessagePack'; -diag ( "Testing Data::MessagePack/$Data::MessagePack::VERSION (", - $INC{'Data/MessagePack/PP.pm'} ? 'PP' : 'XS', ")" ); - -diag "byteoder: $Config{byteorder}, ivsize=$Config{ivsize}"; diff --git a/perl/t/01_pack.t b/perl/t/01_pack.t deleted file mode 100644 index 8c619809..00000000 --- a/perl/t/01_pack.t +++ /dev/null @@ -1,66 +0,0 @@ -use t::Util; -use Test::More; -use Data::MessagePack; - -sub packit { - local $_ = unpack("H*", Data::MessagePack->pack($_[0])); - s/(..)/$1 /g; - s/ $//; - $_; -} - -sub pis ($$) { - is packit($_[0]), $_[1], 'dump ' . $_[1]; -} - -my @dat = ( - 0, '00', - (my $foo="0")+0, '00', - {2 => undef}, '81 a1 32 c0', - do {no warnings; my $foo = 10; "$foo"; $foo = undef; $foo} => 'c0', # PVIV but !POK && !IOK - 1, '01', - 127, '7f', - 128, 'cc 80', - 255, 'cc ff', - 256, 'cd 01 00', - 65535, 'cd ff ff', - 65536, 'ce 00 01 00 00', - -1, 'ff', - -32, 'e0', - -33, 'd0 df', - -128, 'd0 80', - -129, 'd1 ff 7f', - -32768, 'd1 80 00', - -32769, 'd2 ff ff 7f ff', - 1.0, 'cb 3f f0 00 00 00 00 00 00', - do { my $x=3.0;my $y = "$x";$x }, 'a1 33', # PVNV - "", 'a0', - "a", 'a1 61', - "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa", 'bf 61 61 61 61 61 61 61 61 61 61 61 61 61 61 61 61 61 61 61 61 61 61 61 61 61 61 61 61 61 61 61', - "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa", 'da 00 20 61 61 61 61 61 61 61 61 61 61 61 61 61 61 61 61 61 61 61 61 61 61 61 61 61 61 61 61 61 61 61 61', - undef, 'c0', - Data::MessagePack::true(), 'c3', - Data::MessagePack::false(), 'c2', - [], '90', - [+[]], '91 90', - [[], undef], '92 90 c0', - {'a', 0}, '81 a1 61 00', - 8388608, 'ce 00 80 00 00', - - [undef, false, true], '93 c0 c2 c3', - ["", "a", "bc", "def"], '94 a0 a1 61 a2 62 63 a3 64 65 66', - [[], [[undef]]], '92 90 91 91 c0', - [undef, false, true], '93 c0 c2 c3', - [[0, 64, 127], [-32, -16, -1]], '92 93 00 40 7f 93 e0 f0 ff', - [0, -128, -1, 0, -32768, -1, 0, -2147483648, -1], '99 00 d0 80 ff 00 d1 80 00 ff 00 d2 80 00 00 00 ff', - 2147483648, 'ce 80 00 00 00', - -2147483648, 'd2 80 00 00 00', - 'a' x 0x0100, 'da 01 00' . (' 61' x 0x0100), - [(undef) x 0x0100], 'dc 01 00' . (' c0' x 0x0100), -); -plan tests => 1*(scalar(@dat)/2); - -for (my $i=0; $iunpack($v); -} - -sub pis ($$) { - is_deeply unpackit($_[0]), $_[1], 'dump ' . $_[0] - or do { - diag( 'got:', explain(unpackit($_[0])) ); - diag( 'expected:', explain($_[1]) ); - }; -} - -my @dat = do 't/data.pl' or die $@; - -plan tests => 1*(scalar(@dat)/2); - -for (my $i=0; $inew; -sub unpackit { - my $v = $_[0]; - $v =~ s/ //g; - $v = pack 'H*', $v; - $up->reset; - my $ret = $up->execute($v, 0); - if ($ret != length($v)) { - fail "extra bytes"; - } - return $up->data; -} - -sub pis ($$) { - is_deeply unpackit($_[0]), $_[1], 'dump ' . $_[0]; -} - -my @dat = do 't/data.pl'; - -plan tests => 1*(scalar(@dat)/2) + 3; - -isa_ok $up, 'Data::MessagePack::Unpacker'; -for (my $i=0; $inew(); - $up->execute("\x95", 0); # array marker - for (1..5) { - $up->execute("\xc0", 0); # nil - } - ok $up->is_finished, 'finished'; - is_deeply $up->data, [undef, undef, undef, undef, undef], 'array, is_deeply'; -} - diff --git a/perl/t/04_invert.t b/perl/t/04_invert.t deleted file mode 100644 index e1d565bf..00000000 --- a/perl/t/04_invert.t +++ /dev/null @@ -1,24 +0,0 @@ -use Test::More; -use Data::MessagePack; -use t::Util; -no warnings 'uninitialized'; # i need this. i need this. - -sub invert { - return Data::MessagePack->unpack( - Data::MessagePack->pack($_[0]), - ); -} - -sub pis ($) { - is_deeply invert($_[0]), $_[0], 'dump ' . $_[0]; -} - -my @dat = do 't/data.pl'; - -plan tests => 1*(scalar(@dat)/2); - -for (my $i=0; $ipack($_[0])); - s/(..)/$1 /g; - s/ $//; - $_; -} - -sub pis ($$) { - if (ref $_[1]) { - like packit($_[0]), $_[1], 'dump ' . $_[1]; - } else { - is packit($_[0]), $_[1], 'dump ' . $_[1]; - } - # is(Dumper(Data::MessagePack->unpack(Data::MessagePack->pack($_[0]))), Dumper($_[0])); -} - -my $is_win = $^O eq 'MSWin32'; -my @dat = ( - '', 'a0', - '0', '00', - '1', '01', - '10', '0a', - '-1', 'ff', - '-10', 'f6', - '-', 'a1 2d', - ''.0xEFFF => 'cd ef ff', - ''.0xFFFF => 'cd ff ff', - ''.0xFFFFFF => 'ce 00 ff ff ff', - ''.0xFFFFFFFF => 'ce ff ff ff ff', - ''.0xFFFFFFFFF => 'ab 36 38 37 31 39 34 37 36 37 33 35', - ''.0xFFFFFFFFFFFFFFFFFFFFFFFFFFFFF => $is_win ? - qr{^(b5 38 2e 33 30 37 36 37 34 39 37 33 36 35 35 37 32 65 2b 30 33 34|b8 38 2e 33 30 37 36 37 34 39 37 33 36 35 35 37 32 34 32 31 65 2b 30 33 34)$} - : qr{^(b4 38 2e 33 30 37 36 37 34 39 37 33 36 35 35 37 32 65 2b 33 34|b7 38 2e 33 30 37 36 37 34 39 37 33 36 35 35 37 32 34 32 31 65 2b 33 34)$}, - '-'.0x8000000 => 'd2 f8 00 00 00', - '-'.0x80000000 => 'd2 80 00 00 00', - '-'.0x800000000 => 'ac 2d 33 34 33 35 39 37 33 38 33 36 38', - '-'.0x8000000000 => 'ad 2d 35 34 39 37 35 35 38 31 33 38 38 38', - '-'.0x800000000000000000000000000000 => $is_win ? - qr{^(b6 2d 36 2e 36 34 36 31 33 39 39 37 38 39 32 34 35 38 65 2b 30 33 35|b9 2d 36 2e 36 34 36 31 33 39 39 37 38 39 32 34 35 37 39 33 36 65 2b 30 33 35)} - : qr{^(b5 2d 36 2e 36 34 36 31 33 39 39 37 38 39 32 34 35 38 65 2b 33 35|b8 2d 36 2e 36 34 36 31 33 39 39 37 38 39 32 34 35 37 39 33 36 65 2b 33 35)}, - {'0' => '1'}, '81 00 01', - {'abc' => '1'}, '81 a3 61 62 63 01', -); -plan tests => 1*(scalar(@dat)/2) + 2; - -for (my $i=0; $i 64; -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, 3.0,-3.0,"a","a",("a" x 70000),"","","", - [0],[0],[0],[],[],[],{},{},{}, - {"a" => 97},{"abc" => 97},{"xyz" => 97},[[]], [["foo"], ["bar"]], - [["foo", true, false, null, 42]], -]; - -my $packed = Data::MessagePack->pack($input); -is_deeply(Data::MessagePack->unpack($packed), $input); - -{ - my $up = Data::MessagePack::Unpacker->new(); - $up->execute($packed, 0); - ok $up->is_finished; - is_deeply $up->data, $input; -} - -{ - my $up = Data::MessagePack::Unpacker->new(); - $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); - - $offset = $up->execute($packed, $offset); - ok $up->is_finished, 'finished'; - my $data = $up->data; - is scalar(@{$data}), scalar(@{$input}), 'size of @{$data}'; - is_deeply $data, $input, "block $i, offset $offset"; - $up->reset(); - } -} - -{ - my $s = ''; - foreach my $datum(reverse @{$input}) { - $s .= Data::MessagePack->pack($datum); - } - - my $up = Data::MessagePack::Unpacker->new(); - - my $offset = 0; - for my $datum(reverse @{$input}) { - $offset = $up->execute($s, $offset); - is_deeply $up->data, $datum, "offset $offset/" . length($s); - $up->reset(); - } -} - diff --git a/perl/t/07_break.t b/perl/t/07_break.t deleted file mode 100644 index cf3f1079..00000000 --- a/perl/t/07_break.t +++ /dev/null @@ -1,23 +0,0 @@ -use Test::More; -use Data::MessagePack; -use t::Util; - -plan tests => 4; - -my $d = Data::MessagePack->unpack(Data::MessagePack->pack({ - nil => undef, - true => true, - false => false, - foo => [undef, true, false], -})); - -$d->{nil} = 42; -is $d->{nil}, 42; - -$d->{true} = 43; -is $d->{true}, 43; - -$d->{false} = 44; -is $d->{false}, 44; - -is_deeply $d->{foo}, [undef, true, false]; diff --git a/perl/t/08_cycle.t b/perl/t/08_cycle.t deleted file mode 100644 index 2bd66c10..00000000 --- a/perl/t/08_cycle.t +++ /dev/null @@ -1,28 +0,0 @@ -use t::Util; -use Test::More; -use Data::MessagePack; - -plan tests => 6; - -my $aref = [0]; -$aref->[1] = $aref; -eval { Data::MessagePack->pack($aref) }; -ok $@, $@; - -my $href = {}; -$href->{cycle} = $href; -eval { Data::MessagePack->pack($aref) }; -ok $@, $@; - -$aref = [0,[1,2]]; -eval { Data::MessagePack->pack($aref) }; -ok !$@; - -eval { Data::MessagePack->pack($aref, 3) }; -ok !$@; - -eval { Data::MessagePack->pack($aref, 2) }; -ok $@, $@; - -eval { Data::MessagePack->pack($aref, -1) }; -ok $@, $@; diff --git a/perl/t/09_stddata.t b/perl/t/09_stddata.t deleted file mode 100644 index f98d696b..00000000 --- a/perl/t/09_stddata.t +++ /dev/null @@ -1,42 +0,0 @@ -#!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 t::Util; - -use Data::MessagePack; - -sub slurp { - open my $fh, '<:raw', $_[0] or die "failed to open '$_[0]': $!"; - local $/; - return scalar <$fh>; -} - -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"); - -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); - ok $mps->is_finished, "data[$i] : is_finished"; - is_deeply $mps->data, $data[$i], "data[$i]"; - $mps->reset; - $i++; - } -} - -done_testing; diff --git a/perl/t/10_splitted_bytes.t b/perl/t/10_splitted_bytes.t deleted file mode 100644 index d94472d2..00000000 --- a/perl/t/10_splitted_bytes.t +++ /dev/null @@ -1,40 +0,0 @@ -#!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) { - my $up = Data::MessagePack::Unpacker->new(); - - 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; - - $done = $up->execute($buff); - } - is $done, length($packed); - ok $up->is_finished, "is_finished: $size"; - my $data = $up->data; - is_deeply $data, $input; -} - -done_testing; diff --git a/perl/t/11_stream_unpack3.t b/perl/t/11_stream_unpack3.t deleted file mode 100644 index 0eb8bff7..00000000 --- a/perl/t/11_stream_unpack3.t +++ /dev/null @@ -1,39 +0,0 @@ -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; - diff --git a/perl/t/12_stream_unpack4.t b/perl/t/12_stream_unpack4.t deleted file mode 100644 index ef6fa395..00000000 --- a/perl/t/12_stream_unpack4.t +++ /dev/null @@ -1,27 +0,0 @@ -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}], - [ map { +{ "foo $_" => "bar $_" } } 'aa' .. 'zz' ], - [42, null], - [42, true], - [42, false], -); - -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); -} - diff --git a/perl/t/13_booleans.t b/perl/t/13_booleans.t deleted file mode 100755 index 1ecbe646..00000000 --- a/perl/t/13_booleans.t +++ /dev/null @@ -1,12 +0,0 @@ -#!perl -w -use strict; -use Test::More tests => 6; -use Data::MessagePack; - -ok defined(Data::MessagePack::true()), 'true (1)'; -ok defined(Data::MessagePack::true()), 'true (2)'; -ok Data::MessagePack::true(), 'true is true'; - -ok defined(Data::MessagePack::false()), 'false (1)'; -ok defined(Data::MessagePack::false()), 'false (2)'; -ok !Data::MessagePack::false(), 'false is false'; diff --git a/perl/t/14_invalid_data.t b/perl/t/14_invalid_data.t deleted file mode 100755 index f5344857..00000000 --- a/perl/t/14_invalid_data.t +++ /dev/null @@ -1,18 +0,0 @@ -use strict; -use warnings; -use Data::MessagePack; -use Test::More; -use t::Util; - -my $nil = Data::MessagePack->pack(undef); - -my @data = do 't/data.pl'; -while(my($dump, $data) = splice @data, 0, 2) { - my $s = Data::MessagePack->pack($data); - eval { - Data::MessagePack->unpack($s . $nil); - }; - like $@, qr/extra bytes/, "dump $dump"; -} - -done_testing; diff --git a/perl/t/15_utf8.t b/perl/t/15_utf8.t deleted file mode 100644 index f3163dfa..00000000 --- a/perl/t/15_utf8.t +++ /dev/null @@ -1,33 +0,0 @@ -#!perl -w -use strict; -use Test::More; -use Data::MessagePack; -use utf8; - -my $data = [42, undef, 'foo', "\x{99f1}\x{99dd}"]; -my $packed = Data::MessagePack->pack($data) x 2; - -my $u = Data::MessagePack::Unpacker->new()->utf8(); -my $p = 0; -for(1 .. 2) { - ok $u->get_utf8(); - $p = $u->execute($packed, $p); - my $d = $u->data(); - $u->reset(); - is_deeply $d, $data, 'decoded'; -} - -is $u->utf8(0), $u, 'utf8(0)'; -$p = 0; -for(1 .. 2) { - ok !$u->get_utf8(); - $p = $u->execute($packed, $p); - my $d = $u->data(); - $u->reset(); - my $s = $data->[3]; - utf8::encode($s); - is_deeply $d->[3], $s, 'not decoded'; -} - -done_testing; - diff --git a/perl/t/16_unpacker_for_larges.t b/perl/t/16_unpacker_for_larges.t deleted file mode 100644 index 26894a20..00000000 --- a/perl/t/16_unpacker_for_larges.t +++ /dev/null @@ -1,20 +0,0 @@ -use strict; -use Test::More; -use Data::MessagePack; - -foreach my $data("abc", [ 'x' x 1024 ], [0xFFFF42]) { - my $packed = Data::MessagePack->pack($data); - - my $unpacker = Data::MessagePack::Unpacker->new; - note "buff: ", join " ", map { unpack 'H2', $_ } split //, $packed; - - foreach my $byte(split //, $packed) { - $unpacker->execute($byte); - } - - ok $unpacker->is_finished, 'finished'; - is_deeply $unpacker->data, $data, 'data'; -} - -done_testing; - diff --git a/perl/t/17_canonical.t b/perl/t/17_canonical.t deleted file mode 100644 index 5389e2f9..00000000 --- a/perl/t/17_canonical.t +++ /dev/null @@ -1,32 +0,0 @@ - -use strict; -use warnings; -use Test::More; -use Data::MessagePack; - -$Data::MessagePack::Canonical = 1; - -my $data = { - 'foo' => { - 'a' => '', - 'b' => '', - 'c' => '', - 'd' => '', - 'e' => '', - 'f' => '', - 'g' => '', - } -}; - -my $packed1 = +Data::MessagePack->pack($data); -my $packed2 = +Data::MessagePack->pack(Data::MessagePack->unpack($packed1)); -my $packed3 = +Data::MessagePack->pack(Data::MessagePack->unpack($packed2)); -my $packed4 = +Data::MessagePack->pack(Data::MessagePack->unpack($packed3)); -my $packed5 = +Data::MessagePack->pack(Data::MessagePack->unpack($packed4)); - -is $packed1, $packed2; -is $packed1, $packed3; -is $packed1, $packed4; -is $packed1, $packed5; - -done_testing; diff --git a/perl/t/18_new_interface.t b/perl/t/18_new_interface.t deleted file mode 100644 index 8867d208..00000000 --- a/perl/t/18_new_interface.t +++ /dev/null @@ -1,15 +0,0 @@ -#!perl -use strict; -use warnings; - -use Test::More; - -use Data::MessagePack; - -my $mp = Data::MessagePack->new(); - -is_deeply $mp->decode( $mp->encode(\%ENV) ), \%ENV; - - -done_testing; - diff --git a/perl/t/50_leaktrace.t b/perl/t/50_leaktrace.t deleted file mode 100644 index 440ac901..00000000 --- a/perl/t/50_leaktrace.t +++ /dev/null @@ -1,62 +0,0 @@ -#!perl -w -use strict; -use Test::Requires { 'Test::LeakTrace' => 0.13 }; -use Test::More; -use Data::MessagePack; -BEGIN { - if($INC{'Data/MessagePack/PP.pm'}) { - plan skip_all => 'disabled in PP'; - } -} - -my $simple_data = "xyz"; -my $complex_data = { - a => 'foo', - b => 42, - c => undef, - d => [qw(bar baz)], - e => 3.14, -}; - -note 'pack'; - -no_leaks_ok { - my $s = Data::MessagePack->pack($complex_data); -}; - -no_leaks_ok { - eval { Data::MessagePack->pack([\*STDIN]) }; - note $@; - $@ or warn "# it must die"; -}; - -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 $data = Data::MessagePack->unpack($c); -}; - -no_leaks_ok { - my $broken = $s; - chop $broken; - eval { Data::MessagePack->unpack($broken) }; - 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; diff --git a/perl/t/Util.pm b/perl/t/Util.pm deleted file mode 100644 index 0aa88bb6..00000000 --- a/perl/t/Util.pm +++ /dev/null @@ -1,18 +0,0 @@ -package t::Util; -use strict; -use warnings; -use Data::MessagePack; - -sub import { - my $pkg = caller(0); - - strict->import; - warnings->import; - - no strict 'refs'; - *{"$pkg\::true"} = \&Data::MessagePack::true; - *{"$pkg\::false"} = \&Data::MessagePack::false; - *{"$pkg\::null"} = sub() { undef }; -} - -1; diff --git a/perl/t/data.pl b/perl/t/data.pl deleted file mode 100644 index b7bbaf1a..00000000 --- a/perl/t/data.pl +++ /dev/null @@ -1,55 +0,0 @@ -no warnings; # i need this, i need this. -( - '93 c0 c2 c3' => [undef, false, true], - '94 a0 a1 61 a2 62 63 a3 64 65 66', ["", "a", "bc", "def"], - '92 90 91 91 c0', [[], [[undef]]], - '93 c0 c2 c3', [undef, false, true], - - '82 d0 2a c2 d0 2b c3', { 42 => false, 43 => true }, # fix map - 'de 00 02 d0 2a c2 d0 2b c3', { 42 => false, 43 => true }, # map 16 - 'df 00 00 00 02 d0 2a c2 d0 2b c3', { 42 => false, 43 => true }, # map 32 - - 'ce 80 00 00 00', 2147483648, - '99 cc 00 cc 80 cc ff cd 00 00 cd 80 00 cd ff ff ce 00 00 00 00 ce 80 00 00 00 ce ff ff ff ff', - [0, 128, 255, 0, 32768, 65535, 0, 2147483648, 4294967295], - '92 93 00 40 7f 93 e0 f0 ff', [[0, 64, 127], [-32, -16, -1]], - '96 dc 00 00 dc 00 01 c0 dc 00 02 c2 c3 dd 00 00 00 00 dd 00 00 00 01 c0 dd 00 00 00 02 c2 c3', - [[], [undef], [false, true], [], [undef], [false, true]], - '96 da 00 00 da 00 01 61 da 00 02 61 62 db 00 00 00 00 db 00 00 00 01 61 db 00 00 00 02 61 62', - ["", "a", "ab", "", "a", "ab"], - '99 d0 00 d0 80 d0 ff d1 00 00 d1 80 00 d1 ff ff d2 00 00 00 00 d2 80 00 00 00 d2 ff ff ff ff', - [0, -128, -1, 0, -32768, -1, 0, -2147483648, -1], - '82 c2 81 c0 c0 c3 81 c0 80', {false,{undef,undef}, true,{undef,{}}}, - '96 de 00 00 de 00 01 c0 c2 de 00 02 c0 c2 c3 c2 df 00 00 00 00 df 00 00 00 01 c0 c2 df 00 00 00 02 c0 c2 c3 c2', - [{}, {undef,false}, {true,false, undef,false}, {}, {undef,false}, {true,false, undef,false}], - 'dc 01 00' . (' c0' x 0x0100), [(undef) x 0x0100], - 'ce 00 ff ff ff' => ''.0xFFFFFF, - 'aa 34 32 39 34 39 36 37 32 39 35' => ''.0xFFFFFFFF, - 'ab 36 38 37 31 39 34 37 36 37 33 35' => ''.0xFFFFFFFFF, - - 'ca 00 00 00 00' => 0.0, # float - 'ca 40 2c cc cd' => unpack('f', pack 'f', 2.7), - - 'd2 80 00 00 01' => '-2147483647', # int32_t - 'ce 80 00 00 01' => '2147483649', # uint32_t - - 'd2 ff ff ff ff' => '-1', # int32_t - 'ce ff ff ff ff' => '4294967295', # uint32_t - - 'd3 00 00 00 00 80 00 00 01' => '2147483649', # int64_t - 'cf 00 00 00 00 80 00 00 01' => '2147483649', # uint64_t - - 'd3 ff 00 ff ff ff ff ff ff' => '-71776119061217281', # int64_t - 'cf ff 00 ff ff ff ff ff ff' => '18374967954648334335', # uint64_t - - 'd3 ff ff ff ff ff ff ff ff' => '-1', # int64_t - 'cf ff ff ff ff ff ff ff ff' => '18446744073709551615', # uint64_t - - # int64_t - 'd3 00 00 00 10 00 00 00 00' => '68719476736', - 'd3 00 00 00 10 00 00 00 01' => '68719476737', - 'd3 00 00 10 00 00 00 00 00' => '17592186044416', - 'd3 00 10 00 00 00 00 00 00' => '4503599627370496', - 'd3 10 00 00 00 00 00 00 00' => '1152921504606846976', - 'd3 11 00 00 00 00 00 00 00' => '1224979098644774912', -) diff --git a/perl/xs-src/MessagePack.c b/perl/xs-src/MessagePack.c deleted file mode 100644 index 82ad1084..00000000 --- a/perl/xs-src/MessagePack.c +++ /dev/null @@ -1,42 +0,0 @@ -#include "xshelper.h" - -#ifndef __cplusplus -#include -#endif - -XS(xs_pack); -XS(xs_unpack); -XS(xs_unpacker_new); -XS(xs_unpacker_utf8); -XS(xs_unpacker_get_utf8); -XS(xs_unpacker_execute); -XS(xs_unpacker_execute_limit); -XS(xs_unpacker_is_finished); -XS(xs_unpacker_data); -XS(xs_unpacker_reset); -XS(xs_unpacker_destroy); - -void init_Data__MessagePack_pack(pTHX_ bool const cloning); -void init_Data__MessagePack_unpack(pTHX_ bool const cloning); - -XS(boot_Data__MessagePack) { - dXSARGS; - XS_VERSION_BOOTCHECK; - - 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__); - - newXS("Data::MessagePack::Unpacker::new", xs_unpacker_new, __FILE__); - newXS("Data::MessagePack::Unpacker::utf8", xs_unpacker_utf8, __FILE__); - newXS("Data::MessagePack::Unpacker::get_utf8", xs_unpacker_get_utf8, __FILE__); - newXS("Data::MessagePack::Unpacker::execute", xs_unpacker_execute, __FILE__); - newXS("Data::MessagePack::Unpacker::execute_limit", xs_unpacker_execute_limit, __FILE__); - newXS("Data::MessagePack::Unpacker::is_finished", xs_unpacker_is_finished, __FILE__); - newXS("Data::MessagePack::Unpacker::data", xs_unpacker_data, __FILE__); - newXS("Data::MessagePack::Unpacker::reset", xs_unpacker_reset, __FILE__); - newXS("Data::MessagePack::Unpacker::DESTROY", xs_unpacker_destroy, __FILE__); -} - diff --git a/perl/xs-src/pack.c b/perl/xs-src/pack.c deleted file mode 100644 index 612e8a51..00000000 --- a/perl/xs-src/pack.c +++ /dev/null @@ -1,323 +0,0 @@ -/* - * code is written by tokuhirom. - * buffer alocation technique is taken from JSON::XS. thanks to mlehmann. - */ -#include "xshelper.h" - -#include "msgpack/pack_define.h" - -#define msgpack_pack_inline_func(name) \ - static inline void msgpack_pack ## name - -#define msgpack_pack_inline_func_cint(name) \ - static inline void msgpack_pack ## name - -typedef struct { - char *cur; /* SvPVX (sv) + current output position */ - const char *end; /* SvEND (sv) */ - SV *sv; /* result scalar */ -} enc_t; - -STATIC_INLINE void -dmp_append_buf(enc_t* const enc, const void* const buf, STRLEN const len) -{ - if (enc->cur + len >= enc->end) { - 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_mutable(enc->sv) + cur; - enc->end = SvPVX_const(enc->sv) + SvLEN (enc->sv) - 1; - } - - memcpy(enc->cur, buf, len); - enc->cur += len; -} - -#define msgpack_pack_user enc_t* - -#define msgpack_pack_append_buffer(enc, buf, len) \ - dmp_append_buf(enc, buf, len) - -#include "msgpack/pack_template.h" - -#define INIT_SIZE 32 /* initial scalar size to be allocated */ - -#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 - -#define ERR_NESTING_EXCEEDED "perl structure exceeds maximum nesting level (max_depth set too low?)" - -#define DMP_PREF_INT "PreferInteger" -#define DMP_CANONICAL "Canonical" - -/* interpreter global variables */ -#define MY_CXT_KEY "Data::MessagePack::_pack_guts" XS_VERSION -typedef struct { - bool prefer_int; - bool canonical; -} my_cxt_t; -START_MY_CXT - - -static int dmp_config_set(pTHX_ SV* sv, MAGIC* mg) { - dMY_CXT; - assert(mg->mg_ptr); - if(strEQ(mg->mg_ptr, DMP_PREF_INT)) { - MY_CXT.prefer_int = SvTRUE(sv) ? true : false; - } - else if(strEQ(mg->mg_ptr, DMP_CANONICAL)) { - MY_CXT.canonical = SvTRUE(sv) ? true : false; - } - else { - assert(0); - } - return 0; -} - -MGVTBL dmp_config_vtbl = { - NULL, - dmp_config_set, - NULL, - NULL, - NULL, - NULL, - NULL, -#ifdef MGf_LOCAL - NULL, -#endif -}; - -void init_Data__MessagePack_pack(pTHX_ bool const cloning PERL_UNUSED_DECL) { - MY_CXT_INIT; - MY_CXT.prefer_int = false; - MY_CXT.canonical = false; - - SV* var = get_sv("Data::MessagePack::" DMP_PREF_INT, TRUE); - sv_magicext(var, NULL, PERL_MAGIC_ext, &dmp_config_vtbl, - DMP_PREF_INT, 0); - SvSETMAGIC(var); - - var = get_sv("Data::MessagePack::" DMP_CANONICAL, TRUE); - sv_magicext(var, NULL, PERL_MAGIC_ext, &dmp_config_vtbl, - DMP_CANONICAL, 0); - SvSETMAGIC(var); -} - - -STATIC_INLINE int try_int(enc_t* enc, const char *p, size_t len) { - int negative = 0; - const char* pe = p + len; - uint64_t num = 0; - - if (len == 0) { return 0; } - - if (*p == '-') { - /* length(-0x80000000) == 11 */ - if (len <= 1 || len > 11) { return 0; } - negative = 1; - ++p; - } else { - /* length(0xFFFFFFFF) == 10 */ - if (len > 10) { return 0; } - } - -#if '9'=='8'+1 && '8'=='7'+1 && '7'=='6'+1 && '6'=='5'+1 && '5'=='4'+1 \ - && '4'=='3'+1 && '3'=='2'+1 && '2'=='1'+1 && '1'=='0'+1 - do { - unsigned int c = ((int)*(p++)) - '0'; - if (c > 9) { return 0; } - num = num * 10 + c; - } while(p < pe); -#else - do { - switch (*(p++)) { - case '0': num = num * 10 + 0; break; - case '1': num = num * 10 + 1; break; - case '2': num = num * 10 + 2; break; - case '3': num = num * 10 + 3; break; - case '4': num = num * 10 + 4; break; - case '5': num = num * 10 + 5; break; - case '6': num = num * 10 + 6; break; - case '7': num = num * 10 + 7; break; - case '8': num = num * 10 + 8; break; - case '9': num = num * 10 + 9; break; - default: return 0; - } - } while(p < pe); -#endif - - if (negative) { - if (num > 0x80000000) { return 0; } - msgpack_pack_int32(enc, ((int32_t)num) * -1); - } else { - if (num > 0xFFFFFFFF) { return 0; } - msgpack_pack_uint32(enc, (uint32_t)num); - } - - return 1; -} - - -STATIC_INLINE void _msgpack_pack_rv(pTHX_ 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 (UNLIKELY(depth <= 0)) Perl_croak(aTHX_ ERR_NESTING_EXCEEDED); - SvGETMAGIC(sv); - - if (SvPOKp(sv)) { - dMY_CXT; - STRLEN const len = SvCUR(sv); - const char* const pv = SvPVX_const(sv); - - if (MY_CXT.prefer_int && try_int(enc, pv, len)) { - return; - } else { - msgpack_pack_raw(enc, len); - msgpack_pack_raw_body(enc, pv, len); - } - } else if (SvNIOKp(sv)) { - if(SvUOK(sv)) { - PACK_UV(enc, SvUVX(sv)); - } - else if(SvIOKp(sv)) { - PACK_IV(enc, SvIVX(sv)); - } - else { - /* XXX long double is not supported yet. */ - msgpack_pack_double(enc, (double)SvNVX(sv)); - } - } else if (SvROK(sv)) { - _msgpack_pack_rv(aTHX_ enc, SvRV(sv), depth-1); - } else if (!SvOK(sv)) { - msgpack_pack_nil(enc); - } else if (isGV(sv)) { - Perl_croak(aTHX_ "msgpack cannot pack the GV\n"); - } else { - sv_dump(sv); - Perl_croak(aTHX_ "msgpack for perl doesn't supported this type: %d\n", SvTYPE(sv)); - } -} - -STATIC_INLINE -void _msgpack_pack_he(pTHX_ enc_t* enc, HV* hv, HE* he, int depth) { - _msgpack_pack_sv(enc, hv_iterkeysv(he), depth); - _msgpack_pack_sv(enc, hv_iterval(hv, he), depth); -} - -STATIC_INLINE void _msgpack_pack_rv(pTHX_ enc_t *enc, SV* sv, int depth) { - svtype svt; - assert(sv); - SvGETMAGIC(sv); - svt = SvTYPE(sv); - - if (SvOBJECT (sv)) { - HV *stash = gv_stashpv ("Data::MessagePack::Boolean", 1); // TODO: cache? - if (SvSTASH (sv) == stash) { - if (SvIV(sv)) { - msgpack_pack_true(enc); - } else { - msgpack_pack_false(enc); - } - } else { - croak ("encountered object '%s', Data::MessagePack doesn't allow the object", - SvPV_nolen(sv_2mortal(newRV_inc(sv)))); - } - } else if (svt == SVt_PVHV) { - dMY_CXT; - HV* hval = (HV*)sv; - int count = hv_iterinit(hval); - HE* he; - - msgpack_pack_map(enc, count); - - if (MY_CXT.canonical) { - AV* const keys = newAV(); - sv_2mortal((SV*)keys); - av_extend(keys, count); - - while ((he = hv_iternext(hval))) { - av_push(keys, SvREFCNT_inc(hv_iterkeysv(he))); - } - - int const len = av_len(keys) + 1; - sortsv(AvARRAY(keys), len, Perl_sv_cmp); - - int i; - for (i=0; ipack($dat [,$max_depth])"); - } - - SV* val = ST(1); - int depth = 512; - if (items >= 3) depth = SvIV(ST(2)); - - enc_t enc; - enc.sv = sv_2mortal(newSV(INIT_SIZE)); - enc.cur = SvPVX(enc.sv); - enc.end = SvEND(enc.sv); - SvPOK_only(enc.sv); - - _msgpack_pack_sv(&enc, val, depth); - - SvCUR_set(enc.sv, enc.cur - SvPVX (enc.sv)); - *SvEND (enc.sv) = 0; /* many xs functions expect a trailing 0 for text strings */ - - ST(0) = enc.sv; - XSRETURN(1); -} diff --git a/perl/xs-src/unpack.c b/perl/xs-src/unpack.c deleted file mode 100644 index e3f62c63..00000000 --- a/perl/xs-src/unpack.c +++ /dev/null @@ -1,513 +0,0 @@ -#define NEED_newRV_noinc -#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 - -// context data for execute_template() -typedef struct { - bool finished; - bool utf8; - SV* buffer; -} unpack_user; -#define UNPACK_USER_INIT { false, false, NULL } - -#include "msgpack/unpack_define.h" - -#define msgpack_unpack_struct(name) \ - struct template ## name - -#define msgpack_unpack_func(ret, name) \ - STATIC_INLINE ret template ## name - -#define msgpack_unpack_callback(name) \ - template_callback ## name - -#define msgpack_unpack_object SV* - -#define msgpack_unpack_user unpack_user - -void init_Data__MessagePack_unpack(pTHX_ bool const cloning) { - // booleans are load on demand (lazy load). - 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 SV* -load_bool(pTHX_ const char* const name) { - CV* const cv = get_cv(name, GV_ADD); - dSP; - ENTER; - SAVETMPS; - PUSHMARK(SP); - call_sv((SV*)cv, G_SCALAR); - SPAGAIN; - SV* const sv = newSVsv(POPs); - PUTBACK; - FREETMPS; - LEAVE; - assert(sv); - assert(sv_isobject(sv)); - if(!SvOK(sv)) { - croak("Oops: Failed to load %"SVf, name); - } - return sv; -} - -static SV* -get_bool(bool const value) { - dTHX; - 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); - } -} - -/* ---------------------------------------------------------------------- */ -struct template_context; -typedef struct template_context msgpack_unpack_t; - -static void template_init(msgpack_unpack_t* u); - -static SV* template_data(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 PERL_UNUSED_DECL) -{ - return NULL; -} - -#if IVSIZE == 4 - -STATIC_INLINE int template_callback_UV(unpack_user* u PERL_UNUSED_DECL, UV const d, SV** o) -{ - dTHX; - *o = newSVuv(d); - return 0; -} - -STATIC_INLINE int template_callback_IV(unpack_user* u PERL_UNUSED_DECL, IV const d, SV** o) -{ - dTHX; - *o = newSViv(d); - return 0; -} - -/* workaround win32 problems (my_snprintf(%llu) returns incorrect values ) */ -static char* str_from_uint64(char* buf_end, uint64_t v) -{ - char *p = buf_end; - *--p = '\0'; - do { - *--p = '0' + v % 10; - } while ((v /= 10) != 0); - return p; -} - -static const char* str_from_int64(char* buf_end, int64_t const v) { - bool const minus = v < 0; - char* p = str_from_uint64(buf_end, minus ? -v : v); - if (minus) - *--p = '-'; - return p; -} - -static int template_callback_uint64(unpack_user* u PERL_UNUSED_DECL, uint64_t const d, SV** o) -{ - dTHX; - char tbuf[64]; - const char* const s = str_from_uint64(tbuf + sizeof(tbuf), d); - *o = newSVpvn(s, tbuf + sizeof(tbuf) - 1 - s); - return 0; -} - -static int template_callback_int64(unpack_user* u PERL_UNUSED_DECL, int64_t const d, SV** o) -{ - dTHX; - char tbuf[64]; - const char* const s = str_from_int64(tbuf + sizeof(tbuf), d); - *o = newSVpvn(s, tbuf + sizeof(tbuf) - 1 - s); - return 0; -} - -#else /* IVSIZE == 8 */ - - -STATIC_INLINE int template_callback_UV(unpack_user* u PERL_UNUSED_DECL, UV const d, SV** o) -{ - dTHX; - *o = newSVuv(d); - return 0; -} - -#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 = newSViv(d); - return 0; -} - -#define template_callback_int64 template_callback_IV - -#endif /* IVSIZE */ - -#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 = 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 PERL_UNUSED_DECL, SV** o) -{ - dTHX; - *o = newSV(0); - return 0; -} - -STATIC_INLINE int template_callback_true(unpack_user* u PERL_UNUSED_DECL, SV** o) -{ - *o = get_bool(true); - return 0; -} - -STATIC_INLINE int template_callback_false(unpack_user* u PERL_UNUSED_DECL, SV** o) -{ - *o = get_bool(false); - return 0; -} - -STATIC_INLINE int template_callback_array(unpack_user* u PERL_UNUSED_DECL, unsigned int n, SV** o) -{ - dTHX; - AV* const a = newAV(); - *o = newRV_noinc((SV*)a); - av_extend(a, n + 1); - return 0; -} - -STATIC_INLINE int template_callback_array_item(unpack_user* u PERL_UNUSED_DECL, SV** c, SV* o) -{ - 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) - return 0; -} - -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; -} - -STATIC_INLINE int template_callback_map_item(unpack_user* u PERL_UNUSED_DECL, SV** c, SV* k, SV* v) -{ - dTHX; - HV* const h = (HV*)SvRV(*c); - assert(SvTYPE(h) == SVt_PVHV); - (void)hv_store_ent(h, k, v, 0); - SvREFCNT_dec(k); - return 0; -} - -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(p, l) returns an undef if p == NULL */ - *o = ((l==0) ? newSVpvs("") : newSVpvn(p, l)); - if(u->utf8) { - sv_utf8_decode(*o); - } - return 0; -} - -#include "msgpack/unpack_template.h" - -#define UNPACKER(from, name) \ - msgpack_unpack_t *name; \ - { \ - SV* const obj = from; \ - if(!(SvROK(obj) && SvIOK(SvRV(obj)))) { \ - Perl_croak(aTHX_ "Invalid unpacker instance for " #name); \ - } \ - name = INT2PTR(msgpack_unpack_t*, SvIVX(SvRV((obj)))); \ - if(name == NULL) { \ - Perl_croak(aTHX_ "NULL found for " # name " when shouldn't be"); \ - } \ - } - -XS(xs_unpack) { - dXSARGS; - SV* const data = ST(1); - size_t limit; - - 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])"); - } - - STRLEN dlen; - const char* const dptr = SvPV_const(data, dlen); - - msgpack_unpack_t mp; - template_init(&mp); - - unpack_user const u = UNPACK_USER_INIT; - 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 */ - - -XS(xs_unpacker_new) { - dXSARGS; - if (items != 1) { - Perl_croak(aTHX_ "Usage: Data::MessagePack::Unpacker->new()"); - } - - SV* const self = sv_newmortal(); - msgpack_unpack_t *mp; - - Newxz(mp, 1, msgpack_unpack_t); - template_init(mp); - unpack_user const u = UNPACK_USER_INIT; - mp->user = u; - - mp->user.buffer = newSV(80); - sv_setpvs(mp->user.buffer, ""); - - sv_setref_pv(self, "Data::MessagePack::Unpacker", mp); - - ST(0) = self; - XSRETURN(1); -} - -XS(xs_unpacker_utf8) { - dXSARGS; - if (!(items == 1 || items == 2)) { - Perl_croak(aTHX_ "Usage: $unpacker->utf8([$bool)"); - } - UNPACKER(ST(0), mp); - mp->user.utf8 = (items == 1 || sv_true(ST(1))) ? true : false; - XSRETURN(1); // returns $self -} - -XS(xs_unpacker_get_utf8) { - dXSARGS; - if (items != 1) { - Perl_croak(aTHX_ "Usage: $unpacker->get_utf8()"); - } - UNPACKER(ST(0), mp); - ST(0) = boolSV(mp->user.utf8); - XSRETURN(1); -} - -STATIC_INLINE size_t -_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 = offset; - const char* dptr = SvPV_nolen_const(data); - STRLEN dlen = limit; - - if(SvCUR(mp->user.buffer) != 0) { - sv_catpvn(mp->user.buffer, dptr, dlen); - dptr = SvPV_const(mp->user.buffer, dlen); - from = 0; - } - - int const ret = template_execute(mp, dptr, dlen, &from); - // ret < 0 : error - // ret == 0 : insufficient - // ret > 0 : success - - if(ret < 0) { - Perl_croak(aTHX_ - "Data::MessagePack::Unpacker: parse error while executing"); - } - - mp->user.finished = (ret > 0) ? true : false; - if(!mp->user.finished) { - template_init(mp); // reset the state - sv_setpvn(mp->user.buffer, dptr, dlen); - from = 0; - } - else { - sv_setpvs(mp->user.buffer, ""); - } - //warn(">> (%d) dlen=%d, from=%d, rest=%d", - // (int)ret, (int)dlen, (int)from, dlen - from); - return from; -} - -XS(xs_unpacker_execute) { - dXSARGS; - 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)"); - } - - dXSTARG; - sv_setuv(TARG, _execute_impl(self, data, offset, sv_len(data))); - ST(0) = TARG; - XSRETURN(1); -} - -XS(xs_unpacker_execute_limit) { - dXSARGS; - if (items != 4) { - Perl_croak(aTHX_ "Usage: $unpacker->execute_limit(data, offset, limit)"); - } - - SV* const self = ST(0); - SV* const data = ST(1); - UV const offset = SvUVx(ST(2)); - UV const limit = SvUVx(ST(3)); - - dXSTARG; - sv_setuv(TARG, _execute_impl(self, data, offset, limit)); - ST(0) = TARG; - XSRETURN(1); -} - -XS(xs_unpacker_is_finished) { - dXSARGS; - if (items != 1) { - Perl_croak(aTHX_ "Usage: $unpacker->is_finished()"); - } - - UNPACKER(ST(0), mp); - ST(0) = boolSV(mp->user.finished); - XSRETURN(1); -} - -XS(xs_unpacker_data) { - dXSARGS; - if (items != 1) { - Perl_croak(aTHX_ "Usage: $unpacker->data()"); - } - - UNPACKER(ST(0), mp); - ST(0) = template_data(mp); - XSRETURN(1); -} - -XS(xs_unpacker_reset) { - dXSARGS; - if (items != 1) { - Perl_croak(aTHX_ "Usage: $unpacker->reset()"); - } - - UNPACKER(ST(0), mp); - - SV* const data = template_data(mp); - SvREFCNT_dec(data); - - template_init(mp); - sv_setpvs(mp->user.buffer, ""); - - XSRETURN(0); -} - -XS(xs_unpacker_destroy) { - dXSARGS; - if (items != 1) { - Perl_croak(aTHX_ "Usage: $unpacker->DESTROY()"); - } - - UNPACKER(ST(0), mp); - - SV* const data = template_data(mp); - SvREFCNT_dec(data); - SvREFCNT_dec(mp->user.buffer); - Safefree(mp); - - XSRETURN(0); -} diff --git a/perl/xt/99_pod.t b/perl/xt/99_pod.t deleted file mode 100644 index 437887a0..00000000 --- a/perl/xt/99_pod.t +++ /dev/null @@ -1,4 +0,0 @@ -use Test::More; -eval "use Test::Pod 1.00"; -plan skip_all => "Test::Pod 1.00 required for testing POD" if $@; -all_pod_files_ok(); diff --git a/perl/xt/leaks/normal.t b/perl/xt/leaks/normal.t deleted file mode 100644 index 370b23e6..00000000 --- a/perl/xt/leaks/normal.t +++ /dev/null @@ -1,93 +0,0 @@ -use strict; -use warnings; -use Test::More; -use Data::MessagePack; -use Devel::Peek; - -plan skip_all => '$ENV{LEAK_TEST} is required' unless $ENV{LEAK_TEST}; - -my $input = [ - { - "ZCPGBENCH-1276933268" => - { "1271859210" => [ "\x14\x02\x07\x00\x00", 1 ] }, - "VDORBENCH-5637665303" => - { "1271859210" => [ "\x00\x01\x00\x01\x00", 1 ] }, - "ZVTHBENCH-7648578738" => { - "1271859210" => [ - "\x0a\x02\x04\x00\x00", "2600", - "\x0a\x05\x04\x00\x00", "4600" - ] - }, - "VMVTBENCH-5237337637" => - { "1271859210" => [ "\x00\x01\x00\x01\x00", 1 ] }, - "ZPLSBENCH-1823993880" => - { "1271859210" => [ "\x01\x07\x07\x03\x06", "10001" ] }, - "ZCPGBENCH-1995524375" => - { "1271859210" => [ "\x14\x02\x07\x00\x00", 1 ] }, - "ZCPGBENCH-2330423245" => - { "1271859210" => [ "\x14\x02\x07\x00\x00", 1 ] }, - "ZCPGBENCH-2963065090" => - { "1271859210" => [ "\x14\x02\x07\x00\x00", 1 ] }, - "MINT0" => { "1271859210" => [ "\x00\x01\x00\x01\x00", "D" ] } - } -]; -my $r = Data::MessagePack->pack($input); -my $n1 = trace(10); -my $n2 = trace(10000); -diag("$n1, $n2"); - -cmp_ok abs($n2-$n1), '<', 100; - -done_testing; - -sub trace { - my $n = shift; - my $before = memoryusage(); - for ( 1 .. $n ) { - my $x = Data::MessagePack->unpack($r); - # is_deeply($x, $input); - } - my $after = memoryusage(); - diag("$n\t: $after - $before"); - return $after - $before; -} - -sub memoryusage { - my $status = `cat /proc/$$/status`; - my @lines = split( "\n", $status ); - foreach my $line (@lines) { - if ( $line =~ /^VmRSS:/ ) { - $line =~ s/.*:\s*(\d+).*/$1/; - return int($line); - } - } - return -1; -} - -__END__ - [ - { - "ZCPGBENCH-1276933268" => - { "1271859210" => [ "\x14\x02\x07\x00\x00", 1 ] }, - "VDORBENCH-5637665303" => - { "1271859210" => [ "\x00\x01\x00\x01\x00", 1 ] }, - "ZVTHBENCH-7648578738" => { - "1271859210" => [ - "\x0a\x02\x04\x00\x00", "2600", - "\x0a\x05\x04\x00\x00", "4600" - ] - }, - "VMVTBENCH-5237337637" => - { "1271859210" => [ "\x00\x01\x00\x01\x00", 1 ] }, - "ZPLSBENCH-1823993880" => - { "1271859210" => [ "\x01\x07\x07\x03\x06", "10001" ] }, - "ZCPGBENCH-1995524375" => - { "1271859210" => [ "\x14\x02\x07\x00\x00", 1 ] }, - "ZCPGBENCH-2330423245" => - { "1271859210" => [ "\x14\x02\x07\x00\x00", 1 ] }, - "ZCPGBENCH-2963065090" => - { "1271859210" => [ "\x14\x02\x07\x00\x00", 1 ] }, - "MINT0" => { "1271859210" => [ "\x00\x01\x00\x01\x00", "D" ] } - } - ] - diff --git a/perl/xt/leaks/stream.t b/perl/xt/leaks/stream.t deleted file mode 100644 index 7765d733..00000000 --- a/perl/xt/leaks/stream.t +++ /dev/null @@ -1,108 +0,0 @@ -use strict; -use warnings; -use Test::More; -use Data::MessagePack; -use Devel::Peek; - -plan skip_all => '$ENV{LEAK_TEST} is required' unless $ENV{LEAK_TEST}; - -my $input = [ - { - "ZCPGBENCH-1276933268" => - { "1271859210" => [ "\x14\x02\x07\x00\x00", 1 ] }, - "VDORBENCH-5637665303" => - { "1271859210" => [ "\x00\x01\x00\x01\x00", 1 ] }, - "ZVTHBENCH-7648578738" => { - "1271859210" => [ - "\x0a\x02\x04\x00\x00", "2600", - "\x0a\x05\x04\x00\x00", "4600" - ] - }, - "VMVTBENCH-5237337637" => - { "1271859210" => [ "\x00\x01\x00\x01\x00", 1 ] }, - "ZPLSBENCH-1823993880" => - { "1271859210" => [ "\x01\x07\x07\x03\x06", "10001" ] }, - "ZCPGBENCH-1995524375" => - { "1271859210" => [ "\x14\x02\x07\x00\x00", 1 ] }, - "ZCPGBENCH-2330423245" => - { "1271859210" => [ "\x14\x02\x07\x00\x00", 1 ] }, - "ZCPGBENCH-2963065090" => - { "1271859210" => [ "\x14\x02\x07\x00\x00", 1 ] }, - "MINT0" => { "1271859210" => [ "\x00\x01\x00\x01\x00", "D" ] } - } -]; -$input = [(undef)x10]; -my $r = Data::MessagePack->pack($input); - -my $n1 = trace(10); -my $n2 = trace(10000); -diag("$n1, $n2"); - -cmp_ok abs($n2-$n1), '<', 100; - -done_testing; - -sub trace { - my $n = shift; - my $before = memoryusage(); - for ( 1 .. $n ) { - my $unpacker = Data::MessagePack::Unpacker->new(); - $unpacker->execute($r, 0); - # ok $unpacker->is_finished if $i % 100 == 0; - if ($unpacker->is_finished) { - my $x = $unpacker->data; - # is_deeply($x, $input) if $i % 100 == 0; - } - $unpacker->reset(); - $unpacker->execute($r, 0); - $unpacker->reset(); - $unpacker->execute(substr($r, 0, 1), 0); - $unpacker->execute(substr($r, 0, 2), 1); - $unpacker->execute($r, 2); - $unpacker->reset(); - $r or die; - } - my $after = memoryusage(); - diag("$n\t: $after - $before"); - return $after - $before; -} - -sub memoryusage { - my $status = `cat /proc/$$/status`; - my @lines = split( "\n", $status ); - foreach my $line (@lines) { - if ( $line =~ /^VmRSS:/ ) { - $line =~ s/.*:\s*(\d+).*/$1/; - return int($line); - } - } - return -1; -} - -__END__ - [ - { - "ZCPGBENCH-1276933268" => - { "1271859210" => [ "\x14\x02\x07\x00\x00", 1 ] }, - "VDORBENCH-5637665303" => - { "1271859210" => [ "\x00\x01\x00\x01\x00", 1 ] }, - "ZVTHBENCH-7648578738" => { - "1271859210" => [ - "\x0a\x02\x04\x00\x00", "2600", - "\x0a\x05\x04\x00\x00", "4600" - ] - }, - "VMVTBENCH-5237337637" => - { "1271859210" => [ "\x00\x01\x00\x01\x00", 1 ] }, - "ZPLSBENCH-1823993880" => - { "1271859210" => [ "\x01\x07\x07\x03\x06", "10001" ] }, - "ZCPGBENCH-1995524375" => - { "1271859210" => [ "\x14\x02\x07\x00\x00", 1 ] }, - "ZCPGBENCH-2330423245" => - { "1271859210" => [ "\x14\x02\x07\x00\x00", 1 ] }, - "ZCPGBENCH-2963065090" => - { "1271859210" => [ "\x14\x02\x07\x00\x00", 1 ] }, - "MINT0" => { "1271859210" => [ "\x00\x01\x00\x01\x00", "D" ] } - } - ] -