generic-library/msgpack
1
0
Fork 0
mirror of https://github.com/msgpack/msgpack-c.git synced 2025-03-21 06:11:18 +01:00
Code Issues Projects Releases Wiki Activity

Move perl/ to https://github.com/msgpack/msgpack-perl

Browse Source
This commit is contained in:
Fuji Goro 2011-08-19 12:37:03 +09:00
parent 2794b1d310
commit d36666bd98
42 changed files with 0 additions and 3344 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

20
perl/.gitignore vendored
View File

@ -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
*~

4
perl/.shipit
View File

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

169
perl/Changes
View File

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

30
perl/MANIFEST.SKIP
View File

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

112
perl/Makefile.PL
View File

@ -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 <<NOT_SUPPORT_C99;
This distribution requires a C99 compiler, but yours seems not to support C99.
Instead of XS, configure PP version.
NOT_SUPPORT_C99
}
}
else {
print "configure PP version\n\n";
requires 'Math::BigInt' => 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;
}

139
perl/README
View File

@ -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 <http://msgpack.org/>.
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
<http://msgpack.org/> is the official web site for the MessagePack
format.
Data::MessagePack::Unpacker
AnyEvent::MPRPC

6
perl/benchmark/data.pl
View File

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

27
perl/benchmark/deserialize.pl
View File

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

21
perl/benchmark/serialize.pl
View File

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

37
perl/benchmark/size.pl
View File

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

218
perl/lib/Data/MessagePack.pm
View File

@ -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<Data::MessagePack::Unpacker> for details.
=back
If you want to get more information about the MessagePack format, please visit to L<http://msgpack.org/>.
=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<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% --
=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<Math::BigInt>.
=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<http://msgpack.org/> is the official web site for the MessagePack format.
L<Data::MessagePack::Unpacker>
L<AnyEvent::MPRPC>
=cut

14
perl/lib/Data/MessagePack/Boolean.pm
View File

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

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

@ -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<Data::MessagePack> internally.
=head1 SEE ALSO
L<http://msgpack.sourceforge.jp/>,
L<Data::MessagePack>,
L<http://frox25.no-ip.org/~mtve/wiki/MessagePack.html>,
=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

76
perl/lib/Data/MessagePack/Unpacker.pod
View File

@ -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 <execute()>.
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<Data::MessagePack>

9
perl/t/00_compile.t
View File

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

66
perl/t/01_pack.t
View File

@ -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; $i<scalar(@dat); ) {
pis $dat[$i++], $dat[$i++];
}

28
perl/t/02_unpack.t
View File

@ -1,28 +0,0 @@
use Test::More;
use Data::MessagePack;
use t::Util;
no warnings 'uninitialized'; # i need this. i need this.
sub unpackit {
my $v = $_[0];
$v =~ s/ +//g;
$v = pack 'H*', $v;
return Data::MessagePack->unpack($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; $i<scalar(@dat); ) {
pis $dat[$i++], $dat[$i++];
}

43
perl/t/03_stream_unpack.t
View File

@ -1,43 +0,0 @@
use t::Util;
use Test::More;
use Data::MessagePack;
no warnings 'uninitialized'; # i need this. i need this.
my $up = Data::MessagePack::Unpacker->new;
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; $i<scalar(@dat); ) {
pis $dat[$i++], $dat[$i++];
}
# devided.
{
my $up = Data::MessagePack::Unpacker->new();
$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';
}

24
perl/t/04_invert.t
View File

@ -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; $i<scalar(@dat); ) {
$i++;
pis $dat[$i++];
}

66
perl/t/05_preferred_int.t
View File

@ -1,66 +0,0 @@
use t::Util;
use Test::More;
use Data::MessagePack;
use Data::Dumper;
no warnings; # shut up "Integer overflow in hexadecimal number"
sub packit {
local $_ = unpack("H*", Data::MessagePack->pack($_[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<scalar(@dat); ) {
local $Data::MessagePack::PreferInteger = 1;
my($x, $y) = ($i++, $i++);
pis $dat[$x], $dat[$y];
}
# flags working?
{
local $Data::MessagePack::PreferInteger;
$Data::MessagePack::PreferInteger = 1;
pis '0', '00';
$Data::MessagePack::PreferInteger = 0;
pis '0', 'a1 30';
}

60
perl/t/06_stream_unpack2.t
View File

@ -1,60 +0,0 @@
use strict;
use warnings;
use Data::MessagePack;
use Test::More tests => 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();
}
}

23
perl/t/07_break.t
View File

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

28
perl/t/08_cycle.t
View File

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

42
perl/t/09_stddata.t
View File

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

40
perl/t/10_splitted_bytes.t
View File

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

39
perl/t/11_stream_unpack3.t
View File

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

27
perl/t/12_stream_unpack4.t
View File

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

12
perl/t/13_booleans.t
View File

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

18
perl/t/14_invalid_data.t
View File

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

33
perl/t/15_utf8.t
View File

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

20
perl/t/16_unpacker_for_larges.t
View File

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

32
perl/t/17_canonical.t
View File

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

15
perl/t/18_new_interface.t
View File

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

62
perl/t/50_leaktrace.t
View File

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

18
perl/t/Util.pm
View File

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

55
perl/t/data.pl
View File

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

42
perl/xs-src/MessagePack.c
View File

@ -1,42 +0,0 @@
#include "xshelper.h"
#ifndef __cplusplus
#include <stdbool.h>
#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__);
}

323
perl/xs-src/pack.c
View File

@ -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; i<len; i++) {
SV* sv = *av_fetch(keys, i, TRUE);
he = hv_fetch_ent(hval, sv, FALSE, 0U);
_msgpack_pack_he(aTHX_ enc, hval, he, depth);
}
} else {
while ((he = hv_iternext(hval))) {
_msgpack_pack_he(aTHX_ enc, hval, he, depth);
}
}
} else if (svt == SVt_PVAV) {
AV* ary = (AV*)sv;
int len = av_len(ary) + 1;
int i;
msgpack_pack_array(enc, len);
for (i=0; i<len; i++) {
SV** svp = av_fetch(ary, i, 0);
if (svp) {
_msgpack_pack_sv(enc, *svp, depth);
} else {
msgpack_pack_nil(enc);
}
}
} else if (svt < SVt_PVAV) {
STRLEN len = 0;
char *pv = svt ? SvPV (sv, len) : 0;
if (len == 1 && *pv == '1')
msgpack_pack_true(enc);
else if (len == 1 && *pv == '0')
msgpack_pack_false(enc);
else {
//sv_dump(sv);
croak("cannot encode reference to scalar '%s' unless the scalar is 0 or 1",
SvPV_nolen (sv_2mortal (newRV_inc (sv))));
}
} else {
croak ("encountered %s, but msgpack can only represent references to arrays or hashes",
SvPV_nolen (sv_2mortal (newRV_inc (sv))));
}
}
XS(xs_pack) {
dXSARGS;
if (items < 2) {
Perl_croak(aTHX_ "Usage: Data::MessagePack->pack($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);
}

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

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

4
perl/xt/99_pod.t
View File

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

93
perl/xt/leaks/normal.t
View File

@ -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" ] }
}
]

108
perl/xt/leaks/stream.t
View File

@ -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" ] }
}
]