From 712b8eec3d90f7e61908cb32c4433ee38a5f1848 Mon Sep 17 00:00:00 2001 From: makamaka Date: Wed, 1 Sep 2010 11:22:43 +0900 Subject: [PATCH 01/17] added pp version --- perl/lib/Data/MessagePack/PP.pm | 556 ++++++++++++++++++++++++++++++++ 1 file changed, 556 insertions(+) create mode 100644 perl/lib/Data/MessagePack/PP.pm diff --git a/perl/lib/Data/MessagePack/PP.pm b/perl/lib/Data/MessagePack/PP.pm new file mode 100644 index 00000000..f4f1060f --- /dev/null +++ b/perl/lib/Data/MessagePack/PP.pm @@ -0,0 +1,556 @@ +package Data::MessagePack::PP; + +use 5.008000; +use strict; +use B (); +use Scalar::Util qw( blessed ); +use Carp (); + +our $VERSION = '0.03'; + + +# copied from Data::MessagePack +our $true = do { bless \(my $dummy = 1), "Data::MessagePack::Boolean" }; +our $false = do { bless \(my $dummy = 0), "Data::MessagePack::Boolean" }; + +sub true () { $true } +sub false () { $false } + +our $PreferInteger; + +# 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 { + # for pack and unpack compatibility + if ( $] < 5.010 ) { + require Data::Float; + *pack_double = sub { + my $float_hex = Data::Float::float_hex( $_[0] ); + my ( $sign, $sgnf, $exp ) = $float_hex =~ /^([-+])0x1\.([a-z0-9]+)p([-+][\d]+)$/; + my @bits; + + $sign = $sign eq '-' ? 1 : 0; + $exp = sprintf( '%011b', 1023 + $exp ); + + my $bit = $sign . $exp . join( '', map { unpack('B4', pack('H', $_) ) } split //, $sgnf ); + + while ( $bit =~ /(.{8})/g ) { + push @bits, $1; + } + + return pack( 'C*', 0xcb, map { unpack( 'C', pack("B*", $_ ) ) } @bits ); + }; + *unpack_double = sub { + my $bits = join('', map { sprintf('%08b', $_) } unpack( 'C*', substr( $_[0], $_[1], 8 ) ) ); + my $sign = substr($bits, 0, 1) ? '-' : '+'; + my $sgnf = substr($bits, 12, 52); + my $exp = substr($bits, 1, 11); + $bits = ''; + while ( $sgnf =~ /(.{4})/g ) { + $bits .= unpack('H',pack('B4', $1)); + } + $exp = ((unpack("C*",(pack("B8", (substr('00000'.$exp,0,8) )))) <<8 ) + + unpack("C*",(pack("B8", (substr('00000'.$exp,8,8) ))))) - 1023; + return Data::Float::hex_float( $sign . '0x1.' . $bits . 'p' . $exp ) + 0.0; + }; + *unpack_float = sub { Carp::croak("unpack_float is disable in less than Perl 5.10"); }; + *unpack_int16 = sub { + my $v = unpack 'n', substr( $_[0], $_[1], 2 ); + return $v ? $v - 0x10000 : 0; + }; + *unpack_int32 = sub { + my $v = unpack 'N', substr( $_[0], $_[1], 4 ); + return $v ? -(~$v + 1) : $v; + }; + *unpack_int64 = sub { Carp::croak("unpack_int64 is disable in less than Perl 5.10"); }; + } + else { + *pack_double = sub { return pack 'Cd>', 0xcb, $_[0]; }; + *unpack_double = sub { return unpack( 'd>', substr( $_[0], $_[1], 8 ) ); }; + *unpack_float = sub { return unpack( 'f>', substr( $_[0], $_[1], 4 ) ); }; + *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 ); }; + } + # for 5.8 etc. + unless ( defined &utf8::is_utf8 ) { + require Encode; + *utf8::is_utf8 = *Encode::is_utf8; + } +} + + +# +# PACK +# + +{ + 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 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 ? pack( 'C', 0x90 + $num ) + : $num < 2 ** 16 - 1 ? pack( 'Cn', 0xdc, $num ) + : $num < 2 ** 32 - 1 ? 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 ? pack( 'C', 0x80 + $num ) + : $num < 2 ** 16 - 1 ? pack( 'Cn', 0xde, $num ) + : $num < 2 ** 32 - 1 ? 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 ) eq 'Data::MessagePack::Boolean' ) { + return pack( 'C', $$value ? 0xc3 : 0xc2 ); + } + + my $flags = $b_obj->FLAGS; + + if ( $flags & ( B::SVf_IOK | B::SVp_IOK ) ) { + + if ($value >= 0) { + return $value <= 127 ? pack 'C', $value + : $value < 2 ** 8 ? pack 'CC', 0xcc, $value + : $value < 2 ** 16 ? pack 'Cn', 0xcd, $value + : $value < 2 ** 32 ? pack 'CN', 0xce, $value + : pack 'CQ>', 0xcf, $value; + } + else { + return -$value <= 32 ? pack 'C', $value + : -$value <= 2 ** 7 ? pack 'Cc', 0xd0, $value + : -$value <= 2 ** 15 ? pack 'Cn', 0xd1, $value + : -$value <= 2 ** 31 ? pack 'CN', 0xd2, $value + : pack 'Cq>', 0xd3, $value; + } + + } + + elsif ( $flags & B::SVf_POK ) { # raw / check needs before dboule + + if ( $PreferInteger ) { + if ( $value =~ /^-?[0-9]+$/ ) { # ok? + my $value2 = 0 + $value; + if ( 0 + $value != B::svref_2object( \$value2 )->int_value ) { + local $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 ? pack( 'C', 0xa0 + $num ) + : $num < 2 ** 16 - 1 ? pack( 'Cn', 0xda, $num ) + : $num < 2 ** 32 - 1 ? 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 = 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 = 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; + } + 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 = 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; + } + my %map; + for ( 0 .. $num - 1 ) { + 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 + unpack( 'C', substr( $value, $p++, 1 ) ); + } + elsif ( $byte == 0xcd ) { # uint16 + $p += 2; + return unpack 'n', substr( $value, $p - 2, 2 ); + } + elsif ( $byte == 0xce ) { # unit32 + $p += 4; + return unpack 'N', substr( $value, $p - 4, 4 ); + } + elsif ( $byte == 0xcf ) { # unit64 + $p += 8; + return unpack 'Q>', substr( $value, $p - 8, 8 ); + } + elsif ( $byte == 0xd3 ) { # int64 + $p += 8; + return unpack_int64( $value, $p - 8 ); + return unpack 'q>', substr( $value, $p - 8, 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 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 = unpack 'n', substr( $value, $p, 2 ); + $p += 2 + $num; + } + elsif ( $byte == 0xdb ) { + $num = 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::PP::Unpacker; + +use strict; + +sub new { + bless { stack => [] }, shift; +} + + +sub execute_limit { + execute( @_ ); +} + + +{ + my $p; + #my $r; # remained data. + +sub execute { + my ( $self, $data, $offset, $limit ) = @_; + #my $value = ( defined $self->{ remain } ? $self->{ remain } : '' ) . substr( $data, $offset, $limit ); + my $value = substr( $data, $offset, $limit ? $limit : length $data ); + my $len = length $value; + + $p = 0; + #$r = 0; + + while ( $len > $p ) { + _count( $self, $value ) or last; + + if ( @{ $self->{stack} } > 0 ) { + $self->{stack}->[-1]; + pop @{ $self->{stack} } if --$self->{stack}->[-1] == 0; + } + } + + if ( $len == $p ) { + $self->{ data } .= substr( $value, 0, $p ); + $self->{ remain } = undef; + } + else { # I thought this feature is needed. but XS version can't do so + #$self->{ remain } = substr( $value, 0, $p + $r ); + } + + 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 + # I thought this feature is needed. but XS version can't do so. So commented out. + #my $len = length substr( $value, $p, 2 ); + #if ( $len != 2 ) { + # $r = $len; + # return 0; + #} + $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 - the pure perl version of Data::MessagePack + +=head1 LIMITATION + +Currently this module works completely in Perl 5.10 or later. +In Perl 5.8.x, it requires L and cannot unpack int64 and float (pack int64 too). + + +=head1 SEE ALSO + +L, +L, +L + +=head1 AUTHOR + +makamaka + +=head1 COPYRIGHT AND LICENSE + +This library is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. + +=cut From a0705a6c67e852154e92bb16876ac9e950a8f044 Mon Sep 17 00:00:00 2001 From: makamaka Date: Wed, 1 Sep 2010 11:59:01 +0900 Subject: [PATCH 02/17] added PP backend switch into Data::MessagePack --- perl/Changes | 6 ++++++ perl/lib/Data/MessagePack.pm | 15 +++++++++++++-- perl/lib/Data/MessagePack/PP.pm | 33 +++++++++++++++------------------ 3 files changed, 34 insertions(+), 20 deletions(-) diff --git a/perl/Changes b/perl/Changes index 189990a8..a8a4298c 100644 --- a/perl/Changes +++ b/perl/Changes @@ -1,3 +1,9 @@ + +0.1x + + - added PP version. + (makamaka) + 0.15 - better argument validation. diff --git a/perl/lib/Data/MessagePack.pm b/perl/lib/Data/MessagePack.pm index 276353a2..a3f8264e 100644 --- a/perl/lib/Data/MessagePack.pm +++ b/perl/lib/Data/MessagePack.pm @@ -1,7 +1,6 @@ package Data::MessagePack; use strict; use warnings; -use XSLoader; use 5.008001; our $VERSION = '0.15'; @@ -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 + if ( $ENV{ PERL_DATA_MESSAGEPACK } !~ /\b pp \b/xms ) { + eval { + require XSLoader; + XSLoader::load(__PACKAGE__, $VERSION); + }; + die $@ if $@ && $ENV{ PERL_DATA_MESSAGEPACK } =~ /\b xs \b/xms; # force XS + } + if ( !__PACKAGE__->can('pack') ) { + print "PP\n"; + require 'Data/MessagePack/PP.pm'; + } +} 1; __END__ diff --git a/perl/lib/Data/MessagePack/PP.pm b/perl/lib/Data/MessagePack/PP.pm index f4f1060f..ecb97b46 100644 --- a/perl/lib/Data/MessagePack/PP.pm +++ b/perl/lib/Data/MessagePack/PP.pm @@ -2,21 +2,9 @@ package Data::MessagePack::PP; use 5.008000; use strict; -use B (); -use Scalar::Util qw( blessed ); use Carp (); -our $VERSION = '0.03'; - - -# copied from Data::MessagePack -our $true = do { bless \(my $dummy = 1), "Data::MessagePack::Boolean" }; -our $false = do { bless \(my $dummy = 0), "Data::MessagePack::Boolean" }; - -sub true () { $true } -sub false () { $false } - -our $PreferInteger; +our $VERSION = '0.15'; # See also # http://redmine.msgpack.org/projects/msgpack/wiki/FormatSpec @@ -24,6 +12,13 @@ our $PreferInteger; # 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 ) { @@ -160,11 +155,11 @@ sub _pack { elsif ( $flags & B::SVf_POK ) { # raw / check needs before dboule - if ( $PreferInteger ) { + if ( $Data::MessagePack::PreferInteger ) { if ( $value =~ /^-?[0-9]+$/ ) { # ok? my $value2 = 0 + $value; if ( 0 + $value != B::svref_2object( \$value2 )->int_value ) { - local $PreferInteger; # avoid for PV => NV + local $Data::MessagePack::PreferInteger; # avoid for PV => NV return _pack( "$value" ); } return _pack( $value + 0 ); @@ -346,7 +341,8 @@ sub _unpack { # Data::MessagePack::Unpacker # -package Data::MessagePack::PP::Unpacker; +package + Data::MessagePack::Unpacker; use strict; @@ -530,7 +526,7 @@ __END__ =head1 NAME -Data::MessagePack::PP - the pure perl version of Data::MessagePack +Data::MessagePack::PP - Pure Perl version of Data::MessagePack =head1 LIMITATION @@ -540,9 +536,10 @@ In Perl 5.8.x, it requires L and cannot unpack int64 and float (pac =head1 SEE ALSO +L, L, +L, L, -L =head1 AUTHOR From af83a624743735e1f4404bcd3942e98eee36ce2a Mon Sep 17 00:00:00 2001 From: makamaka Date: Wed, 1 Sep 2010 16:04:25 +0900 Subject: [PATCH 03/17] modified some codes for test warnings --- perl/lib/Data/MessagePack.pm | 5 ++- perl/lib/Data/MessagePack/PP.pm | 74 +++++++++++++++++---------------- 2 files changed, 41 insertions(+), 38 deletions(-) diff --git a/perl/lib/Data/MessagePack.pm b/perl/lib/Data/MessagePack.pm index a3f8264e..f8d16254 100644 --- a/perl/lib/Data/MessagePack.pm +++ b/perl/lib/Data/MessagePack.pm @@ -12,12 +12,13 @@ sub true () { $true } sub false () { $false } if ( !__PACKAGE__->can('pack') ) { # this idea comes from Text::Xslate - if ( $ENV{ PERL_DATA_MESSAGEPACK } !~ /\b pp \b/xms ) { + my $backend = $ENV{ PERL_DATA_MESSAGEPACK } || ''; + if ( $backend !~ /\b pp \b/xms ) { eval { require XSLoader; XSLoader::load(__PACKAGE__, $VERSION); }; - die $@ if $@ && $ENV{ PERL_DATA_MESSAGEPACK } =~ /\b xs \b/xms; # force XS + die $@ if $@ && $backend =~ /\b xs \b/xms; # force XS } if ( !__PACKAGE__->can('pack') ) { print "PP\n"; diff --git a/perl/lib/Data/MessagePack/PP.pm b/perl/lib/Data/MessagePack/PP.pm index ecb97b46..1e05bab0 100644 --- a/perl/lib/Data/MessagePack/PP.pm +++ b/perl/lib/Data/MessagePack/PP.pm @@ -84,6 +84,8 @@ BEGIN { # { + no warnings 'recursion'; + my $max_depth; sub pack { @@ -96,16 +98,16 @@ sub pack { sub _pack { my ( $value ) = @_; - return pack( 'C', 0xc0 ) if ( not defined $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 ? pack( 'C', 0x90 + $num ) - : $num < 2 ** 16 - 1 ? pack( 'Cn', 0xdc, $num ) - : $num < 2 ** 32 - 1 ? pack( 'CN', 0xdd, $num ) + $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 ) { @@ -117,9 +119,9 @@ sub _pack { elsif ( $b_obj->isa('B::HV') ) { my $num = keys %$value; my $header = - $num < 16 ? pack( 'C', 0x80 + $num ) - : $num < 2 ** 16 - 1 ? pack( 'Cn', 0xde, $num ) - : $num < 2 ** 32 - 1 ? pack( 'CN', 0xdf, $num ) + $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 ) { @@ -128,8 +130,8 @@ sub _pack { return join( '', $header, map { _pack( $_ ) } %$value ); } - elsif ( blessed( $value ) eq 'Data::MessagePack::Boolean' ) { - return pack( 'C', $$value ? 0xc3 : 0xc2 ); + elsif ( blessed( $value ) and blessed( $value ) eq 'Data::MessagePack::Boolean' ) { + return CORE::pack( 'C', $$value ? 0xc3 : 0xc2 ); } my $flags = $b_obj->FLAGS; @@ -137,18 +139,18 @@ sub _pack { if ( $flags & ( B::SVf_IOK | B::SVp_IOK ) ) { if ($value >= 0) { - return $value <= 127 ? pack 'C', $value - : $value < 2 ** 8 ? pack 'CC', 0xcc, $value - : $value < 2 ** 16 ? pack 'Cn', 0xcd, $value - : $value < 2 ** 32 ? pack 'CN', 0xce, $value - : pack 'CQ>', 0xcf, $value; + 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 + : CORE::pack 'CQ>', 0xcf, $value; } else { - return -$value <= 32 ? pack 'C', $value - : -$value <= 2 ** 7 ? pack 'Cc', 0xd0, $value - : -$value <= 2 ** 15 ? pack 'Cn', 0xd1, $value - : -$value <= 2 ** 31 ? pack 'CN', 0xd2, $value - : pack 'Cq>', 0xd3, $value; + 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 + : CORE::pack 'Cq>', 0xd3, $value; } } @@ -170,9 +172,9 @@ sub _pack { my $num = length $value; my $header = - $num < 32 ? pack( 'C', 0xa0 + $num ) - : $num < 2 ** 16 - 1 ? pack( 'Cn', 0xda, $num ) - : $num < 2 ** 32 - 1 ? pack( 'CN', 0xdb, $num ) + $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 ; @@ -198,6 +200,7 @@ sub _pack { # { + my $p; # position variables for speed. sub unpack { @@ -208,18 +211,18 @@ sub unpack { sub _unpack { my ( $value ) = @_; - my $byte = unpack( 'C', substr( $value, $p++, 1 ) ); # get header + 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 = unpack 'n', substr( $value, $p, 2 ); + $num = CORE::unpack 'n', substr( $value, $p, 2 ); $p += 2; } elsif ( $byte == 0xdd ) { # array 32 - $num = unpack 'N', substr( $value, $p, 4 ); + $num = CORE::unpack 'N', substr( $value, $p, 4 ); $p += 4; } else { # fix array @@ -233,11 +236,11 @@ sub _unpack { 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 ); + $num = CORE::unpack 'n', substr( $value, $p, 2 ); $p += 2; } elsif ( $byte == 0xdf ) { # map 32 - $num = unpack 'N', substr( $value, $p, 4 ); + $num = CORE::unpack 'N', substr( $value, $p, 4 ); $p += 4; } else { # fix map @@ -245,6 +248,7 @@ sub _unpack { } my %map; for ( 0 .. $num - 1 ) { + no warnings; # for undef key case my $key = _unpack( $value ); my $val = _unpack( $value ); $map{ $key } = $val; @@ -256,24 +260,23 @@ sub _unpack { return $byte; } elsif ( $byte == 0xcc ) { # uint8 - unpack( 'C', substr( $value, $p++, 1 ) ); + CORE::unpack( 'C', substr( $value, $p++, 1 ) ); } elsif ( $byte == 0xcd ) { # uint16 $p += 2; - return unpack 'n', substr( $value, $p - 2, 2 ); + return CORE::unpack 'n', substr( $value, $p - 2, 2 ); } elsif ( $byte == 0xce ) { # unit32 $p += 4; - return unpack 'N', substr( $value, $p - 4, 4 ); + return CORE::unpack 'N', substr( $value, $p - 4, 4 ); } elsif ( $byte == 0xcf ) { # unit64 $p += 8; - return unpack 'Q>', substr( $value, $p - 8, 8 ); + return CORE::unpack 'Q>', substr( $value, $p - 8, 8 ); } elsif ( $byte == 0xd3 ) { # int64 $p += 8; return unpack_int64( $value, $p - 8 ); - return unpack 'q>', substr( $value, $p - 8, 8 ); } elsif ( $byte == 0xd2 ) { # int32 $p += 4; @@ -284,7 +287,7 @@ sub _unpack { return unpack_int16( $value, $p - 2 ); } elsif ( $byte == 0xd0 ) { # int8 - return unpack 'c', substr( $value, $p++, 1 ); # c / C + return CORE::unpack 'c', substr( $value, $p++, 1 ); # c / C } elsif ( $byte >= 0xe0 and $byte <= 0xff ) { # negative fixnum return $byte - 256; @@ -293,11 +296,11 @@ sub _unpack { elsif ( ( $byte >= 0xa0 and $byte <= 0xbf ) or $byte == 0xda or $byte == 0xdb ) { # raw my $num; if ( $byte == 0xda ) { - $num = unpack 'n', substr( $value, $p, 2 ); + $num = CORE::unpack 'n', substr( $value, $p, 2 ); $p += 2 + $num; } elsif ( $byte == 0xdb ) { - $num = unpack 'N', substr( $value, $p, 4 ); + $num = CORE::unpack 'N', substr( $value, $p, 4 ); $p += 4 + $num; } else { # fix raw @@ -373,7 +376,6 @@ sub execute { _count( $self, $value ) or last; if ( @{ $self->{stack} } > 0 ) { - $self->{stack}->[-1]; pop @{ $self->{stack} } if --$self->{stack}->[-1] == 0; } } From 8fc86ce7fa588657ce841a9cf30ea868c461c4e1 Mon Sep 17 00:00:00 2001 From: makamaka Date: Thu, 2 Sep 2010 14:33:59 +0900 Subject: [PATCH 04/17] removed commented out codes --- perl/lib/Data/MessagePack.pm | 1 - perl/lib/Data/MessagePack/PP.pm | 12 ------------ perl/{ => xs-src}/MessagePack.c | 0 perl/{ => xs-src}/pack.c | 0 perl/{ => xs-src}/unpack.c | 0 5 files changed, 13 deletions(-) rename perl/{ => xs-src}/MessagePack.c (100%) rename perl/{ => xs-src}/pack.c (100%) rename perl/{ => xs-src}/unpack.c (100%) diff --git a/perl/lib/Data/MessagePack.pm b/perl/lib/Data/MessagePack.pm index f8d16254..785f275d 100644 --- a/perl/lib/Data/MessagePack.pm +++ b/perl/lib/Data/MessagePack.pm @@ -21,7 +21,6 @@ if ( !__PACKAGE__->can('pack') ) { # this idea comes from Text::Xslate die $@ if $@ && $backend =~ /\b xs \b/xms; # force XS } if ( !__PACKAGE__->can('pack') ) { - print "PP\n"; require 'Data/MessagePack/PP.pm'; } } diff --git a/perl/lib/Data/MessagePack/PP.pm b/perl/lib/Data/MessagePack/PP.pm index 1e05bab0..540b416d 100644 --- a/perl/lib/Data/MessagePack/PP.pm +++ b/perl/lib/Data/MessagePack/PP.pm @@ -361,16 +361,13 @@ sub execute_limit { { my $p; - #my $r; # remained data. sub execute { my ( $self, $data, $offset, $limit ) = @_; - #my $value = ( defined $self->{ remain } ? $self->{ remain } : '' ) . substr( $data, $offset, $limit ); my $value = substr( $data, $offset, $limit ? $limit : length $data ); my $len = length $value; $p = 0; - #$r = 0; while ( $len > $p ) { _count( $self, $value ) or last; @@ -384,9 +381,6 @@ sub execute { $self->{ data } .= substr( $value, 0, $p ); $self->{ remain } = undef; } - else { # I thought this feature is needed. but XS version can't do so - #$self->{ remain } = substr( $value, 0, $p + $r ); - } return $p; } @@ -399,12 +393,6 @@ sub _count { if ( ( $byte >= 0x90 and $byte <= 0x9f ) or $byte == 0xdc or $byte == 0xdd ) { my $num; if ( $byte == 0xdc ) { # array 16 - # I thought this feature is needed. but XS version can't do so. So commented out. - #my $len = length substr( $value, $p, 2 ); - #if ( $len != 2 ) { - # $r = $len; - # return 0; - #} $num = unpack 'n', substr( $value, $p, 2 ); $p += 2; } diff --git a/perl/MessagePack.c b/perl/xs-src/MessagePack.c similarity index 100% rename from perl/MessagePack.c rename to perl/xs-src/MessagePack.c diff --git a/perl/pack.c b/perl/xs-src/pack.c similarity index 100% rename from perl/pack.c rename to perl/xs-src/pack.c diff --git a/perl/unpack.c b/perl/xs-src/unpack.c similarity index 100% rename from perl/unpack.c rename to perl/xs-src/unpack.c From 918dbd1926589a9b70f34037e35e98f3194302fc Mon Sep 17 00:00:00 2001 From: makamaka Date: Thu, 2 Sep 2010 14:37:22 +0900 Subject: [PATCH 05/17] made Makefile.PL XS/PP configurable --- perl/Makefile.PL | 69 +++++++++++++++++++++++++++++++++++++++------ perl/t/00_compile.t | 2 +- 2 files changed, 62 insertions(+), 9 deletions(-) diff --git a/perl/Makefile.PL b/perl/Makefile.PL index e9f9618a..7440a46d 100644 --- a/perl/Makefile.PL +++ b/perl/Makefile.PL @@ -5,15 +5,29 @@ 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. +my $use_xs = want_xs(); + +if ( $] >= 5.008005 and $use_xs ) { + can_cc or die "This module requires a C compiler"; + use_ppport 3.19; + requires_c99(); # msgpack C library requires C99. + cc_src_paths('xs-src'); + if ($ENV{DEBUG}) { + cc_append_to_ccflags '-g'; + } + # for author's test_pp + requires 'Data::Float' => 0 if ( $Module::Install::AUTHOR and $] < 5.010 ); +} +else { # for Data::MessagePack::PP + print "configure PP version\n"; + requires 'Data::Float' => 0 if ( $] < 5.010 ); +} clean_files qw{ *.stackdump @@ -23,10 +37,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 +49,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; +} diff --git a/perl/t/00_compile.t b/perl/t/00_compile.t index 66fe8f0e..f91b29e7 100644 --- a/perl/t/00_compile.t +++ b/perl/t/00_compile.t @@ -3,4 +3,4 @@ use warnings; use Test::More tests => 1; use_ok 'Data::MessagePack'; - +diag ( $INC{'Data/MessagePack/PP.pm'} ? 'PP' : 'XS' ); From 8f43e033a49aaf1bacb8fb887a0f7b7a538c4031 Mon Sep 17 00:00:00 2001 From: makamaka Date: Thu, 2 Sep 2010 23:45:05 +0900 Subject: [PATCH 06/17] removed dependency on Data::Float --- perl/Makefile.PL | 5 +-- perl/lib/Data/MessagePack/PP.pm | 70 +++++++++++++-------------------- 2 files changed, 28 insertions(+), 47 deletions(-) diff --git a/perl/Makefile.PL b/perl/Makefile.PL index 7440a46d..b7864854 100644 --- a/perl/Makefile.PL +++ b/perl/Makefile.PL @@ -21,12 +21,9 @@ if ( $] >= 5.008005 and $use_xs ) { if ($ENV{DEBUG}) { cc_append_to_ccflags '-g'; } - # for author's test_pp - requires 'Data::Float' => 0 if ( $Module::Install::AUTHOR and $] < 5.010 ); } -else { # for Data::MessagePack::PP +else { print "configure PP version\n"; - requires 'Data::Float' => 0 if ( $] < 5.010 ); } clean_files qw{ diff --git a/perl/lib/Data/MessagePack/PP.pm b/perl/lib/Data/MessagePack/PP.pm index 540b416d..86583733 100644 --- a/perl/lib/Data/MessagePack/PP.pm +++ b/perl/lib/Data/MessagePack/PP.pm @@ -22,37 +22,19 @@ use B (); BEGIN { # for pack and unpack compatibility if ( $] < 5.010 ) { - require Data::Float; - *pack_double = sub { - my $float_hex = Data::Float::float_hex( $_[0] ); - my ( $sign, $sgnf, $exp ) = $float_hex =~ /^([-+])0x1\.([a-z0-9]+)p([-+][\d]+)$/; - my @bits; - - $sign = $sign eq '-' ? 1 : 0; - $exp = sprintf( '%011b', 1023 + $exp ); - - my $bit = $sign . $exp . join( '', map { unpack('B4', pack('H', $_) ) } split //, $sgnf ); - - while ( $bit =~ /(.{8})/g ) { - push @bits, $1; - } - - return pack( 'C*', 0xcb, map { unpack( 'C', pack("B*", $_ ) ) } @bits ); - }; - *unpack_double = sub { - my $bits = join('', map { sprintf('%08b', $_) } unpack( 'C*', substr( $_[0], $_[1], 8 ) ) ); - my $sign = substr($bits, 0, 1) ? '-' : '+'; - my $sgnf = substr($bits, 12, 52); - my $exp = substr($bits, 1, 11); - $bits = ''; - while ( $sgnf =~ /(.{4})/g ) { - $bits .= unpack('H',pack('B4', $1)); - } - $exp = ((unpack("C*",(pack("B8", (substr('00000'.$exp,0,8) )))) <<8 ) - + unpack("C*",(pack("B8", (substr('00000'.$exp,8,8) ))))) - 1023; - return Data::Float::hex_float( $sign . '0x1.' . $bits . 'p' . $exp ) + 0.0; - }; - *unpack_float = sub { Carp::croak("unpack_float is disable in less than Perl 5.10"); }; + my $bo_is_le = unpack ( 'd', "\x00\x00\x00\x00\x00\x00\xf0\x3f") == 1; # 1.0LE + *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; @@ -62,14 +44,16 @@ BEGIN { return $v ? -(~$v + 1) : $v; }; *unpack_int64 = sub { Carp::croak("unpack_int64 is disable in less than Perl 5.10"); }; + *unpack_uint64 = sub { Carp::croak("unpack_uint64 is disable in less than Perl 5.10"); }; } else { *pack_double = sub { return pack 'Cd>', 0xcb, $_[0]; }; - *unpack_double = sub { return unpack( 'd>', substr( $_[0], $_[1], 8 ) ); }; *unpack_float = sub { return unpack( 'f>', substr( $_[0], $_[1], 4 ) ); }; - *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_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 ) { @@ -272,7 +256,7 @@ sub _unpack { } elsif ( $byte == 0xcf ) { # unit64 $p += 8; - return CORE::unpack 'Q>', substr( $value, $p - 8, 8 ); + return pack_uint64( $value, $p - 8 ); } elsif ( $byte == 0xd3 ) { # int64 $p += 8; @@ -516,25 +500,25 @@ __END__ =head1 NAME -Data::MessagePack::PP - Pure Perl version of Data::MessagePack - -=head1 LIMITATION - -Currently this module works completely in Perl 5.10 or later. -In Perl 5.8.x, it requires L and cannot unpack int64 and float (pack int64 too). +Data::MessagePack::PP - Pure Perl implementation of Data::MessagePack =head1 SEE ALSO L, L, -L, L, =head1 AUTHOR makamaka +=head1 LIMITATION + +Currently this module works completely in Perl 5.10 or later. +In Perl 5.8.x, it cannot C uint64 and int64. + + =head1 COPYRIGHT AND LICENSE This library is free software; you can redistribute it and/or modify From 4cc6c3e535e1181dcd9810fd862b80954246f9b7 Mon Sep 17 00:00:00 2001 From: makamaka Date: Thu, 2 Sep 2010 23:48:57 +0900 Subject: [PATCH 07/17] modified t/05_preferred_int.t for Win32 --- perl/t/05_preferred_int.t | 9 +++++++-- 1 file changed, 7 insertions(+), 2 deletions(-) diff --git a/perl/t/05_preferred_int.t b/perl/t/05_preferred_int.t index 9860711b..67d11aaf 100644 --- a/perl/t/05_preferred_int.t +++ b/perl/t/05_preferred_int.t @@ -16,6 +16,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', @@ -29,12 +30,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 => 'b4 38 2e 33 30 37 36 37 34 39 37 33 36 35 35 37 32 65 2b 33 34', + ''.0xFFFFFFFFFFFFFFFFFFFFFFFFFFFFF => $is_win ? + 'b5 38 2e 33 30 37 36 37 34 39 37 33 36 35 35 37 32 65 2b 30 33 34' + : 'b4 38 2e 33 30 37 36 37 34 39 37 33 36 35 35 37 32 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 => 'b5 2d 36 2e 36 34 36 31 33 39 39 37 38 39 32 34 35 38 65 2b 33 35', + '-'.0x800000000000000000000000000000 => $is_win ? + 'b6 2d 36 2e 36 34 36 31 33 39 39 37 38 39 32 34 35 38 65 2b 30 33 35' + : 'b5 2d 36 2e 36 34 36 31 33 39 39 37 38 39 32 34 35 38 65 2b 33 35', {'0' => '1'}, '81 00 01', {'abc' => '1'}, '81 a3 61 62 63 01', ); From cdc09a7d30e3390dba17db64df121a2dc34c8f04 Mon Sep 17 00:00:00 2001 From: makamaka Date: Thu, 2 Sep 2010 23:52:36 +0900 Subject: [PATCH 08/17] Changes --- perl/Changes | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) diff --git a/perl/Changes b/perl/Changes index a8a4298c..a9bb2dbb 100644 --- a/perl/Changes +++ b/perl/Changes @@ -1,7 +1,10 @@ 0.1x - - added PP version. + - 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.15 From 2b75d54ce14521b70b63d7aa808a005ac8dafdfa Mon Sep 17 00:00:00 2001 From: makamaka Date: Thu, 2 Sep 2010 23:56:55 +0900 Subject: [PATCH 09/17] modified pod --- perl/lib/Data/MessagePack/PP.pm | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/perl/lib/Data/MessagePack/PP.pm b/perl/lib/Data/MessagePack/PP.pm index 86583733..270db343 100644 --- a/perl/lib/Data/MessagePack/PP.pm +++ b/perl/lib/Data/MessagePack/PP.pm @@ -509,16 +509,16 @@ L, L, L, -=head1 AUTHOR - -makamaka - =head1 LIMITATION Currently this module works completely in Perl 5.10 or later. In Perl 5.8.x, it cannot C uint64 and int64. +=head1 AUTHOR + +makamaka + =head1 COPYRIGHT AND LICENSE This library is free software; you can redistribute it and/or modify From f91728561fe9c374edb93262e7c9a7c1d819d284 Mon Sep 17 00:00:00 2001 From: makamaka Date: Thu, 2 Sep 2010 23:58:40 +0900 Subject: [PATCH 10/17] ouch, modified pod --- perl/lib/Data/MessagePack/PP.pm | 11 +++++------ 1 file changed, 5 insertions(+), 6 deletions(-) diff --git a/perl/lib/Data/MessagePack/PP.pm b/perl/lib/Data/MessagePack/PP.pm index 270db343..5d956078 100644 --- a/perl/lib/Data/MessagePack/PP.pm +++ b/perl/lib/Data/MessagePack/PP.pm @@ -502,6 +502,11 @@ __END__ Data::MessagePack::PP - Pure Perl implementation of Data::MessagePack +=head1 LIMITATION + +Currently this module works completely in Perl 5.10 or later. +In Perl 5.8.x, it cannot C uint64 and int64. + =head1 SEE ALSO @@ -509,12 +514,6 @@ L, L, L, -=head1 LIMITATION - -Currently this module works completely in Perl 5.10 or later. -In Perl 5.8.x, it cannot C uint64 and int64. - - =head1 AUTHOR makamaka From b97baf4d4713580e89e0dca3bad350339618923e Mon Sep 17 00:00:00 2001 From: makamaka Date: Fri, 3 Sep 2010 12:53:56 +0900 Subject: [PATCH 11/17] added some comments in Data::MessagePack::PP --- perl/lib/Data/MessagePack/PP.pm | 3 +++ 1 file changed, 3 insertions(+) diff --git a/perl/lib/Data/MessagePack/PP.pm b/perl/lib/Data/MessagePack/PP.pm index 5d956078..e01b7972 100644 --- a/perl/lib/Data/MessagePack/PP.pm +++ b/perl/lib/Data/MessagePack/PP.pm @@ -22,7 +22,10 @@ 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. *pack_double = $bo_is_le ? sub { my @v = unpack( 'V2', pack( 'd', $_[0] ) ); return pack 'CN2', 0xcb, @v[1,0]; From 1fe4109a42d717aea41ea7ffd7a3193208711e77 Mon Sep 17 00:00:00 2001 From: tokuhirom Date: Fri, 3 Sep 2010 14:50:01 +0900 Subject: [PATCH 12/17] fixed tests on 64bit machines with -Duselongdouble #60625 --- perl/t/05_preferred_int.t | 10 +++++++--- 1 file changed, 7 insertions(+), 3 deletions(-) diff --git a/perl/t/05_preferred_int.t b/perl/t/05_preferred_int.t index 9860711b..fe14ef6c 100644 --- a/perl/t/05_preferred_int.t +++ b/perl/t/05_preferred_int.t @@ -12,7 +12,11 @@ sub packit { } sub pis ($$) { - is packit($_[0]), $_[1], 'dump ' . $_[1]; + 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])); } @@ -29,12 +33,12 @@ 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 => 'b4 38 2e 33 30 37 36 37 34 39 37 33 36 35 35 37 32 65 2b 33 34', + ''.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)$}, '-'.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 => 'b5 2d 36 2e 36 34 36 31 33 39 39 37 38 39 32 34 35 38 65 2b 33 35', + '-'.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)}, {'0' => '1'}, '81 00 01', {'abc' => '1'}, '81 a3 61 62 63 01', ); From adfadc542a98dcc7d838778797b512ccf8bd78f2 Mon Sep 17 00:00:00 2001 From: makamaka Date: Sat, 4 Sep 2010 14:35:24 +0900 Subject: [PATCH 13/17] enable PP to pack/unpack int64 in less than Perl 5.10 --- perl/lib/Data/MessagePack/PP.pm | 39 +++++++++++++++++++++++---------- 1 file changed, 28 insertions(+), 11 deletions(-) diff --git a/perl/lib/Data/MessagePack/PP.pm b/perl/lib/Data/MessagePack/PP.pm index e01b7972..bd37ad76 100644 --- a/perl/lib/Data/MessagePack/PP.pm +++ b/perl/lib/Data/MessagePack/PP.pm @@ -26,6 +26,14 @@ BEGIN { # 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. + *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]; @@ -43,13 +51,22 @@ BEGIN { 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 + 1) : $v; + return $v ? $v - 0x100000000 : 0; + }; + *unpack_int64 = sub { + my @v = unpack( 'V*', substr( $_[0], $_[1], 8 ) ); + return unpack( 'q', pack( 'N2', @v[1,0] ) ); + }; + *unpack_uint64 = sub { + my @v = unpack( 'V*', substr( $_[0], $_[1], 8 ) ); + return unpack( 'Q', pack( 'N2', @v[1,0] ) ); }; - *unpack_int64 = sub { Carp::croak("unpack_int64 is disable in less than Perl 5.10"); }; - *unpack_uint64 = sub { Carp::croak("unpack_uint64 is disable in less than Perl 5.10"); }; } 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 ) ); }; @@ -130,14 +147,14 @@ sub _pack { : $value < 2 ** 8 ? CORE::pack 'CC', 0xcc, $value : $value < 2 ** 16 ? CORE::pack 'Cn', 0xcd, $value : $value < 2 ** 32 ? CORE::pack 'CN', 0xce, $value - : CORE::pack 'CQ>', 0xcf, $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 - : CORE::pack 'Cq>', 0xd3, $value; + : pack_int64( $value ); } } @@ -147,7 +164,9 @@ sub _pack { if ( $Data::MessagePack::PreferInteger ) { if ( $value =~ /^-?[0-9]+$/ ) { # ok? my $value2 = 0 + $value; - if ( 0 + $value != B::svref_2object( \$value2 )->int_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" ); } @@ -259,7 +278,7 @@ sub _unpack { } elsif ( $byte == 0xcf ) { # unit64 $p += 8; - return pack_uint64( $value, $p - 8 ); + return unpack_uint64( $value, $p - 8 ); } elsif ( $byte == 0xd3 ) { # int64 $p += 8; @@ -505,11 +524,9 @@ __END__ Data::MessagePack::PP - Pure Perl implementation of Data::MessagePack -=head1 LIMITATION - -Currently this module works completely in Perl 5.10 or later. -In Perl 5.8.x, it cannot C uint64 and int64. +=head1 DESCRIPTION +This module is used by L internally. =head1 SEE ALSO From 25531d83936a1253a9dc5ee1b0f4f771d301317d Mon Sep 17 00:00:00 2001 From: makamaka Date: Sat, 4 Sep 2010 19:54:12 +0900 Subject: [PATCH 14/17] modified t/05_preferred_int.t for Win32 --- perl/t/05_preferred_int.t | 8 ++++++-- 1 file changed, 6 insertions(+), 2 deletions(-) diff --git a/perl/t/05_preferred_int.t b/perl/t/05_preferred_int.t index 9eb223ad..084df31c 100644 --- a/perl/t/05_preferred_int.t +++ b/perl/t/05_preferred_int.t @@ -34,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', ); From 84123f544524d6ffd118b91cd7e053d0a6d8bbe4 Mon Sep 17 00:00:00 2001 From: makamaka Date: Sat, 4 Sep 2010 20:02:46 +0900 Subject: [PATCH 15/17] fallback PP configuration with c99 unspport compiler --- perl/Makefile.PL | 30 +++++++++++++++++++++--------- 1 file changed, 21 insertions(+), 9 deletions(-) diff --git a/perl/Makefile.PL b/perl/Makefile.PL index b7864854..783e658d 100644 --- a/perl/Makefile.PL +++ b/perl/Makefile.PL @@ -11,19 +11,31 @@ license 'perl'; tests 't/*.t'; recursive_author_tests('xt'); -my $use_xs = want_xs(); -if ( $] >= 5.008005 and $use_xs ) { - can_cc or die "This module requires a C compiler"; - use_ppport 3.19; - requires_c99(); # msgpack C library requires C99. - cc_src_paths('xs-src'); - if ($ENV{DEBUG}) { - cc_append_to_ccflags '-g'; +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 < Date: Sun, 5 Sep 2010 01:54:44 +0900 Subject: [PATCH 16/17] modified begin process about byte order --- perl/lib/Data/MessagePack/PP.pm | 16 ++++++++-------- 1 file changed, 8 insertions(+), 8 deletions(-) diff --git a/perl/lib/Data/MessagePack/PP.pm b/perl/lib/Data/MessagePack/PP.pm index bd37ad76..9e322991 100644 --- a/perl/lib/Data/MessagePack/PP.pm +++ b/perl/lib/Data/MessagePack/PP.pm @@ -25,19 +25,19 @@ BEGIN { # require $Config{byteorder}; my $bo_is_le = ( $Config{byteorder} =~ /^1234/ ); # which better? my $bo_is_le = unpack ( 'd', "\x00\x00\x00\x00\x00\x00\xf0\x3f") == 1; # 1.0LE - # In really, since 5.9.2 '>' is introduced. + # 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]; }; + } : 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]; }; + } : 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]; }; + } : 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] ) ); @@ -55,14 +55,14 @@ BEGIN { my $v = unpack 'N', substr( $_[0], $_[1], 4 ); return $v ? $v - 0x100000000 : 0; }; - *unpack_int64 = sub { + *unpack_int64 = $bo_is_le ? sub { my @v = unpack( 'V*', substr( $_[0], $_[1], 8 ) ); return unpack( 'q', pack( 'N2', @v[1,0] ) ); - }; - *unpack_uint64 = sub { + } : 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]; }; From b9bca2a19fc6519296bcda2c6af5f82cc744e005 Mon Sep 17 00:00:00 2001 From: tokuhirom Date: Sun, 5 Sep 2010 16:17:19 +0900 Subject: [PATCH 17/17] bump to 0.16 --- perl/Changes | 5 +++++ perl/lib/Data/MessagePack.pm | 2 +- 2 files changed, 6 insertions(+), 1 deletion(-) diff --git a/perl/Changes b/perl/Changes index 189990a8..448130b4 100644 --- a/perl/Changes +++ b/perl/Changes @@ -1,3 +1,8 @@ +0.16 + + - tests on 64bit machines with -Duselongdouble + (reported by andk) + 0.15 - better argument validation. diff --git a/perl/lib/Data/MessagePack.pm b/perl/lib/Data/MessagePack.pm index 276353a2..94f28c19 100644 --- a/perl/lib/Data/MessagePack.pm +++ b/perl/lib/Data/MessagePack.pm @@ -4,7 +4,7 @@ use warnings; use XSLoader; use 5.008001; -our $VERSION = '0.15'; +our $VERSION = '0.16'; our $PreferInteger = 0; our $true = do { bless \(my $dummy = 1), "Data::MessagePack::Boolean" };