From 712b8eec3d90f7e61908cb32c4433ee38a5f1848 Mon Sep 17 00:00:00 2001
From: makamaka <makamaka.donzoko@gmail.com>
Date: Wed, 1 Sep 2010 11:22:43 +0900
Subject: [PATCH 01/15] 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<Data::Float> and cannot unpack int64 and float (pack int64 too).
+
+
+=head1 SEE ALSO
+
+L<Data::MessagePack>,
+L<http://frox25.no-ip.org/~mtve/wiki/MessagePack.html>,
+L<Data::Float>
+
+=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 <makamaka.donzoko@gmail.com>
Date: Wed, 1 Sep 2010 11:59:01 +0900
Subject: [PATCH 02/15] 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<Data::Float> and cannot unpack int64 and float (pac
=head1 SEE ALSO
+L<http://msgpack.sourceforge.jp/>,
L<Data::MessagePack>,
+L<Data::Float>,
L<http://frox25.no-ip.org/~mtve/wiki/MessagePack.html>,
-L<Data::Float>
=head1 AUTHOR
From af83a624743735e1f4404bcd3942e98eee36ce2a Mon Sep 17 00:00:00 2001
From: makamaka <makamaka.donzoko@gmail.com>
Date: Wed, 1 Sep 2010 16:04:25 +0900
Subject: [PATCH 03/15] 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 <makamaka.donzoko@gmail.com>
Date: Thu, 2 Sep 2010 14:33:59 +0900
Subject: [PATCH 04/15] 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 <makamaka.donzoko@gmail.com>
Date: Thu, 2 Sep 2010 14:37:22 +0900
Subject: [PATCH 05/15] 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 <makamaka.donzoko@gmail.com>
Date: Thu, 2 Sep 2010 23:45:05 +0900
Subject: [PATCH 06/15] 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<Data::Float> and cannot unpack int64 and float (pack int64 too).
+Data::MessagePack::PP - Pure Perl implementation of Data::MessagePack
=head1 SEE ALSO
L<http://msgpack.sourceforge.jp/>,
L<Data::MessagePack>,
-L<Data::Float>,
L<http://frox25.no-ip.org/~mtve/wiki/MessagePack.html>,
=head1 AUTHOR
makamaka
+=head1 LIMITATION
+
+Currently this module works completely in Perl 5.10 or later.
+In Perl 5.8.x, it cannot C<unpack> 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 <makamaka.donzoko@gmail.com>
Date: Thu, 2 Sep 2010 23:48:57 +0900
Subject: [PATCH 07/15] 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 <makamaka.donzoko@gmail.com>
Date: Thu, 2 Sep 2010 23:52:36 +0900
Subject: [PATCH 08/15] 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 <makamaka.donzoko@gmail.com>
Date: Thu, 2 Sep 2010 23:56:55 +0900
Subject: [PATCH 09/15] 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<http://msgpack.sourceforge.jp/>,
L<Data::MessagePack>,
L<http://frox25.no-ip.org/~mtve/wiki/MessagePack.html>,
-=head1 AUTHOR
-
-makamaka
-
=head1 LIMITATION
Currently this module works completely in Perl 5.10 or later.
In Perl 5.8.x, it cannot C<unpack> 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 <makamaka.donzoko@gmail.com>
Date: Thu, 2 Sep 2010 23:58:40 +0900
Subject: [PATCH 10/15] 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<unpack> uint64 and int64.
+
=head1 SEE ALSO
@@ -509,12 +514,6 @@ L<http://msgpack.sourceforge.jp/>,
L<Data::MessagePack>,
L<http://frox25.no-ip.org/~mtve/wiki/MessagePack.html>,
-=head1 LIMITATION
-
-Currently this module works completely in Perl 5.10 or later.
-In Perl 5.8.x, it cannot C<unpack> uint64 and int64.
-
-
=head1 AUTHOR
makamaka
From b97baf4d4713580e89e0dca3bad350339618923e Mon Sep 17 00:00:00 2001
From: makamaka <makamaka.donzoko@gmail.com>
Date: Fri, 3 Sep 2010 12:53:56 +0900
Subject: [PATCH 11/15] 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 adfadc542a98dcc7d838778797b512ccf8bd78f2 Mon Sep 17 00:00:00 2001
From: makamaka <makamaka.donzoko@gmail.com>
Date: Sat, 4 Sep 2010 14:35:24 +0900
Subject: [PATCH 12/15] 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<unpack> uint64 and int64.
+=head1 DESCRIPTION
+This module is used by L<Data::MessagePack> internally.
=head1 SEE ALSO
From 25531d83936a1253a9dc5ee1b0f4f771d301317d Mon Sep 17 00:00:00 2001
From: makamaka <makamaka.donzoko@gmail.com>
Date: Sat, 4 Sep 2010 19:54:12 +0900
Subject: [PATCH 13/15] 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 <makamaka.donzoko@gmail.com>
Date: Sat, 4 Sep 2010 20:02:46 +0900
Subject: [PATCH 14/15] 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 <<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";
+ print "configure PP version\n\n";
}
clean_files qw{
From 10ec1e48b0857319d1b122c5ef4951c4dc514a02 Mon Sep 17 00:00:00 2001
From: makamaka <makamaka.donzoko@gmail.com>
Date: Sun, 5 Sep 2010 01:54:44 +0900
Subject: [PATCH 15/15] 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]; };