mirror of
https://github.com/msgpack/msgpack-c.git
synced 2025-03-21 06:11:18 +01:00
Merge branch 'master' of git://github.com/makamaka/msgpack
Conflicts: perl/Changes
This commit is contained in:
tokuhirom
commit
e3e771708e
1
perl/.gitignore
vendored
1
perl/.gitignore
vendored
@ -11,3 +11,4 @@ pm_to_blib
|
||||
unpack.o
|
||||
MANIFEST
|
||||
ppport.h
|
||||
.testenv/
|
||||
|
||||
@ -1,3 +1,11 @@
|
||||
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
|
||||
|
||||
@ -5,15 +5,38 @@ name 'Data-MessagePack';
|
||||
all_from 'lib/Data/MessagePack.pm';
|
||||
readme_from('lib/Data/MessagePack.pm');
|
||||
|
||||
perl_version '5.008005';
|
||||
perl_version '5.008000';
|
||||
license 'perl';
|
||||
can_cc or die "This module requires a C compiler";
|
||||
|
||||
tests 't/*.t';
|
||||
recursive_author_tests('xt');
|
||||
use_ppport 3.19;
|
||||
|
||||
requires_c99(); # msgpack C library requires C99.
|
||||
|
||||
if ( $] >= 5.008005 and want_xs() ) {
|
||||
can_cc or die "This module requires a C compiler. Please retry with --pp";
|
||||
|
||||
my $has_c99 = c99_available(); # msgpack C library requires C99.
|
||||
|
||||
if ( $has_c99 ) {
|
||||
use_ppport 3.19;
|
||||
cc_src_paths('xs-src');
|
||||
if ($ENV{DEBUG}) {
|
||||
cc_append_to_ccflags '-g';
|
||||
}
|
||||
}
|
||||
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";
|
||||
}
|
||||
|
||||
clean_files qw{
|
||||
*.stackdump
|
||||
@ -23,10 +46,6 @@ clean_files qw{
|
||||
cover_db
|
||||
};
|
||||
|
||||
if ($ENV{DEBUG}) {
|
||||
cc_append_to_ccflags '-g';
|
||||
}
|
||||
|
||||
# copy modules
|
||||
if ($Module::Install::AUTHOR && -d File::Spec->catfile('..', 'msgpack')) {
|
||||
mkdir 'msgpack' unless -d 'msgpack';
|
||||
@ -39,7 +58,50 @@ if ($Module::Install::AUTHOR && -d File::Spec->catfile('..', 'msgpack')) {
|
||||
requires 'Test::More' => 0.94; # done_testing
|
||||
test_requires('Test::Requires');
|
||||
|
||||
test_with_env( test_pp => PERL_DATA_MESSAGEPACK => 'pp' );
|
||||
|
||||
if($Module::Install::AUTHOR) {
|
||||
postamble qq{test :: test_pp\n\n};
|
||||
}
|
||||
|
||||
auto_set_repository();
|
||||
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;
|
||||
}
|
||||
|
||||
@ -1,7 +1,6 @@
|
||||
package Data::MessagePack;
|
||||
use strict;
|
||||
use warnings;
|
||||
use XSLoader;
|
||||
use 5.008001;
|
||||
|
||||
our $VERSION = '0.16';
|
||||
@ -12,7 +11,19 @@ our $false = do { bless \(my $dummy = 0), "Data::MessagePack::Boolean" };
|
||||
sub true () { $true }
|
||||
sub false () { $false }
|
||||
|
||||
XSLoader::load(__PACKAGE__, $VERSION);
|
||||
if ( !__PACKAGE__->can('pack') ) { # this idea comes from Text::Xslate
|
||||
my $backend = $ENV{ PERL_DATA_MESSAGEPACK } || '';
|
||||
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';
|
||||
}
|
||||
}
|
||||
|
||||
1;
|
||||
__END__
|
||||
|
||||
546
perl/lib/Data/MessagePack/PP.pm
Normal file
546
perl/lib/Data/MessagePack/PP.pm
Normal file
@ -0,0 +1,546 @@
|
||||
package Data::MessagePack::PP;
|
||||
|
||||
use 5.008000;
|
||||
use strict;
|
||||
use Carp ();
|
||||
|
||||
our $VERSION = '0.15';
|
||||
|
||||
# See also
|
||||
# http://redmine.msgpack.org/projects/msgpack/wiki/FormatSpec
|
||||
# http://cpansearch.perl.org/src/YAPPO/Data-Model-0.00006/lib/Data/Model/Driver/Memcached.pm
|
||||
# http://frox25.no-ip.org/~mtve/wiki/MessagePack.html : reference to using CORE::pack, CORE::unpack
|
||||
|
||||
|
||||
package
|
||||
Data::MessagePack;
|
||||
|
||||
use Scalar::Util qw( blessed );
|
||||
use strict;
|
||||
use B ();
|
||||
|
||||
BEGIN {
|
||||
# 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
|
||||
# In really, since 5.9.2 '>' is introduced. but 'n!' and 'N!'?
|
||||
*pack_uint64 = $bo_is_le ? sub {
|
||||
my @v = unpack( 'V2', pack( 'Q', $_[0] ) );
|
||||
return pack 'CN2', 0xcf, @v[1,0];
|
||||
} : sub { pack 'CQ', 0xcf, $_[0]; };
|
||||
*pack_int64 = $bo_is_le ? sub {
|
||||
my @v = unpack( 'V2', pack( 'q', $_[0] ) );
|
||||
return pack 'CN2', 0xd3, @v[1,0];
|
||||
} : sub { pack 'Cq', 0xd3, $_[0]; };
|
||||
*pack_double = $bo_is_le ? sub {
|
||||
my @v = unpack( 'V2', pack( 'd', $_[0] ) );
|
||||
return pack 'CN2', 0xcb, @v[1,0];
|
||||
} : sub { pack 'Cd', 0xcb, $_[0]; };
|
||||
*unpack_float = $bo_is_le ? sub {
|
||||
my @v = unpack( 'v2', substr( $_[0], $_[1], 4 ) );
|
||||
return unpack( 'f', pack( 'n2', @v[1,0] ) );
|
||||
} : sub { return unpack( 'f', substr( $_[0], $_[1], 4 ) ); };
|
||||
*unpack_double = $bo_is_le ? sub {
|
||||
my @v = unpack( 'V2', substr( $_[0], $_[1], 8 ) );
|
||||
return unpack( 'd', pack( 'N2', @v[1,0] ) );
|
||||
} : sub { return unpack( 'd', substr( $_[0], $_[1], 8 ) ); };
|
||||
*unpack_int16 = sub {
|
||||
my $v = unpack 'n', substr( $_[0], $_[1], 2 );
|
||||
return $v ? $v - 0x10000 : 0;
|
||||
};
|
||||
*unpack_int32 = sub {
|
||||
no warnings; # avoid for warning about Hexadecimal number
|
||||
my $v = unpack 'N', substr( $_[0], $_[1], 4 );
|
||||
return $v ? $v - 0x100000000 : 0;
|
||||
};
|
||||
*unpack_int64 = $bo_is_le ? sub {
|
||||
my @v = unpack( 'V*', substr( $_[0], $_[1], 8 ) );
|
||||
return unpack( 'q', pack( 'N2', @v[1,0] ) );
|
||||
} : sub { pack 'q', substr( $_[0], $_[1], 8 ); };
|
||||
*unpack_uint64 = $bo_is_le ? sub {
|
||||
my @v = unpack( 'V*', substr( $_[0], $_[1], 8 ) );
|
||||
return unpack( 'Q', pack( 'N2', @v[1,0] ) );
|
||||
} : sub { pack 'Q', substr( $_[0], $_[1], 8 ); };
|
||||
}
|
||||
else {
|
||||
*pack_uint64 = sub { return pack 'CQ>', 0xcf, $_[0]; };
|
||||
*pack_int64 = sub { return pack 'Cq>', 0xd3, $_[0]; };
|
||||
*pack_double = sub { return pack 'Cd>', 0xcb, $_[0]; };
|
||||
*unpack_float = sub { return unpack( 'f>', substr( $_[0], $_[1], 4 ) ); };
|
||||
*unpack_double = sub { return unpack( 'd>', substr( $_[0], $_[1], 8 ) ); };
|
||||
*unpack_int16 = sub { return unpack( 'n!', substr( $_[0], $_[1], 2 ) ); };
|
||||
*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 ) ); };
|
||||
}
|
||||
# for 5.8 etc.
|
||||
unless ( defined &utf8::is_utf8 ) {
|
||||
require Encode;
|
||||
*utf8::is_utf8 = *Encode::is_utf8;
|
||||
}
|
||||
}
|
||||
|
||||
|
||||
#
|
||||
# PACK
|
||||
#
|
||||
|
||||
{
|
||||
no warnings 'recursion';
|
||||
|
||||
my $max_depth;
|
||||
|
||||
sub pack {
|
||||
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 ) = @_;
|
||||
|
||||
return CORE::pack( 'C', 0xc0 ) if ( not defined $value );
|
||||
|
||||
my $b_obj = B::svref_2object( ref $value ? $value : \$value );
|
||||
|
||||
if ( $b_obj->isa('B::AV') ) {
|
||||
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 )
|
||||
: die "" # don't arrivie here
|
||||
;
|
||||
if ( --$max_depth <= 0 ) {
|
||||
Carp::croak("perl structure exceeds maximum nesting level (max_depth set too low?)");
|
||||
}
|
||||
return join( '', $header, map { _pack( $_ ) } @$value );
|
||||
}
|
||||
|
||||
elsif ( $b_obj->isa('B::HV') ) {
|
||||
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 )
|
||||
: die "" # don't arrivie here
|
||||
;
|
||||
if ( --$max_depth <= 0 ) {
|
||||
Carp::croak("perl structure exceeds maximum nesting level (max_depth set too low?)");
|
||||
}
|
||||
return join( '', $header, map { _pack( $_ ) } %$value );
|
||||
}
|
||||
|
||||
elsif ( blessed( $value ) and blessed( $value ) eq 'Data::MessagePack::Boolean' ) {
|
||||
return CORE::pack( 'C', $$value ? 0xc3 : 0xc2 );
|
||||
}
|
||||
|
||||
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?
|
||||
my $value2 = 0 + $value;
|
||||
if ( $value > 0xFFFFFFFF or $value < '-'.0x80000000 or # <- needless but for XS compat
|
||||
0 + $value != B::svref_2object( \$value2 )->int_value
|
||||
) {
|
||||
local $Data::MessagePack::PreferInteger; # avoid for PV => NV
|
||||
return _pack( "$value" );
|
||||
}
|
||||
return _pack( $value + 0 );
|
||||
}
|
||||
}
|
||||
|
||||
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 )
|
||||
: die "" # don't arrivie here
|
||||
;
|
||||
|
||||
return $header . $value;
|
||||
|
||||
}
|
||||
|
||||
elsif ( $flags & ( B::SVf_NOK | B::SVp_NOK ) ) { # double only
|
||||
return pack_double( $value );
|
||||
}
|
||||
|
||||
else {
|
||||
die "???";
|
||||
}
|
||||
|
||||
}
|
||||
|
||||
} # PACK
|
||||
|
||||
|
||||
#
|
||||
# UNPACK
|
||||
#
|
||||
|
||||
{
|
||||
|
||||
my $p; # position variables for speed.
|
||||
|
||||
sub unpack {
|
||||
$p = 0; # init
|
||||
_unpack( $_[1] );
|
||||
}
|
||||
|
||||
|
||||
sub _unpack {
|
||||
my ( $value ) = @_;
|
||||
my $byte = CORE::unpack( 'C', substr( $value, $p++, 1 ) ); # get header
|
||||
|
||||
die "invalid data" unless defined $byte;
|
||||
|
||||
if ( ( $byte >= 0x90 and $byte <= 0x9f ) or $byte == 0xdc or $byte == 0xdd ) {
|
||||
my $num;
|
||||
if ( $byte == 0xdc ) { # array 16
|
||||
$num = CORE::unpack 'n', substr( $value, $p, 2 );
|
||||
$p += 2;
|
||||
}
|
||||
elsif ( $byte == 0xdd ) { # array 32
|
||||
$num = CORE::unpack 'N', substr( $value, $p, 4 );
|
||||
$p += 4;
|
||||
}
|
||||
else { # fix array
|
||||
$num = $byte & ~0x90;
|
||||
}
|
||||
my @array;
|
||||
push @array, _unpack( $value ) while $num-- > 0;
|
||||
return \@array;
|
||||
}
|
||||
|
||||
elsif ( ( $byte >= 0x80 and $byte <= 0x8f ) or $byte == 0xde or $byte == 0xdf ) {
|
||||
my $num;
|
||||
if ( $byte == 0xde ) { # map 16
|
||||
$num = CORE::unpack 'n', substr( $value, $p, 2 );
|
||||
$p += 2;
|
||||
}
|
||||
elsif ( $byte == 0xdf ) { # map 32
|
||||
$num = CORE::unpack 'N', substr( $value, $p, 4 );
|
||||
$p += 4;
|
||||
}
|
||||
else { # fix map
|
||||
$num = $byte & ~0x80;
|
||||
}
|
||||
my %map;
|
||||
for ( 0 .. $num - 1 ) {
|
||||
no warnings; # for undef key case
|
||||
my $key = _unpack( $value );
|
||||
my $val = _unpack( $value );
|
||||
$map{ $key } = $val;
|
||||
}
|
||||
return \%map;
|
||||
}
|
||||
|
||||
elsif ( $byte >= 0x00 and $byte <= 0x7f ) { # positive fixnum
|
||||
return $byte;
|
||||
}
|
||||
elsif ( $byte == 0xcc ) { # uint8
|
||||
CORE::unpack( 'C', substr( $value, $p++, 1 ) );
|
||||
}
|
||||
elsif ( $byte == 0xcd ) { # uint16
|
||||
$p += 2;
|
||||
return CORE::unpack 'n', substr( $value, $p - 2, 2 );
|
||||
}
|
||||
elsif ( $byte == 0xce ) { # unit32
|
||||
$p += 4;
|
||||
return CORE::unpack 'N', substr( $value, $p - 4, 4 );
|
||||
}
|
||||
elsif ( $byte == 0xcf ) { # unit64
|
||||
$p += 8;
|
||||
return unpack_uint64( $value, $p - 8 );
|
||||
}
|
||||
elsif ( $byte == 0xd3 ) { # int64
|
||||
$p += 8;
|
||||
return unpack_int64( $value, $p - 8 );
|
||||
}
|
||||
elsif ( $byte == 0xd2 ) { # int32
|
||||
$p += 4;
|
||||
return unpack_int32( $value, $p - 4 );
|
||||
}
|
||||
elsif ( $byte == 0xd1 ) { # int16
|
||||
$p += 2;
|
||||
return unpack_int16( $value, $p - 2 );
|
||||
}
|
||||
elsif ( $byte == 0xd0 ) { # int8
|
||||
return CORE::unpack 'c', substr( $value, $p++, 1 ); # c / C
|
||||
}
|
||||
elsif ( $byte >= 0xe0 and $byte <= 0xff ) { # negative fixnum
|
||||
return $byte - 256;
|
||||
}
|
||||
|
||||
elsif ( ( $byte >= 0xa0 and $byte <= 0xbf ) or $byte == 0xda or $byte == 0xdb ) { # raw
|
||||
my $num;
|
||||
if ( $byte == 0xda ) {
|
||||
$num = CORE::unpack 'n', substr( $value, $p, 2 );
|
||||
$p += 2 + $num;
|
||||
}
|
||||
elsif ( $byte == 0xdb ) {
|
||||
$num = CORE::unpack 'N', substr( $value, $p, 4 );
|
||||
$p += 4 + $num;
|
||||
}
|
||||
else { # fix raw
|
||||
$num = $byte & ~0xa0;
|
||||
$p += $num;
|
||||
}
|
||||
return substr( $value, $p - $num, $num );
|
||||
}
|
||||
|
||||
elsif ( $byte == 0xc0 ) { # nil
|
||||
return undef;
|
||||
}
|
||||
elsif ( $byte == 0xc2 ) { # boolean
|
||||
return false;
|
||||
}
|
||||
elsif ( $byte == 0xc3 ) { # boolean
|
||||
return true;
|
||||
}
|
||||
|
||||
elsif ( $byte == 0xcb ) { # double
|
||||
$p += 8;
|
||||
return unpack_double( $value, $p - 8 );
|
||||
}
|
||||
|
||||
elsif ( $byte == 0xca ) { # float
|
||||
$p += 4;
|
||||
return unpack_float( $value, $p - 4 );
|
||||
}
|
||||
|
||||
else {
|
||||
die "???";
|
||||
}
|
||||
|
||||
}
|
||||
|
||||
|
||||
} # UNPACK
|
||||
|
||||
|
||||
#
|
||||
# Data::MessagePack::Unpacker
|
||||
#
|
||||
|
||||
package
|
||||
Data::MessagePack::Unpacker;
|
||||
|
||||
use strict;
|
||||
|
||||
sub new {
|
||||
bless { stack => [] }, shift;
|
||||
}
|
||||
|
||||
|
||||
sub execute_limit {
|
||||
execute( @_ );
|
||||
}
|
||||
|
||||
|
||||
{
|
||||
my $p;
|
||||
|
||||
sub execute {
|
||||
my ( $self, $data, $offset, $limit ) = @_;
|
||||
my $value = substr( $data, $offset, $limit ? $limit : length $data );
|
||||
my $len = length $value;
|
||||
|
||||
$p = 0;
|
||||
|
||||
while ( $len > $p ) {
|
||||
_count( $self, $value ) or last;
|
||||
|
||||
if ( @{ $self->{stack} } > 0 ) {
|
||||
pop @{ $self->{stack} } if --$self->{stack}->[-1] == 0;
|
||||
}
|
||||
}
|
||||
|
||||
if ( $len == $p ) {
|
||||
$self->{ data } .= substr( $value, 0, $p );
|
||||
$self->{ remain } = undef;
|
||||
}
|
||||
|
||||
return $p;
|
||||
}
|
||||
|
||||
|
||||
sub _count {
|
||||
my ( $self, $value ) = @_;
|
||||
my $byte = unpack( 'C', substr( $value, $p++, 1 ) ); # get header
|
||||
|
||||
if ( ( $byte >= 0x90 and $byte <= 0x9f ) or $byte == 0xdc or $byte == 0xdd ) {
|
||||
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;
|
||||
}
|
||||
|
||||
push @{ $self->{stack} }, $num + 1;
|
||||
|
||||
return 1;
|
||||
}
|
||||
|
||||
elsif ( ( $byte >= 0x80 and $byte <= 0x8f ) or $byte == 0xde or $byte == 0xdf ) {
|
||||
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;
|
||||
}
|
||||
|
||||
push @{ $self->{stack} }, $num * 2 + 1; # a pair
|
||||
|
||||
return 1;
|
||||
}
|
||||
|
||||
elsif ( $byte == 0xc0 or $byte == 0xc2 or $byte == 0xc3 ) { # nil, false, true
|
||||
return 1;
|
||||
}
|
||||
|
||||
elsif ( $byte >= 0x00 and $byte <= 0x7f ) { # positive fixnum
|
||||
return 1;
|
||||
}
|
||||
|
||||
elsif ( $byte >= 0xcc and $byte <= 0xcf ) { # uint
|
||||
$p += $byte == 0xcc ? 1
|
||||
: $byte == 0xcd ? 2
|
||||
: $byte == 0xce ? 4
|
||||
: $byte == 0xcf ? 8
|
||||
: die;
|
||||
return 1;
|
||||
}
|
||||
|
||||
elsif ( $byte >= 0xd0 and $byte <= 0xd3 ) { # int
|
||||
$p += $byte == 0xd0 ? 1
|
||||
: $byte == 0xd1 ? 2
|
||||
: $byte == 0xd2 ? 4
|
||||
: $byte == 0xd3 ? 8
|
||||
: die;
|
||||
return 1;
|
||||
}
|
||||
|
||||
elsif ( $byte >= 0xe0 and $byte <= 0xff ) { # negative fixnum
|
||||
return 1;
|
||||
}
|
||||
|
||||
elsif ( $byte >= 0xca and $byte <= 0xcb ) { # float, double
|
||||
$p += $byte == 0xca ? 4 : 8;
|
||||
return 1;
|
||||
}
|
||||
|
||||
elsif ( ( $byte >= 0xa0 and $byte <= 0xbf ) or $byte == 0xda or $byte == 0xdb ) {
|
||||
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;
|
||||
}
|
||||
|
||||
else {
|
||||
die "???";
|
||||
}
|
||||
|
||||
return 0;
|
||||
}
|
||||
|
||||
} # execute
|
||||
|
||||
|
||||
sub data {
|
||||
my $data = Data::MessagePack->unpack( $_[0]->{ data } );
|
||||
$_[0]->reset;
|
||||
return $data;
|
||||
}
|
||||
|
||||
|
||||
sub is_finished {
|
||||
my ( $self ) = @_;
|
||||
( scalar( @{ $self->{stack} } ) or defined $self->{ remain } ) ? 0 : 1;
|
||||
}
|
||||
|
||||
|
||||
sub reset {
|
||||
$_[0]->{ stack } = [];
|
||||
$_[0]->{ data } = undef;
|
||||
$_[0]->{ remain } = undef;
|
||||
}
|
||||
|
||||
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
|
||||
@ -3,4 +3,4 @@ use warnings;
|
||||
use Test::More tests => 1;
|
||||
|
||||
use_ok 'Data::MessagePack';
|
||||
|
||||
diag ( $INC{'Data/MessagePack/PP.pm'} ? 'PP' : 'XS' );
|
||||
|
||||
@ -20,6 +20,7 @@ sub pis ($$) {
|
||||
# is(Dumper(Data::MessagePack->unpack(Data::MessagePack->pack($_[0]))), Dumper($_[0]));
|
||||
}
|
||||
|
||||
my $is_win = $^O eq 'MSWin32';
|
||||
my @dat = (
|
||||
'', 'a0',
|
||||
'0', '00',
|
||||
@ -33,12 +34,16 @@ my @dat = (
|
||||
''.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 => 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)$},
|
||||
''.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 => 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)},
|
||||
'-'.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',
|
||||
);
|
||||
|
||||
Loading…
x
Reference in New Issue
Block a user