mirror of
https://github.com/msgpack/msgpack-c.git
synced 2025-03-28 09:14:12 +01:00
Merge branch 'master' of github.com:msgpack/msgpack
This commit is contained in:
commit
6bb8b4c994
1
perl/.gitignore
vendored
1
perl/.gitignore
vendored
@ -1,4 +1,5 @@
|
|||||||
META.yml
|
META.yml
|
||||||
|
MYMETA.yml
|
||||||
Makefile
|
Makefile
|
||||||
Makefile.old
|
Makefile.old
|
||||||
MessagePack.bs
|
MessagePack.bs
|
||||||
|
@ -1,7 +1,8 @@
|
|||||||
|
|
||||||
0.24
|
0.24
|
||||||
- Fixed a possible SEGV on streaming unpacking (gfx)
|
- Fixed a lot of streaming unpacking issues (tokuhirom, gfx)
|
||||||
- Improve performance, esp. in unpacking (gfx)
|
- Fixed unpacking issues for 64 bit integers on 32 bit perls (gfx)
|
||||||
|
- Improved performance, esp. in unpacking (gfx)
|
||||||
|
|
||||||
0.23
|
0.23
|
||||||
|
|
||||||
|
@ -2,6 +2,7 @@
|
|||||||
\bCVS\b
|
\bCVS\b
|
||||||
^MANIFEST\.
|
^MANIFEST\.
|
||||||
^Makefile$
|
^Makefile$
|
||||||
|
^MYMETA\.yml$
|
||||||
~$
|
~$
|
||||||
^#
|
^#
|
||||||
\.old$
|
\.old$
|
||||||
|
@ -1,3 +1,5 @@
|
|||||||
|
# Usage: Makefile.PL --pp # disable XS
|
||||||
|
# Makefile.PL -g # add -g to the compiler and disable optimization flags
|
||||||
use inc::Module::Install;
|
use inc::Module::Install;
|
||||||
use Module::Install::XSUtil 0.32;
|
use Module::Install::XSUtil 0.32;
|
||||||
use Config;
|
use Config;
|
||||||
@ -21,8 +23,9 @@ if ( $] >= 5.008005 and want_xs() ) {
|
|||||||
if ( $has_c99 ) {
|
if ( $has_c99 ) {
|
||||||
use_xshelper();
|
use_xshelper();
|
||||||
cc_src_paths('xs-src');
|
cc_src_paths('xs-src');
|
||||||
if ($ENV{DEBUG}) {
|
|
||||||
cc_append_to_ccflags '-g';
|
if($Module::Install::AUTHOR) {
|
||||||
|
postamble qq{test :: test_pp\n\n};
|
||||||
}
|
}
|
||||||
}
|
}
|
||||||
else {
|
else {
|
||||||
@ -37,6 +40,7 @@ NOT_SUPPORT_C99
|
|||||||
}
|
}
|
||||||
else {
|
else {
|
||||||
print "configure PP version\n\n";
|
print "configure PP version\n\n";
|
||||||
|
requires 'Math::BigInt' => 1.95; # old versions of BigInt were broken
|
||||||
}
|
}
|
||||||
|
|
||||||
clean_files qw{
|
clean_files qw{
|
||||||
@ -66,10 +70,6 @@ test_requires('Test::Requires');
|
|||||||
|
|
||||||
test_with_env( test_pp => PERL_DATA_MESSAGEPACK => 'pp' );
|
test_with_env( test_pp => PERL_DATA_MESSAGEPACK => 'pp' );
|
||||||
|
|
||||||
if($Module::Install::AUTHOR) {
|
|
||||||
postamble qq{test :: test_pp\n\n};
|
|
||||||
}
|
|
||||||
|
|
||||||
repository('http://github.com/msgpack/msgpack');
|
repository('http://github.com/msgpack/msgpack');
|
||||||
auto_include;
|
auto_include;
|
||||||
WriteAll;
|
WriteAll;
|
||||||
|
15
perl/README
15
perl/README
@ -2,6 +2,8 @@ NAME
|
|||||||
Data::MessagePack - MessagePack serialising/deserialising
|
Data::MessagePack - MessagePack serialising/deserialising
|
||||||
|
|
||||||
SYNOPSIS
|
SYNOPSIS
|
||||||
|
use Data::MessagePack;
|
||||||
|
|
||||||
my $packed = Data::MessagePack->pack($dat);
|
my $packed = Data::MessagePack->pack($dat);
|
||||||
my $unpacked = Data::MessagePack->unpack($dat);
|
my $unpacked = Data::MessagePack->unpack($dat);
|
||||||
|
|
||||||
@ -51,7 +53,8 @@ Configuration Variables
|
|||||||
|
|
||||||
SPEED
|
SPEED
|
||||||
This is a result of benchmark/serialize.pl and benchmark/deserialize.pl
|
This is a result of benchmark/serialize.pl and benchmark/deserialize.pl
|
||||||
on my SC440(Linux 2.6.32-23-server #37-Ubuntu SMP).
|
on my SC440(Linux 2.6.32-23-server #37-Ubuntu SMP). (You should
|
||||||
|
benchmark them with your data if the speed matters, of course.)
|
||||||
|
|
||||||
-- serialize
|
-- serialize
|
||||||
JSON::XS: 2.3
|
JSON::XS: 2.3
|
||||||
@ -79,6 +82,12 @@ SPEED
|
|||||||
json 179443/s 56% -- -16%
|
json 179443/s 56% -- -16%
|
||||||
mp 212910/s 85% 19% --
|
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
|
TODO
|
||||||
Error handling
|
Error handling
|
||||||
MessagePack cannot deal with complex scalars such as object
|
MessagePack cannot deal with complex scalars such as object
|
||||||
@ -117,3 +126,7 @@ SEE ALSO
|
|||||||
<http://msgpack.org/> is the official web site for the MessagePack
|
<http://msgpack.org/> is the official web site for the MessagePack
|
||||||
format.
|
format.
|
||||||
|
|
||||||
|
Data::MessagePack::Unpacker
|
||||||
|
|
||||||
|
AnyEvent::MPRPC
|
||||||
|
|
||||||
|
6
perl/benchmark/data.pl
Executable file
6
perl/benchmark/data.pl
Executable file
@ -0,0 +1,6 @@
|
|||||||
|
+{
|
||||||
|
"method" => "handleMessage",
|
||||||
|
"params" => [ "user1", "we were just talking", "foo\nbar\nbaz\nqux" ],
|
||||||
|
"id" => undef,
|
||||||
|
"array" => [ 1, 1024, 70000, -5, 1e5, 1e7, 1, 0, 3.14, sqrt(2), 1 .. 100 ],
|
||||||
|
};
|
@ -1,29 +1,25 @@
|
|||||||
use strict;
|
use strict;
|
||||||
use warnings;
|
use warnings;
|
||||||
use Data::MessagePack;
|
use Data::MessagePack;
|
||||||
use JSON::XS;
|
use JSON;
|
||||||
use Benchmark ':all';
|
|
||||||
use Storable;
|
use Storable;
|
||||||
|
use Benchmark ':all';
|
||||||
|
|
||||||
#$Data::MessagePack::PreferInteger = 1;
|
#$Data::MessagePack::PreferInteger = 1;
|
||||||
|
|
||||||
my $a = {
|
my $a = do 'benchmark/data.pl';
|
||||||
"method" => "handleMessage",
|
|
||||||
"params" => [ "user1", "we were just talking" ],
|
my $j = JSON::encode_json($a);
|
||||||
"id" => undef,
|
|
||||||
"array" => [ 1, 1024, 70000, -5, 1e5, 1e7, 1, 0, 3.14, sqrt(2) ],
|
|
||||||
};
|
|
||||||
my $j = JSON::XS::encode_json($a);
|
|
||||||
my $m = Data::MessagePack->pack($a);
|
my $m = Data::MessagePack->pack($a);
|
||||||
my $s = Storable::freeze($a);
|
my $s = Storable::freeze($a);
|
||||||
|
|
||||||
print "-- deserialize\n";
|
print "-- deserialize\n";
|
||||||
print "JSON::XS: $JSON::XS::VERSION\n";
|
print "$JSON::Backend: ", $JSON::Backend->VERSION, "\n";
|
||||||
print "Data::MessagePack: $Data::MessagePack::VERSION\n";
|
print "Data::MessagePack: $Data::MessagePack::VERSION\n";
|
||||||
print "Storable: $Storable::VERSION\n";
|
print "Storable: $Storable::VERSION\n";
|
||||||
cmpthese timethese(
|
cmpthese timethese(
|
||||||
-1 => {
|
-1 => {
|
||||||
json => sub { JSON::XS::decode_json($j) },
|
json => sub { JSON::decode_json($j) },
|
||||||
mp => sub { Data::MessagePack->unpack($m) },
|
mp => sub { Data::MessagePack->unpack($m) },
|
||||||
storable => sub { Storable::thaw($s) },
|
storable => sub { Storable::thaw($s) },
|
||||||
}
|
}
|
||||||
|
@ -1,24 +1,19 @@
|
|||||||
use strict;
|
use strict;
|
||||||
use warnings;
|
use warnings;
|
||||||
use Data::MessagePack;
|
use Data::MessagePack;
|
||||||
use JSON::XS;
|
use JSON;
|
||||||
use Storable;
|
use Storable;
|
||||||
use Benchmark ':all';
|
use Benchmark ':all';
|
||||||
|
|
||||||
my $a = {
|
my $a = do 'benchmark/data.pl';
|
||||||
"method" => "handleMessage",
|
|
||||||
"params" => [ "user1", "we were just talking" ],
|
|
||||||
"id" => undef,
|
|
||||||
"array" => [ 1, 1024, 70000, -5, 1e5, 1e7, 1, 0, 3.14, sqrt(2) ],
|
|
||||||
};
|
|
||||||
|
|
||||||
print "-- serialize\n";
|
print "-- serialize\n";
|
||||||
print "JSON::XS: $JSON::XS::VERSION\n";
|
print "$JSON::Backend: ", $JSON::Backend->VERSION, "\n";
|
||||||
print "Data::MessagePack: $Data::MessagePack::VERSION\n";
|
print "Data::MessagePack: $Data::MessagePack::VERSION\n";
|
||||||
print "Storable: $Storable::VERSION\n";
|
print "Storable: $Storable::VERSION\n";
|
||||||
cmpthese timethese(
|
cmpthese timethese(
|
||||||
-1 => {
|
-1 => {
|
||||||
json => sub { JSON::XS::encode_json($a) },
|
json => sub { JSON::encode_json($a) },
|
||||||
storable => sub { Storable::freeze($a) },
|
storable => sub { Storable::freeze($a) },
|
||||||
mp => sub { Data::MessagePack->pack($a) },
|
mp => sub { Data::MessagePack->pack($a) },
|
||||||
}
|
}
|
||||||
|
@ -23,7 +23,7 @@ sub false () {
|
|||||||
}
|
}
|
||||||
|
|
||||||
if ( !__PACKAGE__->can('pack') ) { # this idea comes from Text::Xslate
|
if ( !__PACKAGE__->can('pack') ) { # this idea comes from Text::Xslate
|
||||||
my $backend = $ENV{ PERL_DATA_MESSAGEPACK } || '';
|
my $backend = $ENV{PERL_DATA_MESSAGEPACK} || ($ENV{PERL_ONLY} ? 'pp' : '');
|
||||||
if ( $backend !~ /\b pp \b/xms ) {
|
if ( $backend !~ /\b pp \b/xms ) {
|
||||||
eval {
|
eval {
|
||||||
require XSLoader;
|
require XSLoader;
|
||||||
@ -45,6 +45,8 @@ Data::MessagePack - MessagePack serialising/deserialising
|
|||||||
|
|
||||||
=head1 SYNOPSIS
|
=head1 SYNOPSIS
|
||||||
|
|
||||||
|
use Data::MessagePack;
|
||||||
|
|
||||||
my $packed = Data::MessagePack->pack($dat);
|
my $packed = Data::MessagePack->pack($dat);
|
||||||
my $unpacked = Data::MessagePack->unpack($dat);
|
my $unpacked = Data::MessagePack->unpack($dat);
|
||||||
|
|
||||||
@ -55,7 +57,8 @@ This module converts Perl data structures to MessagePack and vice versa.
|
|||||||
=head1 ABOUT MESSAGEPACK FORMAT
|
=head1 ABOUT MESSAGEPACK FORMAT
|
||||||
|
|
||||||
MessagePack is a binary-based efficient object serialization format.
|
MessagePack is a binary-based efficient object serialization format.
|
||||||
It enables to exchange structured objects between many languages like JSON. But unlike JSON, it is very fast and small.
|
It enables to exchange structured objects between many languages like JSON.
|
||||||
|
But unlike JSON, it is very fast and small.
|
||||||
|
|
||||||
=head2 ADVANTAGES
|
=head2 ADVANTAGES
|
||||||
|
|
||||||
@ -113,7 +116,7 @@ Packs a string as an integer, when it looks like an integer.
|
|||||||
=head1 SPEED
|
=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).
|
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
|
-- serialize
|
||||||
JSON::XS: 2.3
|
JSON::XS: 2.3
|
||||||
@ -141,6 +144,14 @@ This is a result of benchmark/serialize.pl and benchmark/deserialize.pl on my SC
|
|||||||
json 179443/s 56% -- -16%
|
json 179443/s 56% -- -16%
|
||||||
mp 212910/s 85% 19% --
|
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
|
=head1 TODO
|
||||||
|
|
||||||
=over
|
=over
|
||||||
@ -187,4 +198,8 @@ it under the same terms as Perl itself.
|
|||||||
|
|
||||||
L<http://msgpack.org/> is the official web site for the MessagePack format.
|
L<http://msgpack.org/> is the official web site for the MessagePack format.
|
||||||
|
|
||||||
|
L<Data::MessagePack::Unpacker>
|
||||||
|
|
||||||
|
L<AnyEvent::MPRPC>
|
||||||
|
|
||||||
=cut
|
=cut
|
||||||
|
@ -12,17 +12,57 @@ use Carp ();
|
|||||||
package
|
package
|
||||||
Data::MessagePack;
|
Data::MessagePack;
|
||||||
|
|
||||||
use Scalar::Util qw( blessed );
|
|
||||||
use strict;
|
use strict;
|
||||||
use B ();
|
use B ();
|
||||||
|
|
||||||
BEGIN {
|
BEGIN {
|
||||||
|
my $unpack_int64_slow;
|
||||||
|
my $unpack_uint64_slow;
|
||||||
|
|
||||||
|
if(!eval { pack 'Q', 1 }) { # don't have quad types
|
||||||
|
$unpack_int64_slow = sub {
|
||||||
|
require Math::BigInt;
|
||||||
|
my $high = 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
|
# for pack and unpack compatibility
|
||||||
if ( $] < 5.010 ) {
|
if ( $] < 5.010 ) {
|
||||||
# require $Config{byteorder}; my $bo_is_le = ( $Config{byteorder} =~ /^1234/ );
|
# require $Config{byteorder}; my $bo_is_le = ( $Config{byteorder} =~ /^1234/ );
|
||||||
# which better?
|
# which better?
|
||||||
my $bo_is_le = unpack ( 'd', "\x00\x00\x00\x00\x00\x00\xf0\x3f") == 1; # 1.0LE
|
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!'?
|
# In reality, since 5.9.2 '>' is introduced. but 'n!' and 'N!'?
|
||||||
if($bo_is_le) {
|
if($bo_is_le) {
|
||||||
*pack_uint64 = sub {
|
*pack_uint64 = sub {
|
||||||
@ -47,20 +87,11 @@ BEGIN {
|
|||||||
return unpack( 'd', pack( 'N2', @v[1,0] ) );
|
return unpack( 'd', pack( 'N2', @v[1,0] ) );
|
||||||
};
|
};
|
||||||
|
|
||||||
*unpack_int16 = sub {
|
*unpack_int64 = $unpack_int64_slow ||_sub {
|
||||||
my $v = unpack 'n', substr( $_[0], $_[1], 2 );
|
|
||||||
return $v ? $v - 0x10000 : 0;
|
|
||||||
};
|
|
||||||
*unpack_int32 = sub {
|
|
||||||
no warnings; # avoid for warning about Hexadecimal number
|
|
||||||
my $v = unpack 'N', substr( $_[0], $_[1], 4 );
|
|
||||||
return $v ? $v - 0x100000000 : 0;
|
|
||||||
};
|
|
||||||
*unpack_int64 = sub {
|
|
||||||
my @v = unpack( 'V*', substr( $_[0], $_[1], 8 ) );
|
my @v = unpack( 'V*', substr( $_[0], $_[1], 8 ) );
|
||||||
return unpack( 'q', pack( 'N2', @v[1,0] ) );
|
return unpack( 'q', pack( 'N2', @v[1,0] ) );
|
||||||
};
|
};
|
||||||
*unpack_uint64 = sub {
|
*unpack_uint64 = $unpack_uint64_slow || sub {
|
||||||
my @v = unpack( 'V*', substr( $_[0], $_[1], 8 ) );
|
my @v = unpack( 'V*', substr( $_[0], $_[1], 8 ) );
|
||||||
return unpack( 'Q', pack( 'N2', @v[1,0] ) );
|
return unpack( 'Q', pack( 'N2', @v[1,0] ) );
|
||||||
};
|
};
|
||||||
@ -72,17 +103,8 @@ BEGIN {
|
|||||||
|
|
||||||
*unpack_float = sub { return unpack( 'f', substr( $_[0], $_[1], 4 ) ); };
|
*unpack_float = sub { return unpack( 'f', substr( $_[0], $_[1], 4 ) ); };
|
||||||
*unpack_double = sub { return unpack( 'd', substr( $_[0], $_[1], 8 ) ); };
|
*unpack_double = sub { return unpack( 'd', substr( $_[0], $_[1], 8 ) ); };
|
||||||
*unpack_int16 = sub {
|
*unpack_int64 = $unpack_int64_slow || sub { pack 'q', substr( $_[0], $_[1], 8 ); };
|
||||||
my $v = unpack 'n', substr( $_[0], $_[1], 2 );
|
*unpack_uint64 = $unpack_uint64_slow || sub { pack 'Q', substr( $_[0], $_[1], 8 ); };
|
||||||
return $v ? $v - 0x10000 : 0;
|
|
||||||
};
|
|
||||||
*unpack_int32 = sub {
|
|
||||||
no warnings; # avoid for warning about Hexadecimal number
|
|
||||||
my $v = unpack 'N', substr( $_[0], $_[1], 4 );
|
|
||||||
return $v ? $v - 0x100000000 : 0;
|
|
||||||
};
|
|
||||||
*unpack_int64 = sub { pack 'q', substr( $_[0], $_[1], 8 ); };
|
|
||||||
*unpack_uint64 = sub { pack 'Q', substr( $_[0], $_[1], 8 ); };
|
|
||||||
}
|
}
|
||||||
}
|
}
|
||||||
else {
|
else {
|
||||||
@ -94,11 +116,15 @@ BEGIN {
|
|||||||
*unpack_double = sub { return unpack( 'd>', substr( $_[0], $_[1], 8 ) ); };
|
*unpack_double = sub { return unpack( 'd>', substr( $_[0], $_[1], 8 ) ); };
|
||||||
*unpack_int16 = sub { return unpack( 'n!', substr( $_[0], $_[1], 2 ) ); };
|
*unpack_int16 = sub { return unpack( 'n!', substr( $_[0], $_[1], 2 ) ); };
|
||||||
*unpack_int32 = sub { return unpack( 'N!', substr( $_[0], $_[1], 4 ) ); };
|
*unpack_int32 = sub { return unpack( 'N!', substr( $_[0], $_[1], 4 ) ); };
|
||||||
*unpack_int64 = sub { return unpack( 'q>', substr( $_[0], $_[1], 8 ) ); };
|
|
||||||
*unpack_uint64 = sub { return unpack( 'Q>', substr( $_[0], $_[1], 8 ) ); };
|
*unpack_int64 = $unpack_int64_slow || sub { return unpack( 'q>', substr( $_[0], $_[1], 8 ) ); };
|
||||||
|
*unpack_uint64 = $unpack_uint64_slow || sub { return unpack( 'Q>', substr( $_[0], $_[1], 8 ) ); };
|
||||||
}
|
}
|
||||||
}
|
}
|
||||||
|
|
||||||
|
sub _unexpected {
|
||||||
|
Carp::confess("Unexpected " . sprintf(shift, @_) . " found");
|
||||||
|
}
|
||||||
|
|
||||||
#
|
#
|
||||||
# PACK
|
# PACK
|
||||||
@ -107,11 +133,11 @@ BEGIN {
|
|||||||
{
|
{
|
||||||
no warnings 'recursion';
|
no warnings 'recursion';
|
||||||
|
|
||||||
my $max_depth;
|
our $_max_depth;
|
||||||
|
|
||||||
sub pack :method {
|
sub pack :method {
|
||||||
Carp::croak('Usage: Data::MessagePack->pack($dat [,$max_depth])') if @_ < 2;
|
Carp::croak('Usage: Data::MessagePack->pack($dat [,$max_depth])') if @_ < 2;
|
||||||
$max_depth = defined $_[2] ? $_[2] : 512; # init
|
$_max_depth = defined $_[2] ? $_[2] : 512; # init
|
||||||
return _pack( $_[1] );
|
return _pack( $_[1] );
|
||||||
}
|
}
|
||||||
|
|
||||||
@ -119,6 +145,12 @@ sub pack :method {
|
|||||||
sub _pack {
|
sub _pack {
|
||||||
my ( $value ) = @_;
|
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 );
|
return CORE::pack( 'C', 0xc0 ) if ( not defined $value );
|
||||||
|
|
||||||
if ( ref($value) eq 'ARRAY' ) {
|
if ( ref($value) eq 'ARRAY' ) {
|
||||||
@ -127,11 +159,8 @@ sub _pack {
|
|||||||
$num < 16 ? CORE::pack( 'C', 0x90 + $num )
|
$num < 16 ? CORE::pack( 'C', 0x90 + $num )
|
||||||
: $num < 2 ** 16 - 1 ? CORE::pack( 'Cn', 0xdc, $num )
|
: $num < 2 ** 16 - 1 ? CORE::pack( 'Cn', 0xdc, $num )
|
||||||
: $num < 2 ** 32 - 1 ? CORE::pack( 'CN', 0xdd, $num )
|
: $num < 2 ** 32 - 1 ? CORE::pack( 'CN', 0xdd, $num )
|
||||||
: die "" # don't arrivie here
|
: _unexpected("number %d", $num)
|
||||||
;
|
;
|
||||||
if ( --$max_depth <= 0 ) {
|
|
||||||
Carp::croak("perl structure exceeds maximum nesting level (max_depth set too low?)");
|
|
||||||
}
|
|
||||||
return join( '', $header, map { _pack( $_ ) } @$value );
|
return join( '', $header, map { _pack( $_ ) } @$value );
|
||||||
}
|
}
|
||||||
|
|
||||||
@ -141,11 +170,8 @@ sub _pack {
|
|||||||
$num < 16 ? CORE::pack( 'C', 0x80 + $num )
|
$num < 16 ? CORE::pack( 'C', 0x80 + $num )
|
||||||
: $num < 2 ** 16 - 1 ? CORE::pack( 'Cn', 0xde, $num )
|
: $num < 2 ** 16 - 1 ? CORE::pack( 'Cn', 0xde, $num )
|
||||||
: $num < 2 ** 32 - 1 ? CORE::pack( 'CN', 0xdf, $num )
|
: $num < 2 ** 32 - 1 ? CORE::pack( 'CN', 0xdf, $num )
|
||||||
: die "" # don't arrivie here
|
: _unexpected("number %d", $num)
|
||||||
;
|
;
|
||||||
if ( --$max_depth <= 0 ) {
|
|
||||||
Carp::croak("perl structure exceeds maximum nesting level (max_depth set too low?)");
|
|
||||||
}
|
|
||||||
return join( '', $header, map { _pack( $_ ) } %$value );
|
return join( '', $header, map { _pack( $_ ) } %$value );
|
||||||
}
|
}
|
||||||
|
|
||||||
@ -197,7 +223,7 @@ sub _pack {
|
|||||||
$num < 32 ? CORE::pack( 'C', 0xa0 + $num )
|
$num < 32 ? CORE::pack( 'C', 0xa0 + $num )
|
||||||
: $num < 2 ** 16 - 1 ? CORE::pack( 'Cn', 0xda, $num )
|
: $num < 2 ** 16 - 1 ? CORE::pack( 'Cn', 0xda, $num )
|
||||||
: $num < 2 ** 32 - 1 ? CORE::pack( 'CN', 0xdb, $num )
|
: $num < 2 ** 32 - 1 ? CORE::pack( 'CN', 0xdb, $num )
|
||||||
: die "" # don't arrivie here
|
: _unexpected_number($num)
|
||||||
;
|
;
|
||||||
|
|
||||||
return $header . $value;
|
return $header . $value;
|
||||||
@ -207,7 +233,7 @@ sub _pack {
|
|||||||
return pack_double( $value );
|
return pack_double( $value );
|
||||||
}
|
}
|
||||||
else {
|
else {
|
||||||
die "???";
|
_unexpected("data type %s", $b_obj);
|
||||||
}
|
}
|
||||||
|
|
||||||
}
|
}
|
||||||
@ -284,11 +310,11 @@ sub _unpack {
|
|||||||
}
|
}
|
||||||
elsif ( $byte == 0xcd ) { # uint16
|
elsif ( $byte == 0xcd ) { # uint16
|
||||||
$p += 2;
|
$p += 2;
|
||||||
return CORE::unpack 'n', substr( $value, $p - 2, 2 );
|
return unpack_uint16( $value, $p - 2 );
|
||||||
}
|
}
|
||||||
elsif ( $byte == 0xce ) { # unit32
|
elsif ( $byte == 0xce ) { # unit32
|
||||||
$p += 4;
|
$p += 4;
|
||||||
return CORE::unpack 'N', substr( $value, $p - 4, 4 );
|
return unpack_uint32( $value, $p - 4 );
|
||||||
}
|
}
|
||||||
elsif ( $byte == 0xcf ) { # unit64
|
elsif ( $byte == 0xcf ) { # unit64
|
||||||
$p += 8;
|
$p += 8;
|
||||||
@ -351,7 +377,7 @@ sub _unpack {
|
|||||||
}
|
}
|
||||||
|
|
||||||
else {
|
else {
|
||||||
die "???";
|
_unexpected("byte 0x%02x", $byte);
|
||||||
}
|
}
|
||||||
|
|
||||||
}
|
}
|
||||||
@ -470,7 +496,7 @@ sub _count {
|
|||||||
: $byte == 0xcd ? 2
|
: $byte == 0xcd ? 2
|
||||||
: $byte == 0xce ? 4
|
: $byte == 0xce ? 4
|
||||||
: $byte == 0xcf ? 8
|
: $byte == 0xcf ? 8
|
||||||
: die;
|
: _unexpected("byte 0x%02x", $byte);
|
||||||
return 1;
|
return 1;
|
||||||
}
|
}
|
||||||
|
|
||||||
@ -479,7 +505,7 @@ sub _count {
|
|||||||
: $byte == 0xd1 ? 2
|
: $byte == 0xd1 ? 2
|
||||||
: $byte == 0xd2 ? 4
|
: $byte == 0xd2 ? 4
|
||||||
: $byte == 0xd3 ? 8
|
: $byte == 0xd3 ? 8
|
||||||
: die;
|
: _unexpected("byte 0x%02x", $byte);
|
||||||
return 1;
|
return 1;
|
||||||
}
|
}
|
||||||
|
|
||||||
@ -510,7 +536,7 @@ sub _count {
|
|||||||
}
|
}
|
||||||
|
|
||||||
else {
|
else {
|
||||||
die "???";
|
_unexpected("byte 0x%02x", $byte);
|
||||||
}
|
}
|
||||||
|
|
||||||
return 0;
|
return 0;
|
||||||
|
@ -3,4 +3,5 @@ use warnings;
|
|||||||
use Test::More tests => 1;
|
use Test::More tests => 1;
|
||||||
|
|
||||||
use_ok 'Data::MessagePack';
|
use_ok 'Data::MessagePack';
|
||||||
diag ( $INC{'Data/MessagePack/PP.pm'} ? 'PP' : 'XS' );
|
diag ( "Testing Data::MessagePack/$Data::MessagePack::VERSION (",
|
||||||
|
$INC{'Data/MessagePack/PP.pm'} ? 'PP' : 'XS', ")" );
|
||||||
|
@ -9,6 +9,7 @@ my @input = (
|
|||||||
[[],[]],
|
[[],[]],
|
||||||
[{"a" => 97},{"a" => 97}],
|
[{"a" => 97},{"a" => 97}],
|
||||||
[{"a" => 97},{"a" => 97},{"a" => 97}],
|
[{"a" => 97},{"a" => 97},{"a" => 97}],
|
||||||
|
[ map { +{ "foo $_" => "bar $_" } } 'aa' .. 'zz' ],
|
||||||
);
|
);
|
||||||
|
|
||||||
plan tests => @input * 2;
|
plan tests => @input * 2;
|
@ -2,8 +2,12 @@
|
|||||||
use strict;
|
use strict;
|
||||||
use Test::Requires { 'Test::LeakTrace' => 0.13 };
|
use Test::Requires { 'Test::LeakTrace' => 0.13 };
|
||||||
use Test::More;
|
use Test::More;
|
||||||
|
|
||||||
use Data::MessagePack;
|
use Data::MessagePack;
|
||||||
|
BEGIN {
|
||||||
|
if($INC{'Data/MessagePack/PP.pm'}) {
|
||||||
|
plan skip_all => 'disabled in PP';
|
||||||
|
}
|
||||||
|
}
|
||||||
|
|
||||||
my $simple_data = "xyz";
|
my $simple_data = "xyz";
|
||||||
my $complex_data = {
|
my $complex_data = {
|
||||||
|
@ -5,14 +5,39 @@ no warnings; # i need this, i need this.
|
|||||||
'92 90 91 91 c0', [[], [[undef]]],
|
'92 90 91 91 c0', [[], [[undef]]],
|
||||||
'93 c0 c2 c3', [undef, false, true],
|
'93 c0 c2 c3', [undef, false, true],
|
||||||
'ce 80 00 00 00', 2147483648,
|
'ce 80 00 00 00', 2147483648,
|
||||||
'99 cc 00 cc 80 cc ff cd 00 00 cd 80 00 cd ff ff ce 00 00 00 00 ce 80 00 00 00 ce ff ff ff ff', [0, 128, 255, 0, 32768, 65535, 0, 2147483648, 4294967295],
|
'99 cc 00 cc 80 cc ff cd 00 00 cd 80 00 cd ff ff ce 00 00 00 00 ce 80 00 00 00 ce ff ff ff ff',
|
||||||
|
[0, 128, 255, 0, 32768, 65535, 0, 2147483648, 4294967295],
|
||||||
'92 93 00 40 7f 93 e0 f0 ff', [[0, 64, 127], [-32, -16, -1]],
|
'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 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',
|
||||||
'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"],
|
[[], [undef], [false, true], [], [undef], [false, true]],
|
||||||
'99 d0 00 d0 80 d0 ff d1 00 00 d1 80 00 d1 ff ff d2 00 00 00 00 d2 80 00 00 00 d2 ff ff ff ff', [0, -128, -1, 0, -32768, -1, 0, -2147483648, -1],
|
'96 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,{}}},
|
'82 c2 81 c0 c0 c3 81 c0 80', {false,{undef,undef}, true,{undef,{}}},
|
||||||
'96 de 00 00 de 00 01 c0 c2 de 00 02 c0 c2 c3 c2 df 00 00 00 00 df 00 00 00 01 c0 c2 df 00 00 00 02 c0 c2 c3 c2', [{}, {undef,false}, {true,false, undef,false}, {}, {undef,false}, {true,false, undef,false}],
|
'96 de 00 00 de 00 01 c0 c2 de 00 02 c0 c2 c3 c2 df 00 00 00 00 df 00 00 00 01 c0 c2 df 00 00 00 02 c0 c2 c3 c2',
|
||||||
|
[{}, {undef,false}, {true,false, undef,false}, {}, {undef,false}, {true,false, undef,false}],
|
||||||
'ce 00 ff ff ff' => ''.0xFFFFFF,
|
'ce 00 ff ff ff' => ''.0xFFFFFF,
|
||||||
'aa 34 32 39 34 39 36 37 32 39 35' => ''.0xFFFFFFFF,
|
'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,
|
'ab 36 38 37 31 39 34 37 36 37 33 35' => ''.0xFFFFFFFFF,
|
||||||
|
|
||||||
|
'd2 80 00 00 01' => '-2147483647', # int32_t
|
||||||
|
'ce 80 00 00 01' => '2147483649', # uint32_t
|
||||||
|
|
||||||
|
'd2 ff ff ff ff' => '-1', # int32_t
|
||||||
|
'ce ff ff ff ff' => '4294967295', # uint32_t
|
||||||
|
|
||||||
|
'd3 00 00 00 00 80 00 00 01' => '2147483649', # int64_t
|
||||||
|
'cf 00 00 00 00 80 00 00 01' => '2147483649', # uint64_t
|
||||||
|
|
||||||
|
'd3 ff 00 ff ff ff ff ff ff' => '-71776119061217281', # int64_t
|
||||||
|
'cf ff 00 ff ff ff ff ff ff' => '18374967954648334335', # uint64_t
|
||||||
|
|
||||||
|
'd3 ff ff ff ff ff ff ff ff' => '-1', # int64_t
|
||||||
|
'cf ff ff ff ff ff ff ff ff' => '18446744073709551615', # uint64_t
|
||||||
|
|
||||||
|
# int64_t
|
||||||
|
'd3 00 00 00 10 00 00 00 00' => '68719476736',
|
||||||
|
'd3 00 00 00 10 00 00 00 01' => '68719476737',
|
||||||
|
'd3 10 00 00 00 00 00 00 00' => '1152921504606846976',
|
||||||
)
|
)
|
||||||
|
@ -1,5 +1,6 @@
|
|||||||
#define NEED_newRV_noinc
|
#define NEED_newRV_noinc
|
||||||
#define NEED_sv_2pv_flags
|
#define NEED_sv_2pv_flags
|
||||||
|
#define NEED_my_snprintf
|
||||||
#include "xshelper.h"
|
#include "xshelper.h"
|
||||||
|
|
||||||
#define MY_CXT_KEY "Data::MessagePack::_unpack_guts" XS_VERSION
|
#define MY_CXT_KEY "Data::MessagePack::_unpack_guts" XS_VERSION
|
||||||
@ -102,13 +103,6 @@ STATIC_INLINE int template_callback_UV(unpack_user* u PERL_UNUSED_DECL, UV const
|
|||||||
return 0;
|
return 0;
|
||||||
}
|
}
|
||||||
|
|
||||||
STATIC_INLINE int template_callback_uint64(unpack_user* u PERL_UNUSED_DECL, uint64_t const d, SV** o)
|
|
||||||
{
|
|
||||||
dTHX;
|
|
||||||
*o = newSVnv((NV)d);
|
|
||||||
return 0;
|
|
||||||
}
|
|
||||||
|
|
||||||
STATIC_INLINE int template_callback_IV(unpack_user* u PERL_UNUSED_DECL, IV const d, SV** o)
|
STATIC_INLINE int template_callback_IV(unpack_user* u PERL_UNUSED_DECL, IV const d, SV** o)
|
||||||
{
|
{
|
||||||
dTHX;
|
dTHX;
|
||||||
@ -116,10 +110,21 @@ STATIC_INLINE int template_callback_IV(unpack_user* u PERL_UNUSED_DECL, IV const
|
|||||||
return 0;
|
return 0;
|
||||||
}
|
}
|
||||||
|
|
||||||
STATIC_INLINE int template_callback_int64(unpack_user* u PERL_UNUSED_DECL, int64_t const d, SV** o)
|
static int template_callback_uint64(unpack_user* u PERL_UNUSED_DECL, uint64_t const d, SV** o)
|
||||||
{
|
{
|
||||||
dTHX;
|
dTHX;
|
||||||
*o = newSVnv((NV)d);
|
char tbuf[64];
|
||||||
|
STRLEN const len = my_snprintf(tbuf, sizeof(tbuf), "%llu", d);
|
||||||
|
*o = newSVpvn(tbuf, len);
|
||||||
|
return 0;
|
||||||
|
}
|
||||||
|
|
||||||
|
static int template_callback_int64(unpack_user* u PERL_UNUSED_DECL, int64_t const d, SV** o)
|
||||||
|
{
|
||||||
|
dTHX;
|
||||||
|
char tbuf[64];
|
||||||
|
STRLEN const len = my_snprintf(tbuf, sizeof(tbuf), "%lld", d);
|
||||||
|
*o = newSVpvn(tbuf, len);
|
||||||
return 0;
|
return 0;
|
||||||
}
|
}
|
||||||
|
|
||||||
|
Loading…
x
Reference in New Issue
Block a user