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/43] 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/43] 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/43] 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/43] 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/43] 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/43] 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/43] 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/43] 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/43] 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/43] 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/43] 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/43] 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/43] 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/43] 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/43] 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 <tokuhirom@gmail.com>
Date: Sun, 5 Sep 2010 16:17:19 +0900
Subject: [PATCH 16/43] 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" };
From 80db9971b5a579a1388e0e110baa4a8ec3d1ea7c Mon Sep 17 00:00:00 2001
From: Hideyuki Tanaka <tanakh@tanakh-desktop.(none)>
Date: Mon, 6 Sep 2010 01:32:00 +0900
Subject: [PATCH 17/43] pure haskell implementation.
---
haskell/LICENSE | 2 +-
haskell/cbits/msgpack.c | 137 ----
haskell/msgpack.cabal | 55 +-
haskell/src/Data/MessagePack.hs | 130 ++--
haskell/src/Data/MessagePack/Base.hsc | 584 ------------------
haskell/src/Data/MessagePack/Feed.hs | 62 --
haskell/src/Data/MessagePack/Monad.hs | 156 -----
.../Data/MessagePack/{Class.hs => Object.hs} | 38 +-
haskell/src/Data/MessagePack/Packer.hs | 147 +++++
haskell/src/Data/MessagePack/Put.hs | 202 ++++++
haskell/src/Data/MessagePack/Stream.hs | 82 ---
haskell/test/Monad.hs | 15 +-
haskell/test/Stream.hs | 14 -
haskell/test/Test.hs | 69 ++-
14 files changed, 543 insertions(+), 1150 deletions(-)
delete mode 100644 haskell/cbits/msgpack.c
delete mode 100644 haskell/src/Data/MessagePack/Base.hsc
delete mode 100644 haskell/src/Data/MessagePack/Feed.hs
delete mode 100644 haskell/src/Data/MessagePack/Monad.hs
rename haskell/src/Data/MessagePack/{Class.hs => Object.hs} (77%)
create mode 100644 haskell/src/Data/MessagePack/Packer.hs
create mode 100644 haskell/src/Data/MessagePack/Put.hs
delete mode 100644 haskell/src/Data/MessagePack/Stream.hs
delete mode 100644 haskell/test/Stream.hs
diff --git a/haskell/LICENSE b/haskell/LICENSE
index 2de30f66..3cb4d8c8 100644
--- a/haskell/LICENSE
+++ b/haskell/LICENSE
@@ -1,4 +1,4 @@
-Copyright (c) 2009, Hideyuki Tanaka
+Copyright (c) 2009-2010, Hideyuki Tanaka
All rights reserved.
Redistribution and use in source and binary forms, with or without
diff --git a/haskell/cbits/msgpack.c b/haskell/cbits/msgpack.c
deleted file mode 100644
index be445925..00000000
--- a/haskell/cbits/msgpack.c
+++ /dev/null
@@ -1,137 +0,0 @@
-#include <msgpack.h>
-
-void msgpack_sbuffer_init_wrap(msgpack_sbuffer* sbuf)
-{
- msgpack_sbuffer_init(sbuf);
-}
-
-void msgpack_sbuffer_destroy_wrap(msgpack_sbuffer* sbuf)
-{
- msgpack_sbuffer_destroy(sbuf);
-}
-
-int msgpack_sbuffer_write_wrap(void* data, const char* buf, unsigned int len)
-{
- return msgpack_sbuffer_write(data, buf, len);
-}
-
-msgpack_packer* msgpack_packer_new_wrap(void *data, msgpack_packer_write callback)
-{
- return msgpack_packer_new(data, callback);
-}
-
-void msgpack_packer_free_wrap(msgpack_packer* pk)
-{
- msgpack_packer_free(pk);
-}
-
-int msgpack_pack_uint8_wrap(msgpack_packer* pk, uint8_t d)
-{
- return msgpack_pack_uint8(pk, d);
-}
-
-int msgpack_pack_uint16_wrap(msgpack_packer* pk, uint16_t d)
-{
- return msgpack_pack_uint16(pk, d);
-}
-
-int msgpack_pack_uint32_wrap(msgpack_packer* pk, uint32_t d)
-{
- return msgpack_pack_uint32(pk, d);
-}
-
-int msgpack_pack_uint64_wrap(msgpack_packer* pk, uint64_t d)
-{
- return msgpack_pack_uint64(pk, d);
-}
-
-int msgpack_pack_int8_wrap(msgpack_packer* pk, int8_t d)
-{
- return msgpack_pack_int8(pk, d);
-}
-
-int msgpack_pack_int16_wrap(msgpack_packer* pk, int16_t d)
-{
- return msgpack_pack_int16(pk, d);
-}
-
-int msgpack_pack_int32_wrap(msgpack_packer* pk, int32_t d)
-{
- return msgpack_pack_int32(pk, d);
-}
-
-int msgpack_pack_int64_wrap(msgpack_packer* pk, int64_t d)
-{
- return msgpack_pack_int64(pk, d);
-}
-
-int msgpack_pack_double_wrap(msgpack_packer* pk, double d)
-{
- return msgpack_pack_double(pk, d);
-}
-
-int msgpack_pack_nil_wrap(msgpack_packer* pk)
-{
- return msgpack_pack_nil(pk);
-}
-
-int msgpack_pack_true_wrap(msgpack_packer* pk)
-{
- return msgpack_pack_true(pk);
-}
-
-int msgpack_pack_false_wrap(msgpack_packer* pk)
-{
- return msgpack_pack_false(pk);
-}
-
-int msgpack_pack_array_wrap(msgpack_packer* pk, unsigned int n)
-{
- return msgpack_pack_array(pk, n);
-}
-
-int msgpack_pack_map_wrap(msgpack_packer* pk, unsigned int n)
-{
- return msgpack_pack_map(pk, n);
-}
-
-int msgpack_pack_raw_wrap(msgpack_packer* pk, size_t l)
-{
- return msgpack_pack_raw(pk, l);
-}
-
-int msgpack_pack_raw_body_wrap(msgpack_packer* pk, const void *b, size_t l)
-{
- return msgpack_pack_raw_body(pk, b, l);
-}
-
-bool msgpack_unpacker_reserve_buffer_wrap(msgpack_unpacker *mpac, size_t size)
-{
- return msgpack_unpacker_reserve_buffer(mpac, size);
-}
-
-char *msgpack_unpacker_buffer_wrap(msgpack_unpacker *mpac)
-{
- return msgpack_unpacker_buffer(mpac);
-}
-
-size_t msgpack_unpacker_buffer_capacity_wrap(const msgpack_unpacker *mpac)
-{
- return msgpack_unpacker_buffer_capacity(mpac);
-}
-
-void msgpack_unpacker_buffer_consumed_wrap(msgpack_unpacker *mpac, size_t size)
-{
- msgpack_unpacker_buffer_consumed(mpac, size);
-}
-
-void msgpack_unpacker_data_wrap(msgpack_unpacker *mpac, msgpack_object *obj)
-{
- *obj=msgpack_unpacker_data(mpac);
-}
-
-size_t msgpack_unpacker_message_size_wrap(const msgpack_unpacker *mpac)
-{
- return msgpack_unpacker_message_size(mpac);
-}
-
diff --git a/haskell/msgpack.cabal b/haskell/msgpack.cabal
index 82cdb525..8346c1f8 100644
--- a/haskell/msgpack.cabal
+++ b/haskell/msgpack.cabal
@@ -1,32 +1,35 @@
-Name: msgpack
-Version: 0.2.2
-License: BSD3
-License-File: LICENSE
-Author: Hideyuki Tanaka
-Maintainer: Hideyuki Tanaka <tanaka.hideyuki@gmail.com>
-Category: Data
-Synopsis: A Haskell binding to MessagePack
+Name: msgpack
+Version: 0.3.0
+Synopsis: A Haskell binding to MessagePack
Description:
A Haskell binding to MessagePack <http://msgpack.sourceforge.jp/>
-Homepage: http://github.com/tanakh/hsmsgpack
-Stability: Experimental
-Tested-with: GHC==6.10.4
-Cabal-Version: >=1.2
-Build-Type: Simple
-library
- build-depends: base>=4 && <5, mtl, bytestring
- ghc-options: -O2 -Wall
- hs-source-dirs: src
- extra-libraries: msgpackc
+License: BSD3
+License-File: LICENSE
+Category: Data
+Author: Hideyuki Tanaka
+Maintainer: Hideyuki Tanaka <tanaka.hideyuki@gmail.com>
+Homepage: http://github.com/tanakh/hsmsgpack
+Stability: Experimental
+Tested-with: GHC == 6.12.3
+Cabal-Version: >= 1.2
+Build-Type: Simple
+
+Library
+ Build-depends: base >=4 && <5,
+ transformers >= 0.2.1 && < 0.2.2,
+ MonadCatchIO-transformers >= 0.2.2 && < 0.2.3,
+ bytestring >= 0.9 && < 0.10,
+ vector >= 0.6.0 && < 0.6.1,
+ iteratee >= 0.4 && < 0.5,
+ attoparsec >= 0.8.1 && < 0.8.2,
+ binary >= 0.5.0 && < 0.5.1,
+ data-binary-ieee754 >= 0.4 && < 0.5
+ Ghc-options: -Wall -O2
+ Hs-source-dirs: src
Exposed-modules:
Data.MessagePack
- Data.MessagePack.Base
- Data.MessagePack.Class
- Data.MessagePack.Feed
- Data.MessagePack.Monad
- Data.MessagePack.Stream
-
- C-Sources:
- cbits/msgpack.c
+ Data.MessagePack.Object
+ Data.MessagePack.Put
+ Data.MessagePack.Parser
diff --git a/haskell/src/Data/MessagePack.hs b/haskell/src/Data/MessagePack.hs
index 2949e603..010eaab0 100644
--- a/haskell/src/Data/MessagePack.hs
+++ b/haskell/src/Data/MessagePack.hs
@@ -1,7 +1,7 @@
--------------------------------------------------------------------
-- |
-- Module : Data.MessagePack
--- Copyright : (c) Hideyuki Tanaka, 2009
+-- Copyright : (c) Hideyuki Tanaka, 2009-2010
-- License : BSD3
--
-- Maintainer: tanaka.hideyuki@gmail.com
@@ -13,51 +13,105 @@
--------------------------------------------------------------------
module Data.MessagePack(
- module Data.MessagePack.Base,
- module Data.MessagePack.Class,
- module Data.MessagePack.Feed,
- module Data.MessagePack.Monad,
- module Data.MessagePack.Stream,
+ module Data.MessagePack.Object,
+ module Data.MessagePack.Put,
+ module Data.MessagePack.Parser,
- -- * Pack and Unpack
- packb,
- unpackb,
+ -- * Simple functions of Pack and Unpack
+ pack,
+ unpack,
+
+ -- * Pack functions
+ packToString,
+ packToHandle,
+ packToFile,
+
+ -- * Unpack functions
+ unpackFromString,
+ unpackFromHandle,
+ unpackFromFile,
- -- * Pure version of Pack and Unpack
- packb',
- unpackb',
) where
-import Data.ByteString (ByteString)
-import System.IO.Unsafe
+import qualified Control.Monad.CatchIO as CIO
+import Control.Monad.IO.Class
+import qualified Data.Attoparsec as A
+import Data.Binary.Put
+import qualified Data.ByteString as B
+import qualified Data.ByteString.Lazy as L
+import Data.Functor.Identity
+import qualified Data.Iteratee as I
+import qualified Data.Iteratee.IO as I
+import System.IO
-import Data.MessagePack.Base
-import Data.MessagePack.Class
-import Data.MessagePack.Feed
-import Data.MessagePack.Monad
-import Data.MessagePack.Stream
+import Data.MessagePack.Object
+import Data.MessagePack.Put
+import Data.MessagePack.Parser
+
+bufferSize :: Int
+bufferSize = 4 * 1024
+
+class IsByteString s where
+ toBS :: s -> B.ByteString
+
+instance IsByteString B.ByteString where
+ toBS = id
+
+instance IsByteString L.ByteString where
+ toBS = B.concat . L.toChunks
-- | Pack Haskell data to MessagePack string.
-packb :: OBJECT a => a -> IO ByteString
-packb dat = do
- sb <- newSimpleBuffer
- pc <- newPacker sb
- pack pc dat
- simpleBufferData sb
+pack :: ObjectPut a => a -> L.ByteString
+pack = packToString . put
-- | Unpack MessagePack string to Haskell data.
-unpackb :: OBJECT a => ByteString -> IO (Result a)
-unpackb bs = do
- withZone $ \z -> do
- r <- unpackObject z bs
- return $ case r of
- Left err -> Left (show err)
- Right (_, dat) -> fromObject dat
+unpack :: (ObjectGet a, IsByteString s) => s -> a
+unpack bs =
+ runIdentity $ I.run $ I.joinIM $ I.enumPure1Chunk (toBS bs) (parserToIteratee get)
--- | Pure version of 'packb'.
-packb' :: OBJECT a => a -> ByteString
-packb' dat = unsafePerformIO $ packb dat
+-- TODO: tryUnpack
--- | Pure version of 'unpackb'.
-unpackb' :: OBJECT a => ByteString -> Result a
-unpackb' bs = unsafePerformIO $ unpackb bs
+-- | Pack to ByteString.
+packToString :: Put -> L.ByteString
+packToString = runPut
+
+-- | Pack to Handle
+packToHandle :: Handle -> Put -> IO ()
+packToHandle h = L.hPutStr h . packToString
+
+-- | Pack to File
+packToFile :: FilePath -> Put -> IO ()
+packToFile path = L.writeFile path . packToString
+
+-- | Unpack from ByteString
+unpackFromString :: (Monad m, IsByteString s) => s -> A.Parser a -> m a
+unpackFromString bs =
+ I.run . I.joinIM . I.enumPure1Chunk (toBS bs) . parserToIteratee
+
+-- | Unpack from Handle
+unpackFromHandle :: CIO.MonadCatchIO m => Handle -> A.Parser a -> m a
+unpackFromHandle h =
+ I.run . I.joinIM . I.enumHandle bufferSize h . parserToIteratee
+
+-- | Unpack from File
+unpackFromFile :: CIO.MonadCatchIO m => FilePath -> A.Parser a -> m a
+unpackFromFile path p =
+ CIO.bracket
+ (liftIO $ openBinaryFile path ReadMode)
+ (liftIO . hClose)
+ (flip unpackFromHandle p)
+
+parserToIteratee :: Monad m => A.Parser a -> I.Iteratee B.ByteString m a
+parserToIteratee p = I.icont (itr (A.parse p)) Nothing
+ where
+ itr pcont s = case s of
+ I.EOF _ ->
+ I.throwErr (I.setEOF s)
+ I.Chunk bs ->
+ case pcont bs of
+ A.Fail _ _ msg ->
+ I.throwErr (I.iterStrExc msg)
+ A.Partial cont ->
+ I.icont (itr cont) Nothing
+ A.Done remain ret ->
+ I.idone ret (I.Chunk remain)
diff --git a/haskell/src/Data/MessagePack/Base.hsc b/haskell/src/Data/MessagePack/Base.hsc
deleted file mode 100644
index b6cdc287..00000000
--- a/haskell/src/Data/MessagePack/Base.hsc
+++ /dev/null
@@ -1,584 +0,0 @@
-{-# LANGUAGE CPP #-}
-{-# LANGUAGE ForeignFunctionInterface #-}
-
---------------------------------------------------------------------
--- |
--- Module : Data.MessagePack.Base
--- Copyright : (c) Hideyuki Tanaka, 2009
--- License : BSD3
---
--- Maintainer: tanaka.hideyuki@gmail.com
--- Stability : experimental
--- Portability: portable
---
--- Low Level Interface to MessagePack C API
---
---------------------------------------------------------------------
-
-module Data.MessagePack.Base(
- -- * Simple Buffer
- SimpleBuffer,
- newSimpleBuffer,
- simpleBufferData,
-
- -- * Serializer
- Packer,
- newPacker,
-
- packU8,
- packU16,
- packU32,
- packU64,
- packS8,
- packS16,
- packS32,
- packS64,
-
- packTrue,
- packFalse,
-
- packInt,
- packDouble,
- packNil,
- packBool,
-
- packArray,
- packMap,
- packRAW,
- packRAWBody,
- packRAW',
-
- -- * Stream Deserializer
- Unpacker,
- defaultInitialBufferSize,
- newUnpacker,
- unpackerReserveBuffer,
- unpackerBuffer,
- unpackerBufferCapacity,
- unpackerBufferConsumed,
- unpackerFeed,
- unpackerExecute,
- unpackerData,
- unpackerReleaseZone,
- unpackerResetZone,
- unpackerReset,
- unpackerMessageSize,
-
- -- * MessagePack Object
- Object(..),
- packObject,
-
- UnpackReturn(..),
- unpackObject,
-
- -- * Memory Zone
- Zone,
- newZone,
- freeZone,
- withZone,
- ) where
-
-import Control.Exception
-import Control.Monad
-import Data.ByteString (ByteString)
-import qualified Data.ByteString as BS hiding (pack, unpack)
-import Data.Int
-import Data.Word
-import Foreign.C
-import Foreign.Concurrent
-import Foreign.ForeignPtr hiding (newForeignPtr)
-import Foreign.Marshal.Alloc
-import Foreign.Marshal.Array
-import Foreign.Ptr
-import Foreign.Storable
-
-#include <msgpack.h>
-
-type SimpleBuffer = ForeignPtr ()
-
-type WriteCallback = Ptr () -> CString -> CUInt -> IO CInt
-
--- | Create a new Simple Buffer. It will be deleted automatically.
-newSimpleBuffer :: IO SimpleBuffer
-newSimpleBuffer = do
- ptr <- mallocBytes (#size msgpack_sbuffer)
- fptr <- newForeignPtr ptr $ do
- msgpack_sbuffer_destroy ptr
- free ptr
- withForeignPtr fptr $ \p ->
- msgpack_sbuffer_init p
- return fptr
-
--- | Get data of Simple Buffer.
-simpleBufferData :: SimpleBuffer -> IO ByteString
-simpleBufferData sb =
- withForeignPtr sb $ \ptr -> do
- size <- (#peek msgpack_sbuffer, size) ptr
- dat <- (#peek msgpack_sbuffer, data) ptr
- BS.packCStringLen (dat, fromIntegral (size :: CSize))
-
-foreign import ccall "msgpack_sbuffer_init_wrap" msgpack_sbuffer_init ::
- Ptr () -> IO ()
-
-foreign import ccall "msgpack_sbuffer_destroy_wrap" msgpack_sbuffer_destroy ::
- Ptr () -> IO ()
-
-foreign import ccall "msgpack_sbuffer_write_wrap" msgpack_sbuffer_write ::
- WriteCallback
-
-type Packer = ForeignPtr ()
-
--- | Create new Packer. It will be deleted automatically.
-newPacker :: SimpleBuffer -> IO Packer
-newPacker sbuf = do
- cb <- wrap_callback msgpack_sbuffer_write
- ptr <- withForeignPtr sbuf $ \ptr ->
- msgpack_packer_new ptr cb
- fptr <- newForeignPtr ptr $ do
- msgpack_packer_free ptr
- return fptr
-
-foreign import ccall "msgpack_packer_new_wrap" msgpack_packer_new ::
- Ptr () -> FunPtr WriteCallback -> IO (Ptr ())
-
-foreign import ccall "msgpack_packer_free_wrap" msgpack_packer_free ::
- Ptr () -> IO ()
-
-foreign import ccall "wrapper" wrap_callback ::
- WriteCallback -> IO (FunPtr WriteCallback)
-
-packU8 :: Packer -> Word8 -> IO Int
-packU8 pc n =
- liftM fromIntegral $ withForeignPtr pc $ \ptr ->
- msgpack_pack_uint8 ptr n
-
-foreign import ccall "msgpack_pack_uint8_wrap" msgpack_pack_uint8 ::
- Ptr () -> Word8 -> IO CInt
-
-packU16 :: Packer -> Word16 -> IO Int
-packU16 pc n =
- liftM fromIntegral $ withForeignPtr pc $ \ptr ->
- msgpack_pack_uint16 ptr n
-
-foreign import ccall "msgpack_pack_uint16_wrap" msgpack_pack_uint16 ::
- Ptr () -> Word16 -> IO CInt
-
-packU32 :: Packer -> Word32 -> IO Int
-packU32 pc n =
- liftM fromIntegral $ withForeignPtr pc $ \ptr ->
- msgpack_pack_uint32 ptr n
-
-foreign import ccall "msgpack_pack_uint32_wrap" msgpack_pack_uint32 ::
- Ptr () -> Word32 -> IO CInt
-
-packU64 :: Packer -> Word64 -> IO Int
-packU64 pc n =
- liftM fromIntegral $ withForeignPtr pc $ \ptr ->
- msgpack_pack_uint64 ptr n
-
-foreign import ccall "msgpack_pack_uint64_wrap" msgpack_pack_uint64 ::
- Ptr () -> Word64 -> IO CInt
-
-packS8 :: Packer -> Int8 -> IO Int
-packS8 pc n =
- liftM fromIntegral $ withForeignPtr pc $ \ptr ->
- msgpack_pack_int8 ptr n
-
-foreign import ccall "msgpack_pack_int8_wrap" msgpack_pack_int8 ::
- Ptr () -> Int8 -> IO CInt
-
-packS16 :: Packer -> Int16 -> IO Int
-packS16 pc n =
- liftM fromIntegral $ withForeignPtr pc $ \ptr ->
- msgpack_pack_int16 ptr n
-
-foreign import ccall "msgpack_pack_int16_wrap" msgpack_pack_int16 ::
- Ptr () -> Int16 -> IO CInt
-
-packS32 :: Packer -> Int32 -> IO Int
-packS32 pc n =
- liftM fromIntegral $ withForeignPtr pc $ \ptr ->
- msgpack_pack_int32 ptr n
-
-foreign import ccall "msgpack_pack_int32_wrap" msgpack_pack_int32 ::
- Ptr () -> Int32 -> IO CInt
-
-packS64 :: Packer -> Int64 -> IO Int
-packS64 pc n =
- liftM fromIntegral $ withForeignPtr pc $ \ptr ->
- msgpack_pack_int64 ptr n
-
-foreign import ccall "msgpack_pack_int64_wrap" msgpack_pack_int64 ::
- Ptr () -> Int64 -> IO CInt
-
--- | Pack an integral data.
-packInt :: Integral a => Packer -> a -> IO Int
-packInt pc n = packS64 pc $ fromIntegral n
-
--- | Pack a double data.
-packDouble :: Packer -> Double -> IO Int
-packDouble pc d =
- liftM fromIntegral $ withForeignPtr pc $ \ptr ->
- msgpack_pack_double ptr (realToFrac d)
-
-foreign import ccall "msgpack_pack_double_wrap" msgpack_pack_double ::
- Ptr () -> CDouble -> IO CInt
-
--- | Pack a nil.
-packNil :: Packer -> IO Int
-packNil pc =
- liftM fromIntegral $ withForeignPtr pc $ \ptr ->
- msgpack_pack_nil ptr
-
-foreign import ccall "msgpack_pack_nil_wrap" msgpack_pack_nil ::
- Ptr () -> IO CInt
-
-packTrue :: Packer -> IO Int
-packTrue pc =
- liftM fromIntegral $ withForeignPtr pc $ \ptr ->
- msgpack_pack_true ptr
-
-foreign import ccall "msgpack_pack_true_wrap" msgpack_pack_true ::
- Ptr () -> IO CInt
-
-packFalse :: Packer -> IO Int
-packFalse pc =
- liftM fromIntegral $ withForeignPtr pc $ \ptr ->
- msgpack_pack_false ptr
-
-foreign import ccall "msgpack_pack_false_wrap" msgpack_pack_false ::
- Ptr () -> IO CInt
-
--- | Pack a bool data.
-packBool :: Packer -> Bool -> IO Int
-packBool pc True = packTrue pc
-packBool pc False = packFalse pc
-
--- | 'packArray' @p n@ starts packing an array.
--- Next @n@ data will consist this array.
-packArray :: Packer -> Int -> IO Int
-packArray pc n =
- liftM fromIntegral $ withForeignPtr pc $ \ptr ->
- msgpack_pack_array ptr (fromIntegral n)
-
-foreign import ccall "msgpack_pack_array_wrap" msgpack_pack_array ::
- Ptr () -> CUInt -> IO CInt
-
--- | 'packMap' @p n@ starts packing a map.
--- Next @n@ pairs of data (2*n data) will consist this map.
-packMap :: Packer -> Int -> IO Int
-packMap pc n =
- liftM fromIntegral $ withForeignPtr pc $ \ptr ->
- msgpack_pack_map ptr (fromIntegral n)
-
-foreign import ccall "msgpack_pack_map_wrap" msgpack_pack_map ::
- Ptr () -> CUInt -> IO CInt
-
--- | 'packRAW' @p n@ starts packing a byte sequence.
--- Next total @n@ bytes of 'packRAWBody' call will consist this sequence.
-packRAW :: Packer -> Int -> IO Int
-packRAW pc n =
- liftM fromIntegral $ withForeignPtr pc $ \ptr ->
- msgpack_pack_raw ptr (fromIntegral n)
-
-foreign import ccall "msgpack_pack_raw_wrap" msgpack_pack_raw ::
- Ptr () -> CSize -> IO CInt
-
--- | Pack a byte sequence.
-packRAWBody :: Packer -> ByteString -> IO Int
-packRAWBody pc bs =
- liftM fromIntegral $ withForeignPtr pc $ \ptr ->
- BS.useAsCStringLen bs $ \(str, len) ->
- msgpack_pack_raw_body ptr (castPtr str) (fromIntegral len)
-
-foreign import ccall "msgpack_pack_raw_body_wrap" msgpack_pack_raw_body ::
- Ptr () -> Ptr () -> CSize -> IO CInt
-
--- | Pack a single byte stream. It calls 'packRAW' and 'packRAWBody'.
-packRAW' :: Packer -> ByteString -> IO Int
-packRAW' pc bs = do
- _ <- packRAW pc (BS.length bs)
- packRAWBody pc bs
-
-type Unpacker = ForeignPtr ()
-
-defaultInitialBufferSize :: Int
-defaultInitialBufferSize = 32 * 1024 -- #const MSGPACK_UNPACKER_DEFAULT_INITIAL_BUFFER_SIZE
-
--- | 'newUnpacker' @initialBufferSize@ creates a new Unpacker. It will be deleted automatically.
-newUnpacker :: Int -> IO Unpacker
-newUnpacker initialBufferSize = do
- ptr <- msgpack_unpacker_new (fromIntegral initialBufferSize)
- fptr <- newForeignPtr ptr $ do
- msgpack_unpacker_free ptr
- return fptr
-
-foreign import ccall "msgpack_unpacker_new" msgpack_unpacker_new ::
- CSize -> IO (Ptr ())
-
-foreign import ccall "msgpack_unpacker_free" msgpack_unpacker_free ::
- Ptr() -> IO ()
-
--- | 'unpackerReserveBuffer' @up size@ reserves at least @size@ bytes of buffer.
-unpackerReserveBuffer :: Unpacker -> Int -> IO Bool
-unpackerReserveBuffer up size =
- withForeignPtr up $ \ptr ->
- liftM (/=0) $ msgpack_unpacker_reserve_buffer ptr (fromIntegral size)
-
-foreign import ccall "msgpack_unpacker_reserve_buffer_wrap" msgpack_unpacker_reserve_buffer ::
- Ptr () -> CSize -> IO CChar
-
--- | Get a pointer of unpacker buffer.
-unpackerBuffer :: Unpacker -> IO (Ptr CChar)
-unpackerBuffer up =
- withForeignPtr up $ \ptr ->
- msgpack_unpacker_buffer ptr
-
-foreign import ccall "msgpack_unpacker_buffer_wrap" msgpack_unpacker_buffer ::
- Ptr () -> IO (Ptr CChar)
-
--- | Get size of allocated buffer.
-unpackerBufferCapacity :: Unpacker -> IO Int
-unpackerBufferCapacity up =
- withForeignPtr up $ \ptr ->
- liftM fromIntegral $ msgpack_unpacker_buffer_capacity ptr
-
-foreign import ccall "msgpack_unpacker_buffer_capacity_wrap" msgpack_unpacker_buffer_capacity ::
- Ptr () -> IO CSize
-
--- | 'unpackerBufferConsumed' @up size@ notices that writed @size@ bytes to buffer.
-unpackerBufferConsumed :: Unpacker -> Int -> IO ()
-unpackerBufferConsumed up size =
- withForeignPtr up $ \ptr ->
- msgpack_unpacker_buffer_consumed ptr (fromIntegral size)
-
-foreign import ccall "msgpack_unpacker_buffer_consumed_wrap" msgpack_unpacker_buffer_consumed ::
- Ptr () -> CSize -> IO ()
-
--- | Write byte sequence to Unpacker. It is utility funciton, calls 'unpackerReserveBuffer', 'unpackerBuffer' and 'unpackerBufferConsumed'.
-unpackerFeed :: Unpacker -> ByteString -> IO ()
-unpackerFeed up bs =
- BS.useAsCStringLen bs $ \(str, len) -> do
- True <- unpackerReserveBuffer up len
- ptr <- unpackerBuffer up
- copyArray ptr str len
- unpackerBufferConsumed up len
-
--- | Execute deserializing. It returns 0 when buffer contains not enough bytes, returns 1 when succeeded, returns negative value when it failed.
-unpackerExecute :: Unpacker -> IO Int
-unpackerExecute up =
- withForeignPtr up $ \ptr ->
- liftM fromIntegral $ msgpack_unpacker_execute ptr
-
-foreign import ccall "msgpack_unpacker_execute" msgpack_unpacker_execute ::
- Ptr () -> IO CInt
-
--- | Returns a deserialized object when 'unpackerExecute' returned 1.
-unpackerData :: Unpacker -> IO Object
-unpackerData up =
- withForeignPtr up $ \ptr ->
- allocaBytes (#size msgpack_object) $ \pobj -> do
- msgpack_unpacker_data ptr pobj
- peekObject pobj
-
-foreign import ccall "msgpack_unpacker_data_wrap" msgpack_unpacker_data ::
- Ptr () -> Ptr () -> IO ()
-
--- | Release memory zone. The returned zone must be freed by calling 'freeZone'.
-unpackerReleaseZone :: Unpacker -> IO Zone
-unpackerReleaseZone up =
- withForeignPtr up $ \ptr ->
- msgpack_unpacker_release_zone ptr
-
-foreign import ccall "msgpack_unpacker_release_zone" msgpack_unpacker_release_zone ::
- Ptr () -> IO (Ptr ())
-
--- | Free memory zone used by Unapcker.
-unpackerResetZone :: Unpacker -> IO ()
-unpackerResetZone up =
- withForeignPtr up $ \ptr ->
- msgpack_unpacker_reset_zone ptr
-
-foreign import ccall "msgpack_unpacker_reset_zone" msgpack_unpacker_reset_zone ::
- Ptr () -> IO ()
-
--- | Reset Unpacker state except memory zone.
-unpackerReset :: Unpacker -> IO ()
-unpackerReset up =
- withForeignPtr up $ \ptr ->
- msgpack_unpacker_reset ptr
-
-foreign import ccall "msgpack_unpacker_reset" msgpack_unpacker_reset ::
- Ptr () -> IO ()
-
--- | Returns number of bytes of sequence of deserializing object.
-unpackerMessageSize :: Unpacker -> IO Int
-unpackerMessageSize up =
- withForeignPtr up $ \ptr ->
- liftM fromIntegral $ msgpack_unpacker_message_size ptr
-
-foreign import ccall "msgpack_unpacker_message_size_wrap" msgpack_unpacker_message_size ::
- Ptr () -> IO CSize
-
-type Zone = Ptr ()
-
--- | Create a new memory zone. It must be freed manually.
-newZone :: IO Zone
-newZone =
- msgpack_zone_new (#const MSGPACK_ZONE_CHUNK_SIZE)
-
--- | Free a memory zone.
-freeZone :: Zone -> IO ()
-freeZone z =
- msgpack_zone_free z
-
--- | Create a memory zone, then execute argument, then free memory zone.
-withZone :: (Zone -> IO a) -> IO a
-withZone z =
- bracket newZone freeZone z
-
-foreign import ccall "msgpack_zone_new" msgpack_zone_new ::
- CSize -> IO Zone
-
-foreign import ccall "msgpack_zone_free" msgpack_zone_free ::
- Zone -> IO ()
-
--- | Object Representation of MessagePack data.
-data Object =
- ObjectNil
- | ObjectBool Bool
- | ObjectInteger Int
- | ObjectDouble Double
- | ObjectRAW ByteString
- | ObjectArray [Object]
- | ObjectMap [(Object, Object)]
- deriving (Show)
-
-peekObject :: Ptr a -> IO Object
-peekObject ptr = do
- typ <- (#peek msgpack_object, type) ptr
- case (typ :: CInt) of
- (#const MSGPACK_OBJECT_NIL) ->
- return ObjectNil
- (#const MSGPACK_OBJECT_BOOLEAN) ->
- peekObjectBool ptr
- (#const MSGPACK_OBJECT_POSITIVE_INTEGER) ->
- peekObjectPositiveInteger ptr
- (#const MSGPACK_OBJECT_NEGATIVE_INTEGER) ->
- peekObjectNegativeInteger ptr
- (#const MSGPACK_OBJECT_DOUBLE) ->
- peekObjectDouble ptr
- (#const MSGPACK_OBJECT_RAW) ->
- peekObjectRAW ptr
- (#const MSGPACK_OBJECT_ARRAY) ->
- peekObjectArray ptr
- (#const MSGPACK_OBJECT_MAP) ->
- peekObjectMap ptr
- _ ->
- fail $ "peekObject: unknown object type (" ++ show typ ++ ")"
-
-peekObjectBool :: Ptr a -> IO Object
-peekObjectBool ptr = do
- b <- (#peek msgpack_object, via.boolean) ptr
- return $ ObjectBool $ (b :: CUChar) /= 0
-
-peekObjectPositiveInteger :: Ptr a -> IO Object
-peekObjectPositiveInteger ptr = do
- n <- (#peek msgpack_object, via.u64) ptr
- return $ ObjectInteger $ fromIntegral (n :: Word64)
-
-peekObjectNegativeInteger :: Ptr a -> IO Object
-peekObjectNegativeInteger ptr = do
- n <- (#peek msgpack_object, via.i64) ptr
- return $ ObjectInteger $ fromIntegral (n :: Int64)
-
-peekObjectDouble :: Ptr a -> IO Object
-peekObjectDouble ptr = do
- d <- (#peek msgpack_object, via.dec) ptr
- return $ ObjectDouble $ realToFrac (d :: CDouble)
-
-peekObjectRAW :: Ptr a -> IO Object
-peekObjectRAW ptr = do
- size <- (#peek msgpack_object, via.raw.size) ptr
- p <- (#peek msgpack_object, via.raw.ptr) ptr
- bs <- BS.packCStringLen (p, fromIntegral (size :: Word32))
- return $ ObjectRAW bs
-
-peekObjectArray :: Ptr a -> IO Object
-peekObjectArray ptr = do
- csize <- (#peek msgpack_object, via.array.size) ptr
- let size = fromIntegral (csize :: Word32)
- p <- (#peek msgpack_object, via.array.ptr) ptr
- objs <- mapM (\i -> peekObject $ p `plusPtr`
- ((#size msgpack_object) * i))
- [0..size-1]
- return $ ObjectArray objs
-
-peekObjectMap :: Ptr a -> IO Object
-peekObjectMap ptr = do
- csize <- (#peek msgpack_object, via.map.size) ptr
- let size = fromIntegral (csize :: Word32)
- p <- (#peek msgpack_object, via.map.ptr) ptr
- dat <- mapM (\i -> peekObjectKV $ p `plusPtr`
- ((#size msgpack_object_kv) * i))
- [0..size-1]
- return $ ObjectMap dat
-
-peekObjectKV :: Ptr a -> IO (Object, Object)
-peekObjectKV ptr = do
- k <- peekObject $ ptr `plusPtr` (#offset msgpack_object_kv, key)
- v <- peekObject $ ptr `plusPtr` (#offset msgpack_object_kv, val)
- return (k, v)
-
--- | Pack a Object.
-packObject :: Packer -> Object -> IO ()
-packObject pc ObjectNil = packNil pc >> return ()
-
-packObject pc (ObjectBool b) = packBool pc b >> return ()
-
-packObject pc (ObjectInteger n) = packInt pc n >> return ()
-
-packObject pc (ObjectDouble d) = packDouble pc d >> return ()
-
-packObject pc (ObjectRAW bs) = packRAW' pc bs >> return ()
-
-packObject pc (ObjectArray ls) = do
- _ <- packArray pc (length ls)
- mapM_ (packObject pc) ls
-
-packObject pc (ObjectMap ls) = do
- _ <- packMap pc (length ls)
- mapM_ (\(a, b) -> packObject pc a >> packObject pc b) ls
-
-data UnpackReturn =
- UnpackContinue -- ^ not enough bytes to unpack object
- | UnpackParseError -- ^ got invalid bytes
- | UnpackError -- ^ other error
- deriving (Eq, Show)
-
--- | Unpack a single MessagePack object from byte sequence.
-unpackObject :: Zone -> ByteString -> IO (Either UnpackReturn (Int, Object))
-unpackObject z dat =
- allocaBytes (#size msgpack_object) $ \ptr ->
- BS.useAsCStringLen dat $ \(str, len) ->
- alloca $ \poff -> do
- poke poff 0
- ret <- msgpack_unpack str (fromIntegral len) poff z ptr
- case ret of
- (#const MSGPACK_UNPACK_SUCCESS) -> do
- off <- peek poff
- obj <- peekObject ptr
- return $ Right (fromIntegral off, obj)
- (#const MSGPACK_UNPACK_EXTRA_BYTES) -> do
- off <- peek poff
- obj <- peekObject ptr
- return $ Right (fromIntegral off, obj)
- (#const MSGPACK_UNPACK_CONTINUE) ->
- return $ Left UnpackContinue
- (#const MSGPACK_UNPACK_PARSE_ERROR) ->
- return $ Left UnpackParseError
- _ ->
- return $ Left UnpackError
-
-foreign import ccall "msgpack_unpack" msgpack_unpack ::
- Ptr CChar -> CSize -> Ptr CSize -> Zone -> Ptr () -> IO CInt
diff --git a/haskell/src/Data/MessagePack/Feed.hs b/haskell/src/Data/MessagePack/Feed.hs
deleted file mode 100644
index 4b486396..00000000
--- a/haskell/src/Data/MessagePack/Feed.hs
+++ /dev/null
@@ -1,62 +0,0 @@
---------------------------------------------------------------------
--- |
--- Module : Data.MessagePack.Feed
--- Copyright : (c) Hideyuki Tanaka, 2009
--- License : BSD3
---
--- Maintainer: tanaka.hideyuki@gmail.com
--- Stability : experimental
--- Portability: portable
---
--- Feeders for Stream Deserializers
---
---------------------------------------------------------------------
-
-module Data.MessagePack.Feed(
- -- * Feeder type
- Feeder,
- -- * Feeders
- feederFromHandle,
- feederFromFile,
- feederFromString,
- ) where
-
-import Data.ByteString (ByteString)
-import qualified Data.ByteString as BS
-import Data.IORef
-import System.IO
-
--- | Feeder returns Just ByteString when bytes remains, otherwise Nothing.
-type Feeder = IO (Maybe ByteString)
-
--- | Feeder from Handle
-feederFromHandle :: Handle -> IO Feeder
-feederFromHandle h = return $ do
- bs <- BS.hGetNonBlocking h bufSize
- if BS.length bs > 0
- then do return $ Just bs
- else do
- c <- BS.hGet h 1
- if BS.length c > 0
- then do return $ Just c
- else do
- hClose h
- return Nothing
- where
- bufSize = 4096
-
--- | Feeder from File
-feederFromFile :: FilePath -> IO Feeder
-feederFromFile path =
- openFile path ReadMode >>= feederFromHandle
-
--- | Feeder from ByteString
-feederFromString :: ByteString -> IO Feeder
-feederFromString bs = do
- r <- newIORef (Just bs)
- return $ f r
- where
- f r = do
- mb <- readIORef r
- writeIORef r Nothing
- return mb
diff --git a/haskell/src/Data/MessagePack/Monad.hs b/haskell/src/Data/MessagePack/Monad.hs
deleted file mode 100644
index 15f21fe0..00000000
--- a/haskell/src/Data/MessagePack/Monad.hs
+++ /dev/null
@@ -1,156 +0,0 @@
---------------------------------------------------------------------
--- |
--- Module : Data.MessagePack.Monad
--- Copyright : (c) Hideyuki Tanaka, 2009
--- License : BSD3
---
--- Maintainer: tanaka.hideyuki@gmail.com
--- Stability : experimental
--- Portability: portable
---
--- Monadic Stream Serializers and Deserializers
---
---------------------------------------------------------------------
-
-module Data.MessagePack.Monad(
- -- * Classes
- MonadPacker(..),
- MonadUnpacker(..),
-
- -- * Packer and Unpacker type
- PackerT(..),
- UnpackerT(..),
-
- -- * Packers
- packToString,
- packToHandle,
- packToFile,
-
- -- * Unpackers
- unpackFrom,
- unpackFromString,
- unpackFromHandle,
- unpackFromFile,
- ) where
-
-import Control.Monad
-import Control.Monad.Trans
-import Data.ByteString (ByteString)
-import qualified Data.ByteString as BS
-import System.IO
-
-import Data.MessagePack.Base hiding (Unpacker)
-import qualified Data.MessagePack.Base as Base
-import Data.MessagePack.Class
-import Data.MessagePack.Feed
-
-class Monad m => MonadPacker m where
- -- | Serialize a object
- put :: OBJECT a => a -> m ()
-
-class Monad m => MonadUnpacker m where
- -- | Deserialize a object
- get :: OBJECT a => m a
-
--- | Serializer Type
-newtype PackerT m r = PackerT { runPackerT :: Base.Packer -> m r }
-
-instance Monad m => Monad (PackerT m) where
- a >>= b =
- PackerT $ \pc -> do
- r <- runPackerT a pc
- runPackerT (b r) pc
-
- return r =
- PackerT $ \_ -> return r
-
-instance MonadTrans PackerT where
- lift m = PackerT $ \_ -> m
-
-instance MonadIO m => MonadIO (PackerT m) where
- liftIO = lift . liftIO
-
-instance MonadIO m => MonadPacker (PackerT m) where
- put v = PackerT $ \pc -> liftIO $ do
- pack pc v
-
--- | Execute given serializer and returns byte sequence.
-packToString :: MonadIO m => PackerT m r -> m ByteString
-packToString m = do
- sb <- liftIO $ newSimpleBuffer
- pc <- liftIO $ newPacker sb
- _ <- runPackerT m pc
- liftIO $ simpleBufferData sb
-
--- | Execute given serializer and write byte sequence to Handle.
-packToHandle :: MonadIO m => Handle -> PackerT m r -> m ()
-packToHandle h m = do
- sb <- packToString m
- liftIO $ BS.hPut h sb
- liftIO $ hFlush h
-
--- | Execute given serializer and write byte sequence to file.
-packToFile :: MonadIO m => FilePath -> PackerT m r -> m ()
-packToFile p m = do
- sb <- packToString m
- liftIO $ BS.writeFile p sb
-
--- | Deserializer type
-newtype UnpackerT m r = UnpackerT { runUnpackerT :: Base.Unpacker -> Feeder -> m r }
-
-instance Monad m => Monad (UnpackerT m) where
- a >>= b =
- UnpackerT $ \up feed -> do
- r <- runUnpackerT a up feed
- runUnpackerT (b r) up feed
-
- return r =
- UnpackerT $ \_ _ -> return r
-
-instance MonadTrans UnpackerT where
- lift m = UnpackerT $ \_ _ -> m
-
-instance MonadIO m => MonadIO (UnpackerT m) where
- liftIO = lift . liftIO
-
-instance MonadIO m => MonadUnpacker (UnpackerT m) where
- get = UnpackerT $ \up feed -> liftIO $ do
- executeOne up feed
- obj <- unpackerData up
- freeZone =<< unpackerReleaseZone up
- unpackerReset up
- let Right r = fromObject obj
- return r
-
- where
- executeOne up feed = do
- resp <- unpackerExecute up
- guard $ resp>=0
- when (resp==0) $ do
- Just bs <- feed
- unpackerFeed up bs
- executeOne up feed
-
--- | Execute deserializer using given feeder.
-unpackFrom :: MonadIO m => Feeder -> UnpackerT m r -> m r
-unpackFrom f m = do
- up <- liftIO $ newUnpacker defaultInitialBufferSize
- runUnpackerT m up f
-
--- | Execute deserializer using given handle.
-unpackFromHandle :: MonadIO m => Handle -> UnpackerT m r -> m r
-unpackFromHandle h m =
- flip unpackFrom m =<< liftIO (feederFromHandle h)
-
--- | Execute deserializer using given file content.
-unpackFromFile :: MonadIO m => FilePath -> UnpackerT m r -> m r
-unpackFromFile p m = do
- h <- liftIO $ openFile p ReadMode
- r <- flip unpackFrom m =<< liftIO (feederFromHandle h)
- liftIO $ hClose h
- return r
-
--- | Execute deserializer from given byte sequence.
-unpackFromString :: MonadIO m => ByteString -> UnpackerT m r -> m r
-unpackFromString bs m = do
- flip unpackFrom m =<< liftIO (feederFromString bs)
diff --git a/haskell/src/Data/MessagePack/Class.hs b/haskell/src/Data/MessagePack/Object.hs
similarity index 77%
rename from haskell/src/Data/MessagePack/Class.hs
rename to haskell/src/Data/MessagePack/Object.hs
index 365acc5f..19a3aeba 100644
--- a/haskell/src/Data/MessagePack/Class.hs
+++ b/haskell/src/Data/MessagePack/Object.hs
@@ -1,38 +1,50 @@
{-# LANGUAGE TypeSynonymInstances #-}
{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE OverlappingInstances #-}
-{-# LANGUAGE IncoherentInstances #-}
--------------------------------------------------------------------
-- |
--- Module : Data.MessagePack.Class
--- Copyright : (c) Hideyuki Tanaka, 2009
+-- Module : Data.MessagePack.Object
+-- Copyright : (c) Hideyuki Tanaka, 2009-2010
-- License : BSD3
--
-- Maintainer: tanaka.hideyuki@gmail.com
-- Stability : experimental
-- Portability: portable
--
--- Serializing Haskell values to and from MessagePack Objects.
+-- MessagePack object definition
--
--------------------------------------------------------------------
-module Data.MessagePack.Class(
+module Data.MessagePack.Object(
+ -- * MessagePack Object
+ Object(..),
+
-- * Serialization to and from Object
OBJECT(..),
Result,
- pack,
) where
-import Control.Monad.Error
-import Data.ByteString.Char8 (ByteString)
+import Control.Monad
+import Control.Monad.Trans.Error ()
+import qualified Data.ByteString as B
import qualified Data.ByteString.Char8 as C8
-import Data.MessagePack.Base
+-- | Object Representation of MessagePack data.
+data Object =
+ ObjectNil
+ | ObjectBool Bool
+ | ObjectInteger Int
+ | ObjectDouble Double
+ | ObjectRAW B.ByteString
+ | ObjectArray [Object]
+ | ObjectMap [(Object, Object)]
+ deriving (Show)
-- | The class of types serializable to and from MessagePack object
class OBJECT a where
+ -- | Encode a value to MessagePack object
toObject :: a -> Object
+ -- | Decode a value from MessagePack object
fromObject :: Object -> Result a
-- | A type for parser results
@@ -65,7 +77,7 @@ instance OBJECT Double where
fromObject (ObjectDouble d) = Right d
fromObject _ = Left fromObjectError
-instance OBJECT ByteString where
+instance OBJECT B.ByteString where
toObject = ObjectRAW
fromObject (ObjectRAW bs) = Right bs
fromObject _ = Left fromObjectError
@@ -95,7 +107,3 @@ instance OBJECT a => OBJECT (Maybe a) where
fromObject ObjectNil = return Nothing
fromObject obj = liftM Just $ fromObject obj
-
--- | Pack a serializable Haskell value.
-pack :: OBJECT a => Packer -> a -> IO ()
-pack pc = packObject pc . toObject
diff --git a/haskell/src/Data/MessagePack/Packer.hs b/haskell/src/Data/MessagePack/Packer.hs
new file mode 100644
index 00000000..9c10f5ed
--- /dev/null
+++ b/haskell/src/Data/MessagePack/Packer.hs
@@ -0,0 +1,147 @@
+{-# Language FlexibleInstances #-}
+{-# Language OverlappingInstances #-}
+
+module Data.MessagePack.Packer(
+ ObjectPut(..),
+ ) where
+
+import Data.Binary.Put
+import Data.Binary.IEEE754
+import Data.Bits
+import qualified Data.ByteString as B
+
+import Data.MessagePack.Object
+
+class ObjectPut a where
+ put :: a -> Put
+
+instance ObjectPut Object where
+ put = putObject
+
+instance ObjectPut Int where
+ put = putInteger
+
+instance ObjectPut () where
+ put _ = putNil
+
+instance ObjectPut Bool where
+ put = putBool
+
+instance ObjectPut Double where
+ put = putDouble
+
+instance ObjectPut B.ByteString where
+ put = putRAW
+
+instance ObjectPut a => ObjectPut [a] where
+ put = putArray
+
+instance (ObjectPut k, ObjectPut v) => ObjectPut [(k, v)] where
+ put = putMap
+
+putObject :: Object -> Put
+putObject obj =
+ case obj of
+ ObjectInteger n ->
+ putInteger n
+ ObjectNil ->
+ putNil
+ ObjectBool b ->
+ putBool b
+ ObjectDouble d ->
+ putDouble d
+ ObjectRAW raw ->
+ putRAW raw
+ ObjectArray arr ->
+ putArray arr
+ ObjectMap m ->
+ putMap m
+
+putInteger :: Int -> Put
+putInteger n =
+ case n of
+ _ | n >= 0 && n <= 127 ->
+ putWord8 $ fromIntegral n
+ _ | n >= -32 && n <= -1 ->
+ putWord8 $ fromIntegral n
+ _ | n >= 0 && n < 0x100 -> do
+ putWord8 0xCC
+ putWord8 $ fromIntegral n
+ _ | n >= 0 && n < 0x10000 -> do
+ putWord8 0xCD
+ putWord16be $ fromIntegral n
+ _ | n >= 0 && n < 0x100000000 -> do
+ putWord8 0xCE
+ putWord32be $ fromIntegral n
+ _ | n >= 0 -> do
+ putWord8 0xCF
+ putWord64be $ fromIntegral n
+ _ | n >= -0x100 -> do
+ putWord8 0xD0
+ putWord8 $ fromIntegral n
+ _ | n >= -0x10000 -> do
+ putWord8 0xD1
+ putWord16be $ fromIntegral n
+ _ | n >= -0x100000000 -> do
+ putWord8 0xD2
+ putWord32be $ fromIntegral n
+ _ -> do
+ putWord8 0xD3
+ putWord64be $ fromIntegral n
+
+putNil :: Put
+putNil = putWord8 0xC0
+
+putBool :: Bool -> Put
+putBool True = putWord8 0xC3
+putBool False = putWord8 0xC2
+
+putDouble :: Double -> Put
+putDouble d = do
+ putWord8 0xCB
+ putFloat64be d
+
+putRAW :: B.ByteString -> Put
+putRAW bs = do
+ case len of
+ _ | len <= 31 -> do
+ putWord8 $ 0xA0 .|. fromIntegral len
+ _ | len < 0x10000 -> do
+ putWord8 0xDA
+ putWord16be $ fromIntegral len
+ _ -> do
+ putWord8 0xDB
+ putWord32be $ fromIntegral len
+ putByteString bs
+ where
+ len = B.length bs
+
+putArray :: ObjectPut a => [a] -> Put
+putArray arr = do
+ case len of
+ _ | len <= 15 ->
+ putWord8 $ 0x90 .|. fromIntegral len
+ _ | len < 0x10000 -> do
+ putWord8 0xDC
+ putWord16be $ fromIntegral len
+ _ -> do
+ putWord8 0xDD
+ putWord32be $ fromIntegral len
+ mapM_ put arr
+ where
+ len = length arr
+
+putMap :: (ObjectPut k, ObjectPut v) => [(k, v)] -> Put
+putMap m = do
+ case len of
+ _ | len <= 15 ->
+ putWord8 $ 0x80 .|. fromIntegral len
+ _ | len < 0x10000 -> do
+ putWord8 0xDE
+ putWord16be $ fromIntegral len
+ _ -> do
+ putWord8 0xDF
+ putWord16be $ fromIntegral len
+ mapM_ (\(k, v) -> put k >> put v) m
+ where
+ len = length m
diff --git a/haskell/src/Data/MessagePack/Put.hs b/haskell/src/Data/MessagePack/Put.hs
new file mode 100644
index 00000000..8d0af2b2
--- /dev/null
+++ b/haskell/src/Data/MessagePack/Put.hs
@@ -0,0 +1,202 @@
+{-# Language FlexibleInstances #-}
+{-# Language IncoherentInstances #-}
+{-# Language OverlappingInstances #-}
+
+--------------------------------------------------------------------
+-- |
+-- Module : Data.MessagePack.Put
+-- Copyright : (c) Hideyuki Tanaka, 2009-2010
+-- License : BSD3
+--
+-- Maintainer: tanaka.hideyuki@gmail.com
+-- Stability : experimental
+-- Portability: portable
+--
+-- MessagePack Serializer using @Data.Binary.Put@
+--
+--------------------------------------------------------------------
+
+module Data.MessagePack.Put(
+ -- * Serializable class
+ ObjectPut(..),
+ ) where
+
+import Data.Binary.Put
+import Data.Binary.IEEE754
+import Data.Bits
+import qualified Data.ByteString as B
+import qualified Data.Vector as V
+
+import Data.MessagePack.Object
+
+-- | Serializable class
+class ObjectPut a where
+ -- | Serialize a value
+ put :: a -> Put
+
+instance ObjectPut Object where
+ put = putObject
+
+instance ObjectPut Int where
+ put = putInteger
+
+instance ObjectPut () where
+ put _ = putNil
+
+instance ObjectPut Bool where
+ put = putBool
+
+instance ObjectPut Double where
+ put = putDouble
+
+instance ObjectPut B.ByteString where
+ put = putRAW
+
+instance ObjectPut a => ObjectPut [a] where
+ put = putArray
+
+instance ObjectPut a => ObjectPut (V.Vector a) where
+ put = putArrayVector
+
+instance (ObjectPut k, ObjectPut v) => ObjectPut [(k, v)] where
+ put = putMap
+
+instance (ObjectPut k, ObjectPut v) => ObjectPut (V.Vector (k, v)) where
+ put = putMapVector
+
+putObject :: Object -> Put
+putObject obj =
+ case obj of
+ ObjectInteger n ->
+ putInteger n
+ ObjectNil ->
+ putNil
+ ObjectBool b ->
+ putBool b
+ ObjectDouble d ->
+ putDouble d
+ ObjectRAW raw ->
+ putRAW raw
+ ObjectArray arr ->
+ putArray arr
+ ObjectMap m ->
+ putMap m
+
+putInteger :: Int -> Put
+putInteger n =
+ case n of
+ _ | n >= 0 && n <= 127 ->
+ putWord8 $ fromIntegral n
+ _ | n >= -32 && n <= -1 ->
+ putWord8 $ fromIntegral n
+ _ | n >= 0 && n < 0x100 -> do
+ putWord8 0xCC
+ putWord8 $ fromIntegral n
+ _ | n >= 0 && n < 0x10000 -> do
+ putWord8 0xCD
+ putWord16be $ fromIntegral n
+ _ | n >= 0 && n < 0x100000000 -> do
+ putWord8 0xCE
+ putWord32be $ fromIntegral n
+ _ | n >= 0 -> do
+ putWord8 0xCF
+ putWord64be $ fromIntegral n
+ _ | n >= -0x80 -> do
+ putWord8 0xD0
+ putWord8 $ fromIntegral n
+ _ | n >= -0x8000 -> do
+ putWord8 0xD1
+ putWord16be $ fromIntegral n
+ _ | n >= -0x80000000 -> do
+ putWord8 0xD2
+ putWord32be $ fromIntegral n
+ _ -> do
+ putWord8 0xD3
+ putWord64be $ fromIntegral n
+
+putNil :: Put
+putNil = putWord8 0xC0
+
+putBool :: Bool -> Put
+putBool True = putWord8 0xC3
+putBool False = putWord8 0xC2
+
+putDouble :: Double -> Put
+putDouble d = do
+ putWord8 0xCB
+ putFloat64be d
+
+putRAW :: B.ByteString -> Put
+putRAW bs = do
+ case len of
+ _ | len <= 31 -> do
+ putWord8 $ 0xA0 .|. fromIntegral len
+ _ | len < 0x10000 -> do
+ putWord8 0xDA
+ putWord16be $ fromIntegral len
+ _ -> do
+ putWord8 0xDB
+ putWord32be $ fromIntegral len
+ putByteString bs
+ where
+ len = B.length bs
+
+putArray :: ObjectPut a => [a] -> Put
+putArray arr = do
+ case len of
+ _ | len <= 15 ->
+ putWord8 $ 0x90 .|. fromIntegral len
+ _ | len < 0x10000 -> do
+ putWord8 0xDC
+ putWord16be $ fromIntegral len
+ _ -> do
+ putWord8 0xDD
+ putWord32be $ fromIntegral len
+ mapM_ put arr
+ where
+ len = length arr
+
+putArrayVector :: ObjectPut a => V.Vector a -> Put
+putArrayVector arr = do
+ case len of
+ _ | len <= 15 ->
+ putWord8 $ 0x90 .|. fromIntegral len
+ _ | len < 0x10000 -> do
+ putWord8 0xDC
+ putWord16be $ fromIntegral len
+ _ -> do
+ putWord8 0xDD
+ putWord32be $ fromIntegral len
+ V.mapM_ put arr
+ where
+ len = V.length arr
+
+putMap :: (ObjectPut k, ObjectPut v) => [(k, v)] -> Put
+putMap m = do
+ case len of
+ _ | len <= 15 ->
+ putWord8 $ 0x80 .|. fromIntegral len
+ _ | len < 0x10000 -> do
+ putWord8 0xDE
+ putWord16be $ fromIntegral len
+ _ -> do
+ putWord8 0xDF
+ putWord32be $ fromIntegral len
+ mapM_ (\(k, v) -> put k >> put v) m
+ where
+ len = length m
+
+putMapVector :: (ObjectPut k, ObjectPut v) => V.Vector (k, v) -> Put
+putMapVector m = do
+ case len of
+ _ | len <= 15 ->
+ putWord8 $ 0x80 .|. fromIntegral len
+ _ | len < 0x10000 -> do
+ putWord8 0xDE
+ putWord16be $ fromIntegral len
+ _ -> do
+ putWord8 0xDF
+ putWord32be $ fromIntegral len
+ V.mapM_ (\(k, v) -> put k >> put v) m
+ where
+ len = V.length m
diff --git a/haskell/src/Data/MessagePack/Stream.hs b/haskell/src/Data/MessagePack/Stream.hs
deleted file mode 100644
index c56fe8d4..00000000
--- a/haskell/src/Data/MessagePack/Stream.hs
+++ /dev/null
@@ -1,82 +0,0 @@
---------------------------------------------------------------------
--- |
--- Module : Data.MessagePack.Stream
--- Copyright : (c) Hideyuki Tanaka, 2009
--- License : BSD3
---
--- Maintainer: tanaka.hideyuki@gmail.com
--- Stability : experimental
--- Portability: portable
---
--- Lazy Stream Serializers and Deserializers
---
---------------------------------------------------------------------
-
-module Data.MessagePack.Stream(
- unpackObjects,
- unpackObjectsFromFile,
- unpackObjectsFromHandle,
- unpackObjectsFromString,
- ) where
-
-import Data.ByteString (ByteString)
-import System.IO
-import System.IO.Unsafe
-
-import Data.MessagePack.Base
-import Data.MessagePack.Feed
-
--- | Unpack objects using given feeder.
-unpackObjects :: Feeder -> IO [Object]
-unpackObjects feeder = do
- up <- newUnpacker defaultInitialBufferSize
- f up
- where
- f up = unsafeInterleaveIO $ do
- mbo <- unpackOnce up
- case mbo of
- Just o -> do
- os <- f up
- return $ o:os
- Nothing ->
- return []
-
- unpackOnce up = do
- resp <- unpackerExecute up
- case resp of
- 0 -> do
- r <- feedOnce up
- if r
- then unpackOnce up
- else return Nothing
- 1 -> do
- obj <- unpackerData up
- freeZone =<< unpackerReleaseZone up
- unpackerReset up
- return $ Just obj
- _ ->
- error $ "unpackerExecute fails: " ++ show resp
-
- feedOnce up = do
- dat <- feeder
- case dat of
- Nothing ->
- return False
- Just bs -> do
- unpackerFeed up bs
- return True
-
--- | Unpack objects from file.
-unpackObjectsFromFile :: FilePath -> IO [Object]
-unpackObjectsFromFile fname =
- unpackObjects =<< feederFromFile fname
-
--- | Unpack objects from handle.
-unpackObjectsFromHandle :: Handle -> IO [Object]
-unpackObjectsFromHandle h =
- unpackObjects =<< feederFromHandle h
-
--- | Unpack oobjects from given byte sequence.
-unpackObjectsFromString :: ByteString -> IO [Object]
-unpackObjectsFromString bs =
- unpackObjects =<< feederFromString bs
diff --git a/haskell/test/Monad.hs b/haskell/test/Monad.hs
index 4bee5c54..2ec40938 100644
--- a/haskell/test/Monad.hs
+++ b/haskell/test/Monad.hs
@@ -1,16 +1,21 @@
-import Control.Monad.Trans
+{-# Language OverloadedStrings #-}
+
+import Control.Monad.IO.Class
+import qualified Data.ByteString as B
import Data.MessagePack
main = do
- sb <- packToString $ do
+ sb <- return $ packToString $ do
put [1,2,3::Int]
put (3.14 :: Double)
- put "Hoge"
+ put ("Hoge" :: B.ByteString)
print sb
- unpackFromString sb $ do
+ r <- unpackFromString sb $ do
arr <- get
dbl <- get
str <- get
- liftIO $ print (arr :: [Int], dbl :: Double, str :: String)
+ return (arr :: [Int], dbl :: Double, str :: B.ByteString)
+
+ print r
diff --git a/haskell/test/Stream.hs b/haskell/test/Stream.hs
deleted file mode 100644
index ce060dea..00000000
--- a/haskell/test/Stream.hs
+++ /dev/null
@@ -1,14 +0,0 @@
-import Control.Applicative
-import qualified Data.ByteString as BS
-import Data.MessagePack
-
-main = do
- sb <- newSimpleBuffer
- pc <- newPacker sb
- pack pc [1,2,3::Int]
- pack pc True
- pack pc "hoge"
- bs <- simpleBufferData sb
-
- os <- unpackObjectsFromString bs
- mapM_ print os
diff --git a/haskell/test/Test.hs b/haskell/test/Test.hs
index 4e713ba6..1bb551c1 100644
--- a/haskell/test/Test.hs
+++ b/haskell/test/Test.hs
@@ -1,36 +1,45 @@
+import Test.Framework
+import Test.Framework.Providers.QuickCheck2
+import Test.QuickCheck
+
import Control.Monad
+import qualified Data.ByteString.Char8 as B
import Data.MessagePack
-{-
-main = do
- sb <- newSimpleBuffer
- pc <- newPacker sb
-
- pack pc [(1,2),(2,3),(3::Int,4::Int)]
- pack pc [4,5,6::Int]
- pack pc "hoge"
-
- bs <- simpleBufferData sb
- print bs
-
- up <- newUnpacker defaultInitialBufferSize
-
- unpackerFeed up bs
+mid :: (ObjectGet a, ObjectPut a) => a -> a
+mid = unpack . pack
- let f = do
- res <- unpackerExecute up
- when (res==1) $ do
- obj <- unpackerData up
- print obj
- f
-
- f
+prop_mid_int a = a == mid a
+ where types = a :: Int
+prop_mid_nil a = a == mid a
+ where types = a :: ()
+prop_mid_bool a = a == mid a
+ where types = a :: Bool
+prop_mid_double a = a == mid a
+ where types = a :: Double
+prop_mid_string a = a == B.unpack (mid (B.pack a))
+ where types = a :: String
+prop_mid_array_int a = a == mid a
+ where types = a :: [Int]
+prop_mid_array_string a = a == map B.unpack (mid (map B.pack a))
+ where types = a :: [String]
+prop_mid_map_int_double a = a == mid a
+ where types = a :: [(Int, Double)]
+prop_mid_map_string_string a = a == map (\(x, y) -> (B.unpack x, B.unpack y)) (mid (map (\(x, y) -> (B.pack x, B.pack y)) a))
+ where types = a :: [(String, String)]
- return ()
--}
+tests =
+ [ testGroup "simple"
+ [ testProperty "int" prop_mid_int
+ , testProperty "nil" prop_mid_nil
+ , testProperty "bool" prop_mid_bool
+ , testProperty "double" prop_mid_double
+ , testProperty "string" prop_mid_string
+ , testProperty "[int]" prop_mid_array_int
+ , testProperty "[string]" prop_mid_array_string
+ , testProperty "[(int, double)]" prop_mid_map_int_double
+ , testProperty "[(string, string)]" prop_mid_map_string_string
+ ]
+ ]
-main = do
- bs <- packb [(1,2),(2,3),(3::Int,4::Int)]
- print bs
- dat <- unpackb bs
- print (dat :: Result [(Int, Int)])
+main = defaultMain tests
From 0368a70dd70a91598507bc7baad8291adc1309fa Mon Sep 17 00:00:00 2001
From: tanakh <tanaka.hideyuki@gmail.com>
Date: Mon, 6 Sep 2010 13:55:34 +0900
Subject: [PATCH 18/43] forgot to add file
---
haskell/src/Data/MessagePack/Parser.hs | 259 +++++++++++++++++++++++++
1 file changed, 259 insertions(+)
create mode 100644 haskell/src/Data/MessagePack/Parser.hs
diff --git a/haskell/src/Data/MessagePack/Parser.hs b/haskell/src/Data/MessagePack/Parser.hs
new file mode 100644
index 00000000..d0cd0846
--- /dev/null
+++ b/haskell/src/Data/MessagePack/Parser.hs
@@ -0,0 +1,259 @@
+{-# Language FlexibleInstances #-}
+{-# Language IncoherentInstances #-}
+{-# Language OverlappingInstances #-}
+
+--------------------------------------------------------------------
+-- |
+-- Module : Data.MessagePack.Parser
+-- Copyright : (c) Hideyuki Tanaka, 2009-2010
+-- License : BSD3
+--
+-- Maintainer: tanaka.hideyuki@gmail.com
+-- Stability : experimental
+-- Portability: portable
+--
+-- MessagePack Deserializer using @Data.Attoparsec@
+--
+--------------------------------------------------------------------
+
+module Data.MessagePack.Parser(
+ -- * MessagePack deserializer
+ ObjectGet(..),
+ ) where
+
+import Control.Monad
+import qualified Data.Attoparsec as A
+import Data.Binary.Get
+import Data.Binary.IEEE754
+import Data.Bits
+import qualified Data.ByteString as B
+import qualified Data.ByteString.Lazy as L
+import Data.Int
+import qualified Data.Vector as V
+import Data.Word
+import Text.Printf
+
+import Data.MessagePack.Object
+
+-- | Deserializable class
+class ObjectGet a where
+ -- | Deserialize a value
+ get :: A.Parser a
+
+instance ObjectGet Int where
+ get = parseInt
+
+instance ObjectGet () where
+ get = parseNil
+
+instance ObjectGet Bool where
+ get = parseBool
+
+instance ObjectGet Double where
+ get = parseDouble
+
+instance ObjectGet B.ByteString where
+ get = parseRAW
+
+instance ObjectGet a => ObjectGet [a] where
+ get = parseArray
+
+instance ObjectGet a => ObjectGet (V.Vector a) where
+ get = parseArrayVector
+
+instance (ObjectGet k, ObjectGet v) => ObjectGet [(k, v)] where
+ get = parseMap
+
+instance (ObjectGet k, ObjectGet v) => ObjectGet (V.Vector (k, v)) where
+ get = parseMapVector
+
+instance ObjectGet Object where
+ get = parseObject
+
+parseInt :: A.Parser Int
+parseInt = do
+ c <- A.anyWord8
+ case c of
+ _ | c .&. 0x80 == 0x00 ->
+ return $ fromIntegral c
+ _ | c .&. 0xE0 == 0xE0 ->
+ return $ fromIntegral (fromIntegral c :: Int8)
+ 0xCC ->
+ return . fromIntegral =<< A.anyWord8
+ 0xCD ->
+ return . fromIntegral =<< parseUint16
+ 0xCE ->
+ return . fromIntegral =<< parseUint32
+ 0xCF ->
+ return . fromIntegral =<< parseUint64
+ 0xD0 ->
+ return . fromIntegral =<< parseInt8
+ 0xD1 ->
+ return . fromIntegral =<< parseInt16
+ 0xD2 ->
+ return . fromIntegral =<< parseInt32
+ 0xD3 ->
+ return . fromIntegral =<< parseInt64
+ _ ->
+ fail $ printf "invlid integer tag: 0x%02X" c
+
+parseNil :: A.Parser ()
+parseNil = do
+ _ <- A.word8 0xC0
+ return ()
+
+parseBool :: A.Parser Bool
+parseBool = do
+ c <- A.anyWord8
+ case c of
+ 0xC3 ->
+ return True
+ 0xC2 ->
+ return False
+ _ ->
+ fail $ printf "invlid bool tag: 0x%02X" c
+
+parseDouble :: A.Parser Double
+parseDouble = do
+ c <- A.anyWord8
+ case c of
+ 0xCA ->
+ return . realToFrac . runGet getFloat32be . toLBS =<< A.take 4
+ 0xCB ->
+ return . runGet getFloat64be . toLBS =<< A.take 8
+ _ ->
+ fail $ printf "invlid double tag: 0x%02X" c
+
+parseRAW :: A.Parser B.ByteString
+parseRAW = do
+ c <- A.anyWord8
+ case c of
+ _ | c .&. 0xE0 == 0xA0 ->
+ A.take . fromIntegral $ c .&. 0x1F
+ 0xDA ->
+ A.take . fromIntegral =<< parseUint16
+ 0xDB ->
+ A.take . fromIntegral =<< parseUint32
+ _ ->
+ fail $ printf "invlid raw tag: 0x%02X" c
+
+parseArray :: ObjectGet a => A.Parser [a]
+parseArray = do
+ c <- A.anyWord8
+ case c of
+ _ | c .&. 0xF0 == 0x90 ->
+ flip replicateM get . fromIntegral $ c .&. 0x0F
+ 0xDC ->
+ flip replicateM get . fromIntegral =<< parseUint16
+ 0xDD ->
+ flip replicateM get . fromIntegral =<< parseUint32
+ _ ->
+ fail $ printf "invlid array tag: 0x%02X" c
+
+parseArrayVector :: ObjectGet a => A.Parser (V.Vector a)
+parseArrayVector = do
+ c <- A.anyWord8
+ case c of
+ _ | c .&. 0xF0 == 0x90 ->
+ flip V.replicateM get . fromIntegral $ c .&. 0x0F
+ 0xDC ->
+ flip V.replicateM get . fromIntegral =<< parseUint16
+ 0xDD ->
+ flip V.replicateM get . fromIntegral =<< parseUint32
+ _ ->
+ fail $ printf "invlid array tag: 0x%02X" c
+
+parseMap :: (ObjectGet k, ObjectGet v) => A.Parser [(k, v)]
+parseMap = do
+ c <- A.anyWord8
+ case c of
+ _ | c .&. 0xF0 == 0x80 ->
+ flip replicateM parsePair . fromIntegral $ c .&. 0x0F
+ 0xDE ->
+ flip replicateM parsePair . fromIntegral =<< parseUint16
+ 0xDF ->
+ flip replicateM parsePair . fromIntegral =<< parseUint32
+ _ ->
+ fail $ printf "invlid map tag: 0x%02X" c
+
+parseMapVector :: (ObjectGet k, ObjectGet v) => A.Parser (V.Vector (k, v))
+parseMapVector = do
+ c <- A.anyWord8
+ case c of
+ _ | c .&. 0xF0 == 0x80 ->
+ flip V.replicateM parsePair . fromIntegral $ c .&. 0x0F
+ 0xDE ->
+ flip V.replicateM parsePair . fromIntegral =<< parseUint16
+ 0xDF ->
+ flip V.replicateM parsePair . fromIntegral =<< parseUint32
+ _ ->
+ fail $ printf "invlid map tag: 0x%02X" c
+
+parseObject :: A.Parser Object
+parseObject =
+ A.choice
+ [ liftM ObjectInteger parseInt
+ , liftM (const ObjectNil) parseNil
+ , liftM ObjectBool parseBool
+ , liftM ObjectDouble parseDouble
+ , liftM ObjectRAW parseRAW
+ , liftM ObjectArray parseArray
+ , liftM ObjectMap parseMap
+ ]
+
+parsePair :: (ObjectGet k, ObjectGet v) => A.Parser (k, v)
+parsePair = do
+ a <- get
+ b <- get
+ return (a, b)
+
+parseUint16 :: A.Parser Word16
+parseUint16 = do
+ b0 <- A.anyWord8
+ b1 <- A.anyWord8
+ return $ (fromIntegral b0 `shiftL` 8) .|. fromIntegral b1
+
+parseUint32 :: A.Parser Word32
+parseUint32 = do
+ b0 <- A.anyWord8
+ b1 <- A.anyWord8
+ b2 <- A.anyWord8
+ b3 <- A.anyWord8
+ return $ (fromIntegral b0 `shiftL` 24) .|.
+ (fromIntegral b1 `shiftL` 16) .|.
+ (fromIntegral b2 `shiftL` 8) .|.
+ fromIntegral b3
+
+parseUint64 :: A.Parser Word64
+parseUint64 = do
+ b0 <- A.anyWord8
+ b1 <- A.anyWord8
+ b2 <- A.anyWord8
+ b3 <- A.anyWord8
+ b4 <- A.anyWord8
+ b5 <- A.anyWord8
+ b6 <- A.anyWord8
+ b7 <- A.anyWord8
+ return $ (fromIntegral b0 `shiftL` 56) .|.
+ (fromIntegral b1 `shiftL` 48) .|.
+ (fromIntegral b2 `shiftL` 40) .|.
+ (fromIntegral b3 `shiftL` 32) .|.
+ (fromIntegral b4 `shiftL` 24) .|.
+ (fromIntegral b5 `shiftL` 16) .|.
+ (fromIntegral b6 `shiftL` 8) .|.
+ fromIntegral b7
+
+parseInt8 :: A.Parser Int8
+parseInt8 = return . fromIntegral =<< A.anyWord8
+
+parseInt16 :: A.Parser Int16
+parseInt16 = return . fromIntegral =<< parseUint16
+
+parseInt32 :: A.Parser Int32
+parseInt32 = return . fromIntegral =<< parseUint32
+
+parseInt64 :: A.Parser Int64
+parseInt64 = return . fromIntegral =<< parseUint64
+
+toLBS :: B.ByteString -> L.ByteString
+toLBS bs = L.fromChunks [bs]
From 209d8d058c17b1ee92f13942a804eb2868191118 Mon Sep 17 00:00:00 2001
From: tanakh <tanaka.hideyuki@gmail.com>
Date: Mon, 6 Sep 2010 13:57:47 +0900
Subject: [PATCH 19/43] forgot to remove file
---
haskell/src/Data/MessagePack/Packer.hs | 147 -------------------------
1 file changed, 147 deletions(-)
delete mode 100644 haskell/src/Data/MessagePack/Packer.hs
diff --git a/haskell/src/Data/MessagePack/Packer.hs b/haskell/src/Data/MessagePack/Packer.hs
deleted file mode 100644
index 9c10f5ed..00000000
--- a/haskell/src/Data/MessagePack/Packer.hs
+++ /dev/null
@@ -1,147 +0,0 @@
-{-# Language FlexibleInstances #-}
-{-# Language OverlappingInstances #-}
-
-module Data.MessagePack.Packer(
- ObjectPut(..),
- ) where
-
-import Data.Binary.Put
-import Data.Binary.IEEE754
-import Data.Bits
-import qualified Data.ByteString as B
-
-import Data.MessagePack.Object
-
-class ObjectPut a where
- put :: a -> Put
-
-instance ObjectPut Object where
- put = putObject
-
-instance ObjectPut Int where
- put = putInteger
-
-instance ObjectPut () where
- put _ = putNil
-
-instance ObjectPut Bool where
- put = putBool
-
-instance ObjectPut Double where
- put = putDouble
-
-instance ObjectPut B.ByteString where
- put = putRAW
-
-instance ObjectPut a => ObjectPut [a] where
- put = putArray
-
-instance (ObjectPut k, ObjectPut v) => ObjectPut [(k, v)] where
- put = putMap
-
-putObject :: Object -> Put
-putObject obj =
- case obj of
- ObjectInteger n ->
- putInteger n
- ObjectNil ->
- putNil
- ObjectBool b ->
- putBool b
- ObjectDouble d ->
- putDouble d
- ObjectRAW raw ->
- putRAW raw
- ObjectArray arr ->
- putArray arr
- ObjectMap m ->
- putMap m
-
-putInteger :: Int -> Put
-putInteger n =
- case n of
- _ | n >= 0 && n <= 127 ->
- putWord8 $ fromIntegral n
- _ | n >= -32 && n <= -1 ->
- putWord8 $ fromIntegral n
- _ | n >= 0 && n < 0x100 -> do
- putWord8 0xCC
- putWord8 $ fromIntegral n
- _ | n >= 0 && n < 0x10000 -> do
- putWord8 0xCD
- putWord16be $ fromIntegral n
- _ | n >= 0 && n < 0x100000000 -> do
- putWord8 0xCE
- putWord32be $ fromIntegral n
- _ | n >= 0 -> do
- putWord8 0xCF
- putWord64be $ fromIntegral n
- _ | n >= -0x100 -> do
- putWord8 0xD0
- putWord8 $ fromIntegral n
- _ | n >= -0x10000 -> do
- putWord8 0xD1
- putWord16be $ fromIntegral n
- _ | n >= -0x100000000 -> do
- putWord8 0xD2
- putWord32be $ fromIntegral n
- _ -> do
- putWord8 0xD3
- putWord64be $ fromIntegral n
-
-putNil :: Put
-putNil = putWord8 0xC0
-
-putBool :: Bool -> Put
-putBool True = putWord8 0xC3
-putBool False = putWord8 0xC2
-
-putDouble :: Double -> Put
-putDouble d = do
- putWord8 0xCB
- putFloat64be d
-
-putRAW :: B.ByteString -> Put
-putRAW bs = do
- case len of
- _ | len <= 31 -> do
- putWord8 $ 0xA0 .|. fromIntegral len
- _ | len < 0x10000 -> do
- putWord8 0xDA
- putWord16be $ fromIntegral len
- _ -> do
- putWord8 0xDB
- putWord32be $ fromIntegral len
- putByteString bs
- where
- len = B.length bs
-
-putArray :: ObjectPut a => [a] -> Put
-putArray arr = do
- case len of
- _ | len <= 15 ->
- putWord8 $ 0x90 .|. fromIntegral len
- _ | len < 0x10000 -> do
- putWord8 0xDC
- putWord16be $ fromIntegral len
- _ -> do
- putWord8 0xDD
- putWord32be $ fromIntegral len
- mapM_ put arr
- where
- len = length arr
-
-putMap :: (ObjectPut k, ObjectPut v) => [(k, v)] -> Put
-putMap m = do
- case len of
- _ | len <= 15 ->
- putWord8 $ 0x80 .|. fromIntegral len
- _ | len < 0x10000 -> do
- putWord8 0xDE
- putWord16be $ fromIntegral len
- _ -> do
- putWord8 0xDF
- putWord16be $ fromIntegral len
- mapM_ (\(k, v) -> put k >> put v) m
- where
- len = length m
From 799935e44c6f27e81d780b324dd69bdbd71066d5 Mon Sep 17 00:00:00 2001
From: tanakh <tanaka.hideyuki@gmail.com>
Date: Mon, 6 Sep 2010 14:03:47 +0900
Subject: [PATCH 20/43] haskel: incr version and update infos.
---
haskell/msgpack.cabal | 6 +++---
1 file changed, 3 insertions(+), 3 deletions(-)
diff --git a/haskell/msgpack.cabal b/haskell/msgpack.cabal
index 8346c1f8..18ae3d86 100644
--- a/haskell/msgpack.cabal
+++ b/haskell/msgpack.cabal
@@ -1,15 +1,15 @@
Name: msgpack
-Version: 0.3.0
+Version: 0.3.1
Synopsis: A Haskell binding to MessagePack
Description:
- A Haskell binding to MessagePack <http://msgpack.sourceforge.jp/>
+ A Haskell binding to MessagePack <http://msgpack.org/>
License: BSD3
License-File: LICENSE
Category: Data
Author: Hideyuki Tanaka
Maintainer: Hideyuki Tanaka <tanaka.hideyuki@gmail.com>
-Homepage: http://github.com/tanakh/hsmsgpack
+Homepage: http://github.com/msgpack/msgpack
Stability: Experimental
Tested-with: GHC == 6.12.3
Cabal-Version: >= 1.2
From 802589516870df83cf209191e234266b09b1abee Mon Sep 17 00:00:00 2001
From: tokuhirom <tokuhirom@gmail.com>
Date: Sun, 5 Sep 2010 16:20:37 +0900
Subject: [PATCH 21/43] Checking in changes prior to tagging of version
0.16_01.
Changelog diff is:
---
perl/MANIFEST.SKIP | 2 ++
perl/lib/Data/MessagePack.pm | 2 +-
2 files changed, 3 insertions(+), 1 deletion(-)
diff --git a/perl/MANIFEST.SKIP b/perl/MANIFEST.SKIP
index f6340354..71a24e5c 100644
--- a/perl/MANIFEST.SKIP
+++ b/perl/MANIFEST.SKIP
@@ -23,3 +23,5 @@
\.o$
\.bs$
^Data-MessagePack-[0-9.]+/
+^\.testenv/test_pp.pl
+^ppport.h$
diff --git a/perl/lib/Data/MessagePack.pm b/perl/lib/Data/MessagePack.pm
index d53ff226..4da67ff6 100644
--- a/perl/lib/Data/MessagePack.pm
+++ b/perl/lib/Data/MessagePack.pm
@@ -3,7 +3,7 @@ use strict;
use warnings;
use 5.008001;
-our $VERSION = '0.16';
+our $VERSION = '0.16_01';
our $PreferInteger = 0;
our $true = do { bless \(my $dummy = 1), "Data::MessagePack::Boolean" };
From e781831032c9091ab7e90bbbd9560828a8b69a30 Mon Sep 17 00:00:00 2001
From: tokuhirom <tokuhirom@gmail.com>
Date: Mon, 6 Sep 2010 14:19:31 +0900
Subject: [PATCH 22/43] upgraded docs
---
perl/README | 16 +++++++++++++---
perl/lib/Data/MessagePack.pm | 15 ++++++++++++---
2 files changed, 25 insertions(+), 6 deletions(-)
diff --git a/perl/README b/perl/README
index 31aae992..2ef686c2 100644
--- a/perl/README
+++ b/perl/README
@@ -1,12 +1,16 @@
NAME
- Data::MessagePack - messagepack
+ Data::MessagePack - MessagePack serialising/deserialising
SYNOPSIS
my $packed = Data::MessagePack->pack($dat);
my $unpacked = Data::MessagePack->unpack($dat);
DESCRIPTION
- Data::MessagePack is a binary packer for perl.
+ This module converts Perl data structures to MessagePack and vice versa.
+
+ MessagePack is a binary-based efficient object serialization format. It
+ enables to exchange structured objects between many languages like JSON.
+ But unlike JSON, it is very fast and small.
METHODS
my $packed = Data::MessagePack->pack($data);
@@ -22,13 +26,19 @@ Configuration Variables
AUTHORS
Tokuhiro Matsuno
+ Makamaka Hannyaharamitu
+
THANKS TO
Jun Kuriyama
+ Dan Kogai
+
+ FURUHASHI Sadayuki
+
LICENSE
This library is free software; you can redistribute it and/or modify it
under the same terms as Perl itself.
SEE ALSO
- <http://msgpack.sourceforge.jp/>
+ <http://msgpack.org/>
diff --git a/perl/lib/Data/MessagePack.pm b/perl/lib/Data/MessagePack.pm
index 4da67ff6..ecdc1e48 100644
--- a/perl/lib/Data/MessagePack.pm
+++ b/perl/lib/Data/MessagePack.pm
@@ -30,7 +30,7 @@ __END__
=head1 NAME
-Data::MessagePack - messagepack
+Data::MessagePack - MessagePack serialising/deserialising
=head1 SYNOPSIS
@@ -39,7 +39,10 @@ Data::MessagePack - messagepack
=head1 DESCRIPTION
-Data::MessagePack is a binary packer for perl.
+This module converts Perl data structures to MessagePack and vice versa.
+
+MessagePack is a binary-based efficient object serialization format.
+It enables to exchange structured objects between many languages like JSON. But unlike JSON, it is very fast and small.
=head1 METHODS
@@ -69,10 +72,16 @@ Pack the string as int when the value looks like int(EXPERIMENTAL).
Tokuhiro Matsuno
+Makamaka Hannyaharamitu
+
=head1 THANKS TO
Jun Kuriyama
+Dan Kogai
+
+FURUHASHI Sadayuki
+
=head1 LICENSE
This library is free software; you can redistribute it and/or modify
@@ -81,5 +90,5 @@ it under the same terms as Perl itself.
=head1 SEE ALSO
-L<http://msgpack.sourceforge.jp/>
+L<http://msgpack.org/>
From c7555f1c3c471278b320db5ca71e5afdbcb52867 Mon Sep 17 00:00:00 2001
From: tokuhirom <tokuhirom@gmail.com>
Date: Mon, 6 Sep 2010 14:31:53 +0900
Subject: [PATCH 23/43] Perl: added link to git repository.
---
perl/Makefile.PL | 2 +-
1 file changed, 1 insertion(+), 1 deletion(-)
diff --git a/perl/Makefile.PL b/perl/Makefile.PL
index 783e658d..7958bc6b 100644
--- a/perl/Makefile.PL
+++ b/perl/Makefile.PL
@@ -64,7 +64,7 @@ if($Module::Install::AUTHOR) {
postamble qq{test :: test_pp\n\n};
}
-auto_set_repository();
+repository('http://github.com/msgpack/msgpack');
auto_include;
WriteAll;
From 9281dba89672862ddf27384909264f4bd6ec12e8 Mon Sep 17 00:00:00 2001
From: tokuhirom <tokuhirom@gmail.com>
Date: Mon, 6 Sep 2010 14:34:04 +0900
Subject: [PATCH 24/43] Checking in changes prior to tagging of version
0.16_02.
Changelog diff is:
diff --git a/perl/Changes b/perl/Changes
index 9b061cf..68b58ba 100644
--- a/perl/Changes
+++ b/perl/Changes
@@ -1,3 +1,8 @@
+0.16_02
+
+ - document enhancement(tokuhirom)
+ - M::I::XSUtil 0.26 is broken. use 0.27.
+
0.16_01
- added PP version (used in cases PERL_DATA_MESSAGEPACK=pp or fail to load XS).
---
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 9b061cfb..68b58ba9 100644
--- a/perl/Changes
+++ b/perl/Changes
@@ -1,3 +1,8 @@
+0.16_02
+
+ - document enhancement(tokuhirom)
+ - M::I::XSUtil 0.26 is broken. use 0.27.
+
0.16_01
- added PP version (used in cases PERL_DATA_MESSAGEPACK=pp or fail to load XS).
diff --git a/perl/lib/Data/MessagePack.pm b/perl/lib/Data/MessagePack.pm
index ecdc1e48..79cc5311 100644
--- a/perl/lib/Data/MessagePack.pm
+++ b/perl/lib/Data/MessagePack.pm
@@ -3,7 +3,7 @@ use strict;
use warnings;
use 5.008001;
-our $VERSION = '0.16_01';
+our $VERSION = '0.16_02';
our $PreferInteger = 0;
our $true = do { bless \(my $dummy = 1), "Data::MessagePack::Boolean" };
From 8b90968cb111be903421083d8f3bebbef23e79c7 Mon Sep 17 00:00:00 2001
From: tokuhirom <tokuhirom@gmail.com>
Date: Mon, 6 Sep 2010 14:34:48 +0900
Subject: [PATCH 25/43] Checking in changes prior to tagging of version
0.16_03.
Changelog diff is:
diff --git a/perl/Changes b/perl/Changes
index 68b58ba..a4a3e36 100644
--- a/perl/Changes
+++ b/perl/Changes
@@ -1,3 +1,7 @@
+0.16_03
+
+ - no feature changes
+
0.16_02
- document enhancement(tokuhirom)
---
perl/Changes | 4 ++++
perl/lib/Data/MessagePack.pm | 2 +-
2 files changed, 5 insertions(+), 1 deletion(-)
diff --git a/perl/Changes b/perl/Changes
index 68b58ba9..a4a3e364 100644
--- a/perl/Changes
+++ b/perl/Changes
@@ -1,3 +1,7 @@
+0.16_03
+
+ - no feature changes
+
0.16_02
- document enhancement(tokuhirom)
diff --git a/perl/lib/Data/MessagePack.pm b/perl/lib/Data/MessagePack.pm
index 79cc5311..b143e4ae 100644
--- a/perl/lib/Data/MessagePack.pm
+++ b/perl/lib/Data/MessagePack.pm
@@ -3,7 +3,7 @@ use strict;
use warnings;
use 5.008001;
-our $VERSION = '0.16_02';
+our $VERSION = '0.16_03';
our $PreferInteger = 0;
our $true = do { bless \(my $dummy = 1), "Data::MessagePack::Boolean" };
From c5afe7a5739fa48d207d85403771de4a526ff437 Mon Sep 17 00:00:00 2001
From: tokuhirom <tokuhirom@gmail.com>
Date: Mon, 6 Sep 2010 14:35:41 +0900
Subject: [PATCH 26/43] Checking in changes prior to tagging of version
0.16_04.
Changelog diff is:
diff --git a/perl/Changes b/perl/Changes
index a4a3e36..7910882 100644
--- a/perl/Changes
+++ b/perl/Changes
@@ -1,4 +1,4 @@
-0.16_03
+0.16_04
- no feature changes
---
perl/Changes | 2 +-
perl/lib/Data/MessagePack.pm | 2 +-
2 files changed, 2 insertions(+), 2 deletions(-)
diff --git a/perl/Changes b/perl/Changes
index a4a3e364..79108820 100644
--- a/perl/Changes
+++ b/perl/Changes
@@ -1,4 +1,4 @@
-0.16_03
+0.16_04
- no feature changes
diff --git a/perl/lib/Data/MessagePack.pm b/perl/lib/Data/MessagePack.pm
index b143e4ae..b08bac2d 100644
--- a/perl/lib/Data/MessagePack.pm
+++ b/perl/lib/Data/MessagePack.pm
@@ -3,7 +3,7 @@ use strict;
use warnings;
use 5.008001;
-our $VERSION = '0.16_03';
+our $VERSION = '0.16_04';
our $PreferInteger = 0;
our $true = do { bless \(my $dummy = 1), "Data::MessagePack::Boolean" };
From aca2ba13c2f3ce3bc43897beb0a4a8529bab7a03 Mon Sep 17 00:00:00 2001
From: tanakh <tanaka.hideyuki@gmail.com>
Date: Mon, 6 Sep 2010 15:37:55 +0900
Subject: [PATCH 27/43] haskell: refactoring
---
haskell/src/Data/MessagePack/Parser.hs | 246 +++++++++++--------------
haskell/src/Data/MessagePack/Put.hs | 232 +++++++++--------------
2 files changed, 195 insertions(+), 283 deletions(-)
diff --git a/haskell/src/Data/MessagePack/Parser.hs b/haskell/src/Data/MessagePack/Parser.hs
index d0cd0846..312e95f3 100644
--- a/haskell/src/Data/MessagePack/Parser.hs
+++ b/haskell/src/Data/MessagePack/Parser.hs
@@ -40,166 +40,113 @@ class ObjectGet a where
-- | Deserialize a value
get :: A.Parser a
+instance ObjectGet Object where
+ get =
+ A.choice
+ [ liftM ObjectInteger get
+ , liftM (\() -> ObjectNil) get
+ , liftM ObjectBool get
+ , liftM ObjectDouble get
+ , liftM ObjectRAW get
+ , liftM ObjectArray get
+ , liftM ObjectMap get
+ ]
+
instance ObjectGet Int where
- get = parseInt
+ get = do
+ c <- A.anyWord8
+ case c of
+ _ | c .&. 0x80 == 0x00 ->
+ return $ fromIntegral c
+ _ | c .&. 0xE0 == 0xE0 ->
+ return $ fromIntegral (fromIntegral c :: Int8)
+ 0xCC ->
+ return . fromIntegral =<< A.anyWord8
+ 0xCD ->
+ return . fromIntegral =<< parseUint16
+ 0xCE ->
+ return . fromIntegral =<< parseUint32
+ 0xCF ->
+ return . fromIntegral =<< parseUint64
+ 0xD0 ->
+ return . fromIntegral =<< parseInt8
+ 0xD1 ->
+ return . fromIntegral =<< parseInt16
+ 0xD2 ->
+ return . fromIntegral =<< parseInt32
+ 0xD3 ->
+ return . fromIntegral =<< parseInt64
+ _ ->
+ fail $ printf "invlid integer tag: 0x%02X" c
instance ObjectGet () where
- get = parseNil
+ get = do
+ c <- A.anyWord8
+ case c of
+ 0xC0 ->
+ return ()
+ _ ->
+ fail $ printf "invlid nil tag: 0x%02X" c
instance ObjectGet Bool where
- get = parseBool
+ get = do
+ c <- A.anyWord8
+ case c of
+ 0xC3 ->
+ return True
+ 0xC2 ->
+ return False
+ _ ->
+ fail $ printf "invlid bool tag: 0x%02X" c
instance ObjectGet Double where
- get = parseDouble
+ get = do
+ c <- A.anyWord8
+ case c of
+ 0xCA ->
+ return . realToFrac . runGet getFloat32be . toLBS =<< A.take 4
+ 0xCB ->
+ return . runGet getFloat64be . toLBS =<< A.take 8
+ _ ->
+ fail $ printf "invlid double tag: 0x%02X" c
instance ObjectGet B.ByteString where
- get = parseRAW
+ get = do
+ c <- A.anyWord8
+ case c of
+ _ | c .&. 0xE0 == 0xA0 ->
+ A.take . fromIntegral $ c .&. 0x1F
+ 0xDA ->
+ A.take . fromIntegral =<< parseUint16
+ 0xDB ->
+ A.take . fromIntegral =<< parseUint32
+ _ ->
+ fail $ printf "invlid raw tag: 0x%02X" c
instance ObjectGet a => ObjectGet [a] where
- get = parseArray
+ get = parseArray (flip replicateM get)
instance ObjectGet a => ObjectGet (V.Vector a) where
- get = parseArrayVector
+ get = parseArray (flip V.replicateM get)
+
+parseArray :: (Int -> A.Parser a) -> A.Parser a
+parseArray aget = do
+ c <- A.anyWord8
+ case c of
+ _ | c .&. 0xF0 == 0x90 ->
+ aget . fromIntegral $ c .&. 0x0F
+ 0xDC ->
+ aget . fromIntegral =<< parseUint16
+ 0xDD ->
+ aget . fromIntegral =<< parseUint32
+ _ ->
+ fail $ printf "invlid array tag: 0x%02X" c
instance (ObjectGet k, ObjectGet v) => ObjectGet [(k, v)] where
- get = parseMap
+ get = parseMap (flip replicateM parsePair)
instance (ObjectGet k, ObjectGet v) => ObjectGet (V.Vector (k, v)) where
- get = parseMapVector
-
-instance ObjectGet Object where
- get = parseObject
-
-parseInt :: A.Parser Int
-parseInt = do
- c <- A.anyWord8
- case c of
- _ | c .&. 0x80 == 0x00 ->
- return $ fromIntegral c
- _ | c .&. 0xE0 == 0xE0 ->
- return $ fromIntegral (fromIntegral c :: Int8)
- 0xCC ->
- return . fromIntegral =<< A.anyWord8
- 0xCD ->
- return . fromIntegral =<< parseUint16
- 0xCE ->
- return . fromIntegral =<< parseUint32
- 0xCF ->
- return . fromIntegral =<< parseUint64
- 0xD0 ->
- return . fromIntegral =<< parseInt8
- 0xD1 ->
- return . fromIntegral =<< parseInt16
- 0xD2 ->
- return . fromIntegral =<< parseInt32
- 0xD3 ->
- return . fromIntegral =<< parseInt64
- _ ->
- fail $ printf "invlid integer tag: 0x%02X" c
-
-parseNil :: A.Parser ()
-parseNil = do
- _ <- A.word8 0xC0
- return ()
-
-parseBool :: A.Parser Bool
-parseBool = do
- c <- A.anyWord8
- case c of
- 0xC3 ->
- return True
- 0xC2 ->
- return False
- _ ->
- fail $ printf "invlid bool tag: 0x%02X" c
-
-parseDouble :: A.Parser Double
-parseDouble = do
- c <- A.anyWord8
- case c of
- 0xCA ->
- return . realToFrac . runGet getFloat32be . toLBS =<< A.take 4
- 0xCB ->
- return . runGet getFloat64be . toLBS =<< A.take 8
- _ ->
- fail $ printf "invlid double tag: 0x%02X" c
-
-parseRAW :: A.Parser B.ByteString
-parseRAW = do
- c <- A.anyWord8
- case c of
- _ | c .&. 0xE0 == 0xA0 ->
- A.take . fromIntegral $ c .&. 0x1F
- 0xDA ->
- A.take . fromIntegral =<< parseUint16
- 0xDB ->
- A.take . fromIntegral =<< parseUint32
- _ ->
- fail $ printf "invlid raw tag: 0x%02X" c
-
-parseArray :: ObjectGet a => A.Parser [a]
-parseArray = do
- c <- A.anyWord8
- case c of
- _ | c .&. 0xF0 == 0x90 ->
- flip replicateM get . fromIntegral $ c .&. 0x0F
- 0xDC ->
- flip replicateM get . fromIntegral =<< parseUint16
- 0xDD ->
- flip replicateM get . fromIntegral =<< parseUint32
- _ ->
- fail $ printf "invlid array tag: 0x%02X" c
-
-parseArrayVector :: ObjectGet a => A.Parser (V.Vector a)
-parseArrayVector = do
- c <- A.anyWord8
- case c of
- _ | c .&. 0xF0 == 0x90 ->
- flip V.replicateM get . fromIntegral $ c .&. 0x0F
- 0xDC ->
- flip V.replicateM get . fromIntegral =<< parseUint16
- 0xDD ->
- flip V.replicateM get . fromIntegral =<< parseUint32
- _ ->
- fail $ printf "invlid array tag: 0x%02X" c
-
-parseMap :: (ObjectGet k, ObjectGet v) => A.Parser [(k, v)]
-parseMap = do
- c <- A.anyWord8
- case c of
- _ | c .&. 0xF0 == 0x80 ->
- flip replicateM parsePair . fromIntegral $ c .&. 0x0F
- 0xDE ->
- flip replicateM parsePair . fromIntegral =<< parseUint16
- 0xDF ->
- flip replicateM parsePair . fromIntegral =<< parseUint32
- _ ->
- fail $ printf "invlid map tag: 0x%02X" c
-
-parseMapVector :: (ObjectGet k, ObjectGet v) => A.Parser (V.Vector (k, v))
-parseMapVector = do
- c <- A.anyWord8
- case c of
- _ | c .&. 0xF0 == 0x80 ->
- flip V.replicateM parsePair . fromIntegral $ c .&. 0x0F
- 0xDE ->
- flip V.replicateM parsePair . fromIntegral =<< parseUint16
- 0xDF ->
- flip V.replicateM parsePair . fromIntegral =<< parseUint32
- _ ->
- fail $ printf "invlid map tag: 0x%02X" c
-
-parseObject :: A.Parser Object
-parseObject =
- A.choice
- [ liftM ObjectInteger parseInt
- , liftM (const ObjectNil) parseNil
- , liftM ObjectBool parseBool
- , liftM ObjectDouble parseDouble
- , liftM ObjectRAW parseRAW
- , liftM ObjectArray parseArray
- , liftM ObjectMap parseMap
- ]
+ get = parseMap (flip V.replicateM parsePair)
parsePair :: (ObjectGet k, ObjectGet v) => A.Parser (k, v)
parsePair = do
@@ -207,6 +154,19 @@ parsePair = do
b <- get
return (a, b)
+parseMap :: (Int -> A.Parser a) -> A.Parser a
+parseMap aget = do
+ c <- A.anyWord8
+ case c of
+ _ | c .&. 0xF0 == 0x80 ->
+ aget . fromIntegral $ c .&. 0x0F
+ 0xDE ->
+ aget . fromIntegral =<< parseUint16
+ 0xDF ->
+ aget . fromIntegral =<< parseUint32
+ _ ->
+ fail $ printf "invlid map tag: 0x%02X" c
+
parseUint16 :: A.Parser Word16
parseUint16 = do
b0 <- A.anyWord8
diff --git a/haskell/src/Data/MessagePack/Put.hs b/haskell/src/Data/MessagePack/Put.hs
index 8d0af2b2..95582dd8 100644
--- a/haskell/src/Data/MessagePack/Put.hs
+++ b/haskell/src/Data/MessagePack/Put.hs
@@ -35,168 +35,120 @@ class ObjectPut a where
put :: a -> Put
instance ObjectPut Object where
- put = putObject
+ put obj =
+ case obj of
+ ObjectInteger n ->
+ put n
+ ObjectNil ->
+ put ()
+ ObjectBool b ->
+ put b
+ ObjectDouble d ->
+ put d
+ ObjectRAW raw ->
+ put raw
+ ObjectArray arr ->
+ put arr
+ ObjectMap m ->
+ put m
instance ObjectPut Int where
- put = putInteger
+ put n =
+ case n of
+ _ | n >= 0 && n <= 127 ->
+ putWord8 $ fromIntegral n
+ _ | n >= -32 && n <= -1 ->
+ putWord8 $ fromIntegral n
+ _ | n >= 0 && n < 0x100 -> do
+ putWord8 0xCC
+ putWord8 $ fromIntegral n
+ _ | n >= 0 && n < 0x10000 -> do
+ putWord8 0xCD
+ putWord16be $ fromIntegral n
+ _ | n >= 0 && n < 0x100000000 -> do
+ putWord8 0xCE
+ putWord32be $ fromIntegral n
+ _ | n >= 0 -> do
+ putWord8 0xCF
+ putWord64be $ fromIntegral n
+ _ | n >= -0x80 -> do
+ putWord8 0xD0
+ putWord8 $ fromIntegral n
+ _ | n >= -0x8000 -> do
+ putWord8 0xD1
+ putWord16be $ fromIntegral n
+ _ | n >= -0x80000000 -> do
+ putWord8 0xD2
+ putWord32be $ fromIntegral n
+ _ -> do
+ putWord8 0xD3
+ putWord64be $ fromIntegral n
instance ObjectPut () where
- put _ = putNil
+ put _ =
+ putWord8 0xC0
instance ObjectPut Bool where
- put = putBool
+ put True = putWord8 0xC3
+ put False = putWord8 0xC2
instance ObjectPut Double where
- put = putDouble
+ put d = do
+ putWord8 0xCB
+ putFloat64be d
instance ObjectPut B.ByteString where
- put = putRAW
+ put bs = do
+ case len of
+ _ | len <= 31 -> do
+ putWord8 $ 0xA0 .|. fromIntegral len
+ _ | len < 0x10000 -> do
+ putWord8 0xDA
+ putWord16be $ fromIntegral len
+ _ -> do
+ putWord8 0xDB
+ putWord32be $ fromIntegral len
+ putByteString bs
+ where
+ len = B.length bs
instance ObjectPut a => ObjectPut [a] where
- put = putArray
+ put = putArray length (mapM_ put)
instance ObjectPut a => ObjectPut (V.Vector a) where
- put = putArrayVector
+ put = putArray V.length (V.mapM_ put)
+
+putArray :: (a -> Int) -> (a -> Put) -> a -> Put
+putArray lf pf arr = do
+ case lf arr of
+ len | len <= 15 ->
+ putWord8 $ 0x90 .|. fromIntegral len
+ len | len < 0x10000 -> do
+ putWord8 0xDC
+ putWord16be $ fromIntegral len
+ len -> do
+ putWord8 0xDD
+ putWord32be $ fromIntegral len
+ pf arr
instance (ObjectPut k, ObjectPut v) => ObjectPut [(k, v)] where
- put = putMap
+ put = putMap length (mapM_ putPair)
instance (ObjectPut k, ObjectPut v) => ObjectPut (V.Vector (k, v)) where
- put = putMapVector
+ put = putMap V.length (V.mapM_ putPair)
-putObject :: Object -> Put
-putObject obj =
- case obj of
- ObjectInteger n ->
- putInteger n
- ObjectNil ->
- putNil
- ObjectBool b ->
- putBool b
- ObjectDouble d ->
- putDouble d
- ObjectRAW raw ->
- putRAW raw
- ObjectArray arr ->
- putArray arr
- ObjectMap m ->
- putMap m
+putPair :: (ObjectPut a, ObjectPut b) => (a, b) -> Put
+putPair (a, b) = put a >> put b
-putInteger :: Int -> Put
-putInteger n =
- case n of
- _ | n >= 0 && n <= 127 ->
- putWord8 $ fromIntegral n
- _ | n >= -32 && n <= -1 ->
- putWord8 $ fromIntegral n
- _ | n >= 0 && n < 0x100 -> do
- putWord8 0xCC
- putWord8 $ fromIntegral n
- _ | n >= 0 && n < 0x10000 -> do
- putWord8 0xCD
- putWord16be $ fromIntegral n
- _ | n >= 0 && n < 0x100000000 -> do
- putWord8 0xCE
- putWord32be $ fromIntegral n
- _ | n >= 0 -> do
- putWord8 0xCF
- putWord64be $ fromIntegral n
- _ | n >= -0x80 -> do
- putWord8 0xD0
- putWord8 $ fromIntegral n
- _ | n >= -0x8000 -> do
- putWord8 0xD1
- putWord16be $ fromIntegral n
- _ | n >= -0x80000000 -> do
- putWord8 0xD2
- putWord32be $ fromIntegral n
- _ -> do
- putWord8 0xD3
- putWord64be $ fromIntegral n
-
-putNil :: Put
-putNil = putWord8 0xC0
-
-putBool :: Bool -> Put
-putBool True = putWord8 0xC3
-putBool False = putWord8 0xC2
-
-putDouble :: Double -> Put
-putDouble d = do
- putWord8 0xCB
- putFloat64be d
-
-putRAW :: B.ByteString -> Put
-putRAW bs = do
- case len of
- _ | len <= 31 -> do
- putWord8 $ 0xA0 .|. fromIntegral len
- _ | len < 0x10000 -> do
- putWord8 0xDA
- putWord16be $ fromIntegral len
- _ -> do
- putWord8 0xDB
- putWord32be $ fromIntegral len
- putByteString bs
- where
- len = B.length bs
-
-putArray :: ObjectPut a => [a] -> Put
-putArray arr = do
- case len of
- _ | len <= 15 ->
- putWord8 $ 0x90 .|. fromIntegral len
- _ | len < 0x10000 -> do
- putWord8 0xDC
- putWord16be $ fromIntegral len
- _ -> do
- putWord8 0xDD
- putWord32be $ fromIntegral len
- mapM_ put arr
- where
- len = length arr
-
-putArrayVector :: ObjectPut a => V.Vector a -> Put
-putArrayVector arr = do
- case len of
- _ | len <= 15 ->
- putWord8 $ 0x90 .|. fromIntegral len
- _ | len < 0x10000 -> do
- putWord8 0xDC
- putWord16be $ fromIntegral len
- _ -> do
- putWord8 0xDD
- putWord32be $ fromIntegral len
- V.mapM_ put arr
- where
- len = V.length arr
-
-putMap :: (ObjectPut k, ObjectPut v) => [(k, v)] -> Put
-putMap m = do
- case len of
- _ | len <= 15 ->
+putMap :: (a -> Int) -> (a -> Put) -> a -> Put
+putMap lf pf m = do
+ case lf m of
+ len | len <= 15 ->
putWord8 $ 0x80 .|. fromIntegral len
- _ | len < 0x10000 -> do
+ len | len < 0x10000 -> do
putWord8 0xDE
putWord16be $ fromIntegral len
- _ -> do
+ len -> do
putWord8 0xDF
putWord32be $ fromIntegral len
- mapM_ (\(k, v) -> put k >> put v) m
- where
- len = length m
-
-putMapVector :: (ObjectPut k, ObjectPut v) => V.Vector (k, v) -> Put
-putMapVector m = do
- case len of
- _ | len <= 15 ->
- putWord8 $ 0x80 .|. fromIntegral len
- _ | len < 0x10000 -> do
- putWord8 0xDE
- putWord16be $ fromIntegral len
- _ -> do
- putWord8 0xDF
- putWord32be $ fromIntegral len
- V.mapM_ (\(k, v) -> put k >> put v) m
- where
- len = V.length m
+ pf m
From 9e50ba6ec6f48071a5cc31b44864194446b9aa6f Mon Sep 17 00:00:00 2001
From: tanakh <tanaka.hideyuki@gmail.com>
Date: Mon, 6 Sep 2010 16:33:36 +0900
Subject: [PATCH 28/43] haskell: instance tupples and String and lazy
ByteString
---
haskell/src/Data/MessagePack/Parser.hs | 73 ++++++++++++++++++++++----
haskell/src/Data/MessagePack/Put.hs | 68 +++++++++++++++++++-----
haskell/test/Test.hs | 25 +++++++--
3 files changed, 139 insertions(+), 27 deletions(-)
diff --git a/haskell/src/Data/MessagePack/Parser.hs b/haskell/src/Data/MessagePack/Parser.hs
index 312e95f3..200ad962 100644
--- a/haskell/src/Data/MessagePack/Parser.hs
+++ b/haskell/src/Data/MessagePack/Parser.hs
@@ -1,6 +1,7 @@
{-# Language FlexibleInstances #-}
{-# Language IncoherentInstances #-}
{-# Language OverlappingInstances #-}
+{-# Language TypeSynonymInstances #-}
--------------------------------------------------------------------
-- |
@@ -27,6 +28,7 @@ import Data.Binary.Get
import Data.Binary.IEEE754
import Data.Bits
import qualified Data.ByteString as B
+import qualified Data.ByteString.Char8 as B8
import qualified Data.ByteString.Lazy as L
import Data.Int
import qualified Data.Vector as V
@@ -110,18 +112,27 @@ instance ObjectGet Double where
_ ->
fail $ printf "invlid double tag: 0x%02X" c
+instance ObjectGet String where
+ get = parseString (\n -> return . B8.unpack =<< A.take n)
+
instance ObjectGet B.ByteString where
- get = do
- c <- A.anyWord8
- case c of
- _ | c .&. 0xE0 == 0xA0 ->
- A.take . fromIntegral $ c .&. 0x1F
- 0xDA ->
- A.take . fromIntegral =<< parseUint16
- 0xDB ->
- A.take . fromIntegral =<< parseUint32
- _ ->
- fail $ printf "invlid raw tag: 0x%02X" c
+ get = parseString A.take
+
+instance ObjectGet L.ByteString where
+ get = parseString (\n -> do bs <- A.take n; return $ L.fromChunks [bs])
+
+parseString :: (Int -> A.Parser a) -> A.Parser a
+parseString aget = do
+ c <- A.anyWord8
+ case c of
+ _ | c .&. 0xE0 == 0xA0 ->
+ aget . fromIntegral $ c .&. 0x1F
+ 0xDA ->
+ aget . fromIntegral =<< parseUint16
+ 0xDB ->
+ aget . fromIntegral =<< parseUint32
+ _ ->
+ fail $ printf "invlid raw tag: 0x%02X" c
instance ObjectGet a => ObjectGet [a] where
get = parseArray (flip replicateM get)
@@ -129,6 +140,46 @@ instance ObjectGet a => ObjectGet [a] where
instance ObjectGet a => ObjectGet (V.Vector a) where
get = parseArray (flip V.replicateM get)
+instance (ObjectGet a1, ObjectGet a2) => ObjectGet (a1, a2) where
+ get = parseArray f where
+ f 2 = get >>= \a1 -> get >>= \a2 -> return (a1, a2)
+ f n = fail $ printf "wrong tupple size: expected 2 but got " n
+
+instance (ObjectGet a1, ObjectGet a2, ObjectGet a3) => ObjectGet (a1, a2, a3) where
+ get = parseArray f where
+ f 3 = get >>= \a1 -> get >>= \a2 -> get >>= \a3 -> return (a1, a2, a3)
+ f n = fail $ printf "wrong tupple size: expected 3 but got " n
+
+instance (ObjectGet a1, ObjectGet a2, ObjectGet a3, ObjectGet a4) => ObjectGet (a1, a2, a3, a4) where
+ get = parseArray f where
+ f 4 = get >>= \a1 -> get >>= \a2 -> get >>= \a3 -> get >>= \a4 -> return (a1, a2, a3, a4)
+ f n = fail $ printf "wrong tupple size: expected 4 but got " n
+
+instance (ObjectGet a1, ObjectGet a2, ObjectGet a3, ObjectGet a4, ObjectGet a5) => ObjectGet (a1, a2, a3, a4, a5) where
+ get = parseArray f where
+ f 5 = get >>= \a1 -> get >>= \a2 -> get >>= \a3 -> get >>= \a4 -> get >>= \a5 -> return (a1, a2, a3, a4, a5)
+ f n = fail $ printf "wrong tupple size: expected 5 but got " n
+
+instance (ObjectGet a1, ObjectGet a2, ObjectGet a3, ObjectGet a4, ObjectGet a5, ObjectGet a6) => ObjectGet (a1, a2, a3, a4, a5, a6) where
+ get = parseArray f where
+ f 6 = get >>= \a1 -> get >>= \a2 -> get >>= \a3 -> get >>= \a4 -> get >>= \a5 -> get >>= \a6 -> return (a1, a2, a3, a4, a5, a6)
+ f n = fail $ printf "wrong tupple size: expected 6 but got " n
+
+instance (ObjectGet a1, ObjectGet a2, ObjectGet a3, ObjectGet a4, ObjectGet a5, ObjectGet a6, ObjectGet a7) => ObjectGet (a1, a2, a3, a4, a5, a6, a7) where
+ get = parseArray f where
+ f 7 = get >>= \a1 -> get >>= \a2 -> get >>= \a3 -> get >>= \a4 -> get >>= \a5 -> get >>= \a6 -> get >>= \a7 -> return (a1, a2, a3, a4, a5, a6, a7)
+ f n = fail $ printf "wrong tupple size: expected 7 but got " n
+
+instance (ObjectGet a1, ObjectGet a2, ObjectGet a3, ObjectGet a4, ObjectGet a5, ObjectGet a6, ObjectGet a7, ObjectGet a8) => ObjectGet (a1, a2, a3, a4, a5, a6, a7, a8) where
+ get = parseArray f where
+ f 8 = get >>= \a1 -> get >>= \a2 -> get >>= \a3 -> get >>= \a4 -> get >>= \a5 -> get >>= \a6 -> get >>= \a7 -> get >>= \a8 -> return (a1, a2, a3, a4, a5, a6, a7, a8)
+ f n = fail $ printf "wrong tupple size: expected 8 but got " n
+
+instance (ObjectGet a1, ObjectGet a2, ObjectGet a3, ObjectGet a4, ObjectGet a5, ObjectGet a6, ObjectGet a7, ObjectGet a8, ObjectGet a9) => ObjectGet (a1, a2, a3, a4, a5, a6, a7, a8, a9) where
+ get = parseArray f where
+ f 9 = get >>= \a1 -> get >>= \a2 -> get >>= \a3 -> get >>= \a4 -> get >>= \a5 -> get >>= \a6 -> get >>= \a7 -> get >>= \a8 -> get >>= \a9 -> return (a1, a2, a3, a4, a5, a6, a7, a8, a9)
+ f n = fail $ printf "wrong tupple size: expected 9 but got " n
+
parseArray :: (Int -> A.Parser a) -> A.Parser a
parseArray aget = do
c <- A.anyWord8
diff --git a/haskell/src/Data/MessagePack/Put.hs b/haskell/src/Data/MessagePack/Put.hs
index 95582dd8..24ec3059 100644
--- a/haskell/src/Data/MessagePack/Put.hs
+++ b/haskell/src/Data/MessagePack/Put.hs
@@ -1,6 +1,7 @@
{-# Language FlexibleInstances #-}
{-# Language IncoherentInstances #-}
{-# Language OverlappingInstances #-}
+{-# Language TypeSynonymInstances #-}
--------------------------------------------------------------------
-- |
@@ -25,6 +26,8 @@ import Data.Binary.Put
import Data.Binary.IEEE754
import Data.Bits
import qualified Data.ByteString as B
+import qualified Data.ByteString.Char8 as B8
+import qualified Data.ByteString.Lazy as L
import qualified Data.Vector as V
import Data.MessagePack.Object
@@ -97,20 +100,27 @@ instance ObjectPut Double where
putWord8 0xCB
putFloat64be d
+instance ObjectPut String where
+ put = putString length (putByteString . B8.pack)
+
instance ObjectPut B.ByteString where
- put bs = do
- case len of
- _ | len <= 31 -> do
- putWord8 $ 0xA0 .|. fromIntegral len
- _ | len < 0x10000 -> do
- putWord8 0xDA
- putWord16be $ fromIntegral len
- _ -> do
- putWord8 0xDB
- putWord32be $ fromIntegral len
- putByteString bs
- where
- len = B.length bs
+ put = putString B.length putByteString
+
+instance ObjectPut L.ByteString where
+ put = putString (fromIntegral . L.length) putLazyByteString
+
+putString :: (s -> Int) -> (s -> Put) -> s -> Put
+putString lf pf str = do
+ case lf str of
+ len | len <= 31 -> do
+ putWord8 $ 0xA0 .|. fromIntegral len
+ len | len < 0x10000 -> do
+ putWord8 0xDA
+ putWord16be $ fromIntegral len
+ len -> do
+ putWord8 0xDB
+ putWord32be $ fromIntegral len
+ pf str
instance ObjectPut a => ObjectPut [a] where
put = putArray length (mapM_ put)
@@ -118,6 +128,38 @@ instance ObjectPut a => ObjectPut [a] where
instance ObjectPut a => ObjectPut (V.Vector a) where
put = putArray V.length (V.mapM_ put)
+instance (ObjectPut a1, ObjectPut a2) => ObjectPut (a1, a2) where
+ put = putArray (const 2) f where
+ f (a1, a2) = put a1 >> put a2
+
+instance (ObjectPut a1, ObjectPut a2, ObjectPut a3) => ObjectPut (a1, a2, a3) where
+ put = putArray (const 3) f where
+ f (a1, a2, a3) = put a1 >> put a2 >> put a3
+
+instance (ObjectPut a1, ObjectPut a2, ObjectPut a3, ObjectPut a4) => ObjectPut (a1, a2, a3, a4) where
+ put = putArray (const 4) f where
+ f (a1, a2, a3, a4) = put a1 >> put a2 >> put a3 >> put a4
+
+instance (ObjectPut a1, ObjectPut a2, ObjectPut a3, ObjectPut a4, ObjectPut a5) => ObjectPut (a1, a2, a3, a4, a5) where
+ put = putArray (const 5) f where
+ f (a1, a2, a3, a4, a5) = put a1 >> put a2 >> put a3 >> put a4 >> put a5
+
+instance (ObjectPut a1, ObjectPut a2, ObjectPut a3, ObjectPut a4, ObjectPut a5, ObjectPut a6) => ObjectPut (a1, a2, a3, a4, a5, a6) where
+ put = putArray (const 6) f where
+ f (a1, a2, a3, a4, a5, a6) = put a1 >> put a2 >> put a3 >> put a4 >> put a5 >> put a6
+
+instance (ObjectPut a1, ObjectPut a2, ObjectPut a3, ObjectPut a4, ObjectPut a5, ObjectPut a6, ObjectPut a7) => ObjectPut (a1, a2, a3, a4, a5, a6, a7) where
+ put = putArray (const 7) f where
+ f (a1, a2, a3, a4, a5, a6, a7) = put a1 >> put a2 >> put a3 >> put a4 >> put a5 >> put a6 >> put a7
+
+instance (ObjectPut a1, ObjectPut a2, ObjectPut a3, ObjectPut a4, ObjectPut a5, ObjectPut a6, ObjectPut a7, ObjectPut a8) => ObjectPut (a1, a2, a3, a4, a5, a6, a7, a8) where
+ put = putArray (const 8) f where
+ f (a1, a2, a3, a4, a5, a6, a7, a8) = put a1 >> put a2 >> put a3 >> put a4 >> put a5 >> put a6 >> put a7 >> put a8
+
+instance (ObjectPut a1, ObjectPut a2, ObjectPut a3, ObjectPut a4, ObjectPut a5, ObjectPut a6, ObjectPut a7, ObjectPut a8, ObjectPut a9) => ObjectPut (a1, a2, a3, a4, a5, a6, a7, a8, a9) where
+ put = putArray (const 9) f where
+ f (a1, a2, a3, a4, a5, a6, a7, a8, a9) = put a1 >> put a2 >> put a3 >> put a4 >> put a5 >> put a6 >> put a7 >> put a8 >> put a9
+
putArray :: (a -> Int) -> (a -> Put) -> a -> Put
putArray lf pf arr = do
case lf arr of
diff --git a/haskell/test/Test.hs b/haskell/test/Test.hs
index 1bb551c1..a73ac9ab 100644
--- a/haskell/test/Test.hs
+++ b/haskell/test/Test.hs
@@ -4,6 +4,7 @@ import Test.QuickCheck
import Control.Monad
import qualified Data.ByteString.Char8 as B
+import qualified Data.ByteString.Lazy.Char8 as L
import Data.MessagePack
mid :: (ObjectGet a, ObjectPut a) => a -> a
@@ -17,15 +18,27 @@ prop_mid_bool a = a == mid a
where types = a :: Bool
prop_mid_double a = a == mid a
where types = a :: Double
-prop_mid_string a = a == B.unpack (mid (B.pack a))
+prop_mid_string a = a == mid a
+ where types = a :: String
+prop_mid_bytestring a = B.pack a == mid (B.pack a)
+ where types = a :: String
+prop_mid_lazy_bytestring a = (L.pack a) == mid (L.pack a)
where types = a :: String
prop_mid_array_int a = a == mid a
where types = a :: [Int]
-prop_mid_array_string a = a == map B.unpack (mid (map B.pack a))
+prop_mid_array_string a = a == mid a
where types = a :: [String]
+prop_mid_pair2 a = a == mid a
+ where types = a :: (Int, Int)
+prop_mid_pair3 a = a == mid a
+ where types = a :: (Int, Int, Int)
+prop_mid_pair4 a = a == mid a
+ where types = a :: (Int, Int, Int, Int)
+prop_mid_pair5 a = a == mid a
+ where types = a :: (Int, Int, Int, Int, Int)
prop_mid_map_int_double a = a == mid a
where types = a :: [(Int, Double)]
-prop_mid_map_string_string a = a == map (\(x, y) -> (B.unpack x, B.unpack y)) (mid (map (\(x, y) -> (B.pack x, B.pack y)) a))
+prop_mid_map_string_string a = a == mid a
where types = a :: [(String, String)]
tests =
@@ -35,8 +48,14 @@ tests =
, testProperty "bool" prop_mid_bool
, testProperty "double" prop_mid_double
, testProperty "string" prop_mid_string
+ , testProperty "bytestring" prop_mid_bytestring
+ , testProperty "lazy-bytestring" prop_mid_lazy_bytestring
, testProperty "[int]" prop_mid_array_int
, testProperty "[string]" prop_mid_array_string
+ , testProperty "(int, int)" prop_mid_pair2
+ , testProperty "(int, int, int)" prop_mid_pair3
+ , testProperty "(int, int, int, int)" prop_mid_pair4
+ , testProperty "(int, int, int, int, int)" prop_mid_pair5
, testProperty "[(int, double)]" prop_mid_map_int_double
, testProperty "[(string, string)]" prop_mid_map_string_string
]
From b75db110dceef9bf75c8410ca4b4fc031e1aad89 Mon Sep 17 00:00:00 2001
From: tanakh <tanaka.hideyuki@gmail.com>
Date: Mon, 6 Sep 2010 17:00:22 +0900
Subject: [PATCH 29/43] haskell: add Iteratee interface
---
haskell/msgpack.cabal | 1 +
haskell/src/Data/MessagePack.hs | 45 ++++++++++++-----------
haskell/src/Data/MessagePack/Iteratee.hs | 46 ++++++++++++++++++++++++
3 files changed, 72 insertions(+), 20 deletions(-)
create mode 100644 haskell/src/Data/MessagePack/Iteratee.hs
diff --git a/haskell/msgpack.cabal b/haskell/msgpack.cabal
index 18ae3d86..3baff77f 100644
--- a/haskell/msgpack.cabal
+++ b/haskell/msgpack.cabal
@@ -33,3 +33,4 @@ Library
Data.MessagePack.Object
Data.MessagePack.Put
Data.MessagePack.Parser
+ Data.MessagePack.Iteratee
diff --git a/haskell/src/Data/MessagePack.hs b/haskell/src/Data/MessagePack.hs
index 010eaab0..92353c53 100644
--- a/haskell/src/Data/MessagePack.hs
+++ b/haskell/src/Data/MessagePack.hs
@@ -16,6 +16,7 @@ module Data.MessagePack(
module Data.MessagePack.Object,
module Data.MessagePack.Put,
module Data.MessagePack.Parser,
+ module Data.MessagePack.Iteratee,
-- * Simple functions of Pack and Unpack
pack,
@@ -30,6 +31,9 @@ module Data.MessagePack(
unpackFromString,
unpackFromHandle,
unpackFromFile,
+ unpackFromStringI,
+ unpackFromHandleI,
+ unpackFromFileI,
) where
@@ -47,6 +51,7 @@ import System.IO
import Data.MessagePack.Object
import Data.MessagePack.Put
import Data.MessagePack.Parser
+import Data.MessagePack.Iteratee
bufferSize :: Int
bufferSize = 4 * 1024
@@ -67,7 +72,7 @@ pack = packToString . put
-- | Unpack MessagePack string to Haskell data.
unpack :: (ObjectGet a, IsByteString s) => s -> a
unpack bs =
- runIdentity $ I.run $ I.joinIM $ I.enumPure1Chunk (toBS bs) (parserToIteratee get)
+ runIdentity $ I.run $ I.joinIM $ I.enumPure1Chunk (toBS bs) getI
-- TODO: tryUnpack
@@ -86,32 +91,32 @@ packToFile path = L.writeFile path . packToString
-- | Unpack from ByteString
unpackFromString :: (Monad m, IsByteString s) => s -> A.Parser a -> m a
unpackFromString bs =
- I.run . I.joinIM . I.enumPure1Chunk (toBS bs) . parserToIteratee
+ unpackFromStringI bs . parserToIteratee
-- | Unpack from Handle
unpackFromHandle :: CIO.MonadCatchIO m => Handle -> A.Parser a -> m a
unpackFromHandle h =
- I.run . I.joinIM . I.enumHandle bufferSize h . parserToIteratee
+ unpackFromHandleI h .parserToIteratee
-- | Unpack from File
unpackFromFile :: CIO.MonadCatchIO m => FilePath -> A.Parser a -> m a
-unpackFromFile path p =
+unpackFromFile path =
+ unpackFromFileI path . parserToIteratee
+
+-- | Iteratee interface to unpack from ByteString
+unpackFromStringI :: (Monad m, IsByteString s) => s -> I.Iteratee B.ByteString m a -> m a
+unpackFromStringI bs =
+ I.run . I.joinIM . I.enumPure1Chunk (toBS bs)
+
+-- | Iteratee interface to unpack from Handle
+unpackFromHandleI :: CIO.MonadCatchIO m => Handle -> I.Iteratee B.ByteString m a -> m a
+unpackFromHandleI h =
+ I.run . I.joinIM . I.enumHandle bufferSize h
+
+-- | Iteratee interface to unpack from File
+unpackFromFileI :: CIO.MonadCatchIO m => FilePath -> I.Iteratee B.ByteString m a -> m a
+unpackFromFileI path p =
CIO.bracket
(liftIO $ openBinaryFile path ReadMode)
(liftIO . hClose)
- (flip unpackFromHandle p)
-
-parserToIteratee :: Monad m => A.Parser a -> I.Iteratee B.ByteString m a
-parserToIteratee p = I.icont (itr (A.parse p)) Nothing
- where
- itr pcont s = case s of
- I.EOF _ ->
- I.throwErr (I.setEOF s)
- I.Chunk bs ->
- case pcont bs of
- A.Fail _ _ msg ->
- I.throwErr (I.iterStrExc msg)
- A.Partial cont ->
- I.icont (itr cont) Nothing
- A.Done remain ret ->
- I.idone ret (I.Chunk remain)
+ (flip unpackFromHandleI p)
diff --git a/haskell/src/Data/MessagePack/Iteratee.hs b/haskell/src/Data/MessagePack/Iteratee.hs
new file mode 100644
index 00000000..789b714a
--- /dev/null
+++ b/haskell/src/Data/MessagePack/Iteratee.hs
@@ -0,0 +1,46 @@
+--------------------------------------------------------------------
+-- |
+-- Module : Data.MessagePack.Iteratee
+-- Copyright : (c) Hideyuki Tanaka, 2009-2010
+-- License : BSD3
+--
+-- Maintainer: tanaka.hideyuki@gmail.com
+-- Stability : experimental
+-- Portability: portable
+--
+-- MessagePack Deserializer interface to @Data.Iteratee@
+--
+--------------------------------------------------------------------
+
+module Data.MessagePack.Iteratee(
+ -- * Iteratee version of deserializer
+ getI,
+ -- * Convert Parser to Iteratee
+ parserToIteratee,
+ ) where
+
+import qualified Data.Attoparsec as A
+import qualified Data.ByteString as B
+import qualified Data.Iteratee as I
+
+import Data.MessagePack.Parser
+
+-- | Deserialize a value
+getI :: (Monad m, ObjectGet a) => I.Iteratee B.ByteString m a
+getI = parserToIteratee get
+
+-- | Convert Parser to Iteratee
+parserToIteratee :: Monad m => A.Parser a -> I.Iteratee B.ByteString m a
+parserToIteratee p = I.icont (itr (A.parse p)) Nothing
+ where
+ itr pcont s = case s of
+ I.EOF _ ->
+ I.throwErr (I.setEOF s)
+ I.Chunk bs ->
+ case pcont bs of
+ A.Fail _ _ msg ->
+ I.throwErr (I.iterStrExc msg)
+ A.Partial cont ->
+ I.icont (itr cont) Nothing
+ A.Done remain ret ->
+ I.idone ret (I.Chunk remain)
From dfe19d308caa43e8d763750faafc2baade7d013c Mon Sep 17 00:00:00 2001
From: tanakh <tanaka.hideyuki@gmail.com>
Date: Mon, 6 Sep 2010 18:14:47 +0900
Subject: [PATCH 30/43] haskell: add overlapping instances
---
haskell/src/Data/MessagePack/Object.hs | 5 +++--
1 file changed, 3 insertions(+), 2 deletions(-)
diff --git a/haskell/src/Data/MessagePack/Object.hs b/haskell/src/Data/MessagePack/Object.hs
index 19a3aeba..df0e89dd 100644
--- a/haskell/src/Data/MessagePack/Object.hs
+++ b/haskell/src/Data/MessagePack/Object.hs
@@ -1,5 +1,6 @@
-{-# LANGUAGE TypeSynonymInstances #-}
-{-# LANGUAGE FlexibleInstances #-}
+{-# Language TypeSynonymInstances #-}
+{-# Language FlexibleInstances #-}
+{-# Language OverlappingInstances #-}
--------------------------------------------------------------------
-- |
From c6424c2ce71f3e79e8aacfe9c76846cf94e168de Mon Sep 17 00:00:00 2001
From: tanakh <tanaka.hideyuki@gmail.com>
Date: Mon, 6 Sep 2010 23:27:50 +0900
Subject: [PATCH 31/43] haskell: nonblocking enumerator
---
haskell/src/Data/MessagePack.hs | 3 +-
haskell/src/Data/MessagePack/Iteratee.hs | 36 ++++++++++++++++++++++++
2 files changed, 37 insertions(+), 2 deletions(-)
diff --git a/haskell/src/Data/MessagePack.hs b/haskell/src/Data/MessagePack.hs
index 92353c53..b53066b1 100644
--- a/haskell/src/Data/MessagePack.hs
+++ b/haskell/src/Data/MessagePack.hs
@@ -45,7 +45,6 @@ import qualified Data.ByteString as B
import qualified Data.ByteString.Lazy as L
import Data.Functor.Identity
import qualified Data.Iteratee as I
-import qualified Data.Iteratee.IO as I
import System.IO
import Data.MessagePack.Object
@@ -111,7 +110,7 @@ unpackFromStringI bs =
-- | Iteratee interface to unpack from Handle
unpackFromHandleI :: CIO.MonadCatchIO m => Handle -> I.Iteratee B.ByteString m a -> m a
unpackFromHandleI h =
- I.run . I.joinIM . I.enumHandle bufferSize h
+ I.run . I.joinIM . enumHandleNonBlocking bufferSize h
-- | Iteratee interface to unpack from File
unpackFromFileI :: CIO.MonadCatchIO m => FilePath -> I.Iteratee B.ByteString m a -> m a
diff --git a/haskell/src/Data/MessagePack/Iteratee.hs b/haskell/src/Data/MessagePack/Iteratee.hs
index 789b714a..4258cf68 100644
--- a/haskell/src/Data/MessagePack/Iteratee.hs
+++ b/haskell/src/Data/MessagePack/Iteratee.hs
@@ -15,13 +15,18 @@
module Data.MessagePack.Iteratee(
-- * Iteratee version of deserializer
getI,
+ -- * Non Blocking Enumerator
+ enumHandleNonBlocking,
-- * Convert Parser to Iteratee
parserToIteratee,
) where
+import Control.Exception
+import Control.Monad.IO.Class
import qualified Data.Attoparsec as A
import qualified Data.ByteString as B
import qualified Data.Iteratee as I
+import System.IO
import Data.MessagePack.Parser
@@ -29,6 +34,37 @@ import Data.MessagePack.Parser
getI :: (Monad m, ObjectGet a) => I.Iteratee B.ByteString m a
getI = parserToIteratee get
+-- | Enumerator
+enumHandleNonBlocking :: MonadIO m => Int -> Handle -> I.Enumerator B.ByteString m a
+enumHandleNonBlocking bufSize h =
+ I.enumFromCallback $ readSome bufSize h
+
+readSome :: MonadIO m => Int -> Handle -> m (Either SomeException (Bool, B.ByteString))
+readSome bufSize h = liftIO $ do
+ ebs <- try $ hGetSome bufSize h
+ case ebs of
+ Left exc ->
+ return $ Left (exc :: SomeException)
+ Right bs | B.null bs ->
+ return $ Right (False, B.empty)
+ Right bs ->
+ return $ Right (True, bs)
+
+hGetSome :: Int -> Handle -> IO B.ByteString
+hGetSome bufSize h = do
+ bs <- B.hGetNonBlocking h bufSize
+ if B.null bs
+ then do
+ hd <- B.hGet h 1
+ if B.null hd
+ then do
+ return B.empty
+ else do
+ rest <- B.hGetNonBlocking h (bufSize - 1)
+ return $ B.cons (B.head hd) rest
+ else do
+ return bs
+
-- | Convert Parser to Iteratee
parserToIteratee :: Monad m => A.Parser a -> I.Iteratee B.ByteString m a
parserToIteratee p = I.icont (itr (A.parse p)) Nothing
From c56926428c2b66fd3f112b9095c46f46e0527cd7 Mon Sep 17 00:00:00 2001
From: tanakh <tanaka.hideyuki@gmail.com>
Date: Tue, 7 Sep 2010 16:14:00 +0900
Subject: [PATCH 32/43] haskell: add packToHandle'
---
haskell/src/Data/MessagePack.hs | 5 +++++
1 file changed, 5 insertions(+)
diff --git a/haskell/src/Data/MessagePack.hs b/haskell/src/Data/MessagePack.hs
index b53066b1..7137589f 100644
--- a/haskell/src/Data/MessagePack.hs
+++ b/haskell/src/Data/MessagePack.hs
@@ -25,6 +25,7 @@ module Data.MessagePack(
-- * Pack functions
packToString,
packToHandle,
+ packToHandle',
packToFile,
-- * Unpack functions
@@ -83,6 +84,10 @@ packToString = runPut
packToHandle :: Handle -> Put -> IO ()
packToHandle h = L.hPutStr h . packToString
+-- | Pack to Handle and Flush Handle
+packToHandle' :: Handle -> Put -> IO ()
+packToHandle' h p = packToHandle h p >> hFlush h
+
-- | Pack to File
packToFile :: FilePath -> Put -> IO ()
packToFile path = L.writeFile path . packToString
From 169f287970a68e52d766b485f9c870ef83916b59 Mon Sep 17 00:00:00 2001
From: tanakh <tanaka.hideyuki@gmail.com>
Date: Tue, 7 Sep 2010 16:14:29 +0900
Subject: [PATCH 33/43] haskell: Now, Object is an instance of NFData.
---
haskell/msgpack.cabal | 4 +++-
haskell/src/Data/MessagePack/Object.hs | 12 ++++++++++++
2 files changed, 15 insertions(+), 1 deletion(-)
diff --git a/haskell/msgpack.cabal b/haskell/msgpack.cabal
index 3baff77f..bd10c4aa 100644
--- a/haskell/msgpack.cabal
+++ b/haskell/msgpack.cabal
@@ -24,7 +24,9 @@ Library
iteratee >= 0.4 && < 0.5,
attoparsec >= 0.8.1 && < 0.8.2,
binary >= 0.5.0 && < 0.5.1,
- data-binary-ieee754 >= 0.4 && < 0.5
+ data-binary-ieee754 >= 0.4 && < 0.5,
+ deepseq >= 1.1 && <1.2
+
Ghc-options: -Wall -O2
Hs-source-dirs: src
diff --git a/haskell/src/Data/MessagePack/Object.hs b/haskell/src/Data/MessagePack/Object.hs
index df0e89dd..6806722b 100644
--- a/haskell/src/Data/MessagePack/Object.hs
+++ b/haskell/src/Data/MessagePack/Object.hs
@@ -25,6 +25,7 @@ module Data.MessagePack.Object(
Result,
) where
+import Control.DeepSeq
import Control.Monad
import Control.Monad.Trans.Error ()
import qualified Data.ByteString as B
@@ -41,6 +42,17 @@ data Object =
| ObjectMap [(Object, Object)]
deriving (Show)
+instance NFData Object where
+ rnf obj =
+ case obj of
+ ObjectNil -> ()
+ ObjectBool b -> rnf b
+ ObjectInteger n -> rnf n
+ ObjectDouble d -> rnf d
+ ObjectRAW bs -> bs `seq` ()
+ ObjectArray a -> rnf a
+ ObjectMap m -> rnf m
+
-- | The class of types serializable to and from MessagePack object
class OBJECT a where
-- | Encode a value to MessagePack object
From 5e19bc6f844500e729d498ee6275a6a2e6557ba2 Mon Sep 17 00:00:00 2001
From: tanakh <tanaka.hideyuki@gmail.com>
Date: Tue, 7 Sep 2010 17:35:24 +0900
Subject: [PATCH 34/43] haskell: Object is Eq, Ord, Typeable.
---
haskell/src/Data/MessagePack/Object.hs | 4 +++-
1 file changed, 3 insertions(+), 1 deletion(-)
diff --git a/haskell/src/Data/MessagePack/Object.hs b/haskell/src/Data/MessagePack/Object.hs
index 6806722b..87f24bd9 100644
--- a/haskell/src/Data/MessagePack/Object.hs
+++ b/haskell/src/Data/MessagePack/Object.hs
@@ -1,6 +1,7 @@
{-# Language TypeSynonymInstances #-}
{-# Language FlexibleInstances #-}
{-# Language OverlappingInstances #-}
+{-# Language DeriveDataTypeable #-}
--------------------------------------------------------------------
-- |
@@ -30,6 +31,7 @@ import Control.Monad
import Control.Monad.Trans.Error ()
import qualified Data.ByteString as B
import qualified Data.ByteString.Char8 as C8
+import Data.Typeable
-- | Object Representation of MessagePack data.
data Object =
@@ -40,7 +42,7 @@ data Object =
| ObjectRAW B.ByteString
| ObjectArray [Object]
| ObjectMap [(Object, Object)]
- deriving (Show)
+ deriving (Show, Eq, Ord, Typeable)
instance NFData Object where
rnf obj =
From a99870645244f9073075a43c30dc20511de89097 Mon Sep 17 00:00:00 2001
From: tanakh <tanaka.hideyuki@gmail.com>
Date: Wed, 8 Sep 2010 13:36:45 +0900
Subject: [PATCH 35/43] haskell: update cabal file
---
haskell/msgpack.cabal | 12 ++++++++----
1 file changed, 8 insertions(+), 4 deletions(-)
diff --git a/haskell/msgpack.cabal b/haskell/msgpack.cabal
index bd10c4aa..ccdb2f7f 100644
--- a/haskell/msgpack.cabal
+++ b/haskell/msgpack.cabal
@@ -1,18 +1,18 @@
Name: msgpack
-Version: 0.3.1
+Version: 0.3.1.1
Synopsis: A Haskell binding to MessagePack
Description:
A Haskell binding to MessagePack <http://msgpack.org/>
License: BSD3
License-File: LICENSE
+Copyright: Copyright (c) 2009-2010, Hideyuki Tanaka
Category: Data
Author: Hideyuki Tanaka
Maintainer: Hideyuki Tanaka <tanaka.hideyuki@gmail.com>
Homepage: http://github.com/msgpack/msgpack
Stability: Experimental
-Tested-with: GHC == 6.12.3
-Cabal-Version: >= 1.2
+Cabal-Version: >= 1.6
Build-Type: Simple
Library
@@ -27,7 +27,7 @@ Library
data-binary-ieee754 >= 0.4 && < 0.5,
deepseq >= 1.1 && <1.2
- Ghc-options: -Wall -O2
+ Ghc-options: -Wall
Hs-source-dirs: src
Exposed-modules:
@@ -36,3 +36,7 @@ Library
Data.MessagePack.Put
Data.MessagePack.Parser
Data.MessagePack.Iteratee
+
+Source-repository head
+ Type: git
+ Location: git://github.com/msgpack/msgpack.git
From 9f684e7670877fe04d02afe8377e4a6191d74f31 Mon Sep 17 00:00:00 2001
From: tokuhirom <tokuhirom@gmail.com>
Date: Fri, 10 Sep 2010 09:35:39 +0900
Subject: [PATCH 36/43] Checking in changes prior to tagging of version 0.20.
Changelog diff is:
diff --git a/perl/Changes b/perl/Changes
index 7910882..dc3dd5c 100644
--- a/perl/Changes
+++ b/perl/Changes
@@ -1,3 +1,7 @@
+0.20
+
+ - first production ready release with PP driver.
+
0.16_04
- no feature changes
---
perl/Changes | 4 ++++
perl/lib/Data/MessagePack.pm | 2 +-
2 files changed, 5 insertions(+), 1 deletion(-)
diff --git a/perl/Changes b/perl/Changes
index 79108820..dc3dd5cf 100644
--- a/perl/Changes
+++ b/perl/Changes
@@ -1,3 +1,7 @@
+0.20
+
+ - first production ready release with PP driver.
+
0.16_04
- no feature changes
diff --git a/perl/lib/Data/MessagePack.pm b/perl/lib/Data/MessagePack.pm
index b08bac2d..eca24ec6 100644
--- a/perl/lib/Data/MessagePack.pm
+++ b/perl/lib/Data/MessagePack.pm
@@ -3,7 +3,7 @@ use strict;
use warnings;
use 5.008001;
-our $VERSION = '0.16_04';
+our $VERSION = '0.20';
our $PreferInteger = 0;
our $true = do { bless \(my $dummy = 1), "Data::MessagePack::Boolean" };
From f6f675d1e12b2c5994099df3d1af1513b1d83bf2 Mon Sep 17 00:00:00 2001
From: tokuhirom <tokuhirom@gmail.com>
Date: Fri, 10 Sep 2010 20:27:11 +0900
Subject: [PATCH 37/43] updated benchmark script
---
perl/benchmark/deserialize.pl | 9 ++++++---
perl/benchmark/serialize.pl | 5 ++++-
2 files changed, 10 insertions(+), 4 deletions(-)
diff --git a/perl/benchmark/deserialize.pl b/perl/benchmark/deserialize.pl
index fd21f086..0ddcec93 100644
--- a/perl/benchmark/deserialize.pl
+++ b/perl/benchmark/deserialize.pl
@@ -3,18 +3,21 @@ use warnings;
use Data::MessagePack;
use JSON::XS;
use Benchmark ':all';
+use Storable;
my $a = [0..2**24];
my $j = JSON::XS::encode_json($a);
my $m = Data::MessagePack->pack($a);
+my $s = Storable::nfreeze($a);
print "-- deserialize\n";
print "JSON::XS: $JSON::XS::VERSION\n";
print "Data::MessagePack: $Data::MessagePack::VERSION\n";
-cmpthese(
+timethese(
-1 => {
- json => sub { JSON::XS::decode_json($j) },
- mp => sub { Data::MessagePack->unpack($m) },
+ json => sub { JSON::XS::decode_json($j) },
+ mp => sub { Data::MessagePack->unpack($m) },
+ storable => sub { Storable::thaw($s) },
}
);
diff --git a/perl/benchmark/serialize.pl b/perl/benchmark/serialize.pl
index 626ae039..b811bfe5 100644
--- a/perl/benchmark/serialize.pl
+++ b/perl/benchmark/serialize.pl
@@ -2,6 +2,7 @@ use strict;
use warnings;
use Data::MessagePack;
use JSON::XS;
+use Storable;
use Benchmark ':all';
my $a = [0..2**24];
@@ -9,9 +10,11 @@ my $a = [0..2**24];
print "-- serialize\n";
print "JSON::XS: $JSON::XS::VERSION\n";
print "Data::MessagePack: $Data::MessagePack::VERSION\n";
-cmpthese(
+print "Storable: $Storable::VERSION\n";
+timethese(
-1 => {
json => sub { JSON::XS::encode_json($a) },
+ storable => sub { Storable::nfreeze($a) },
mp => sub { Data::MessagePack->pack($a) },
}
);
From 5bb8b6f16c426ebfeee0027c1026ab8f610bec05 Mon Sep 17 00:00:00 2001
From: tokuhirom <tokuhirom@gmail.com>
Date: Fri, 10 Sep 2010 20:38:37 +0900
Subject: [PATCH 38/43] perl: ugpraded benchmarking script. and added result to
docs.
---
perl/benchmark/deserialize.pl | 12 ++++++---
perl/benchmark/serialize.pl | 15 +++++++----
perl/lib/Data/MessagePack.pm | 50 ++++++++++++++++++++++++++++++++++-
3 files changed, 68 insertions(+), 9 deletions(-)
diff --git a/perl/benchmark/deserialize.pl b/perl/benchmark/deserialize.pl
index 0ddcec93..750704e9 100644
--- a/perl/benchmark/deserialize.pl
+++ b/perl/benchmark/deserialize.pl
@@ -5,16 +5,22 @@ use JSON::XS;
use Benchmark ':all';
use Storable;
-my $a = [0..2**24];
+my $a = {
+ "method" => "handleMessage",
+ "params" => [ "user1", "we were just talking" ],
+ "id" => undef,
+ "array" => [ 1, 11, 234, -5, 1e5, 1e7, 1, 0 ]
+};
my $j = JSON::XS::encode_json($a);
my $m = Data::MessagePack->pack($a);
-my $s = Storable::nfreeze($a);
+my $s = Storable::freeze($a);
print "-- deserialize\n";
print "JSON::XS: $JSON::XS::VERSION\n";
print "Data::MessagePack: $Data::MessagePack::VERSION\n";
+print "Storable: $Storable::VERSION\n";
timethese(
- -1 => {
+ 1000000 => {
json => sub { JSON::XS::decode_json($j) },
mp => sub { Data::MessagePack->unpack($m) },
storable => sub { Storable::thaw($s) },
diff --git a/perl/benchmark/serialize.pl b/perl/benchmark/serialize.pl
index b811bfe5..c5ab15bc 100644
--- a/perl/benchmark/serialize.pl
+++ b/perl/benchmark/serialize.pl
@@ -5,17 +5,22 @@ use JSON::XS;
use Storable;
use Benchmark ':all';
-my $a = [0..2**24];
+my $a = {
+ "method" => "handleMessage",
+ "params" => [ "user1", "we were just talking" ],
+ "id" => undef,
+ "array" => [ 1, 11, 234, -5, 1e5, 1e7, 1, 0 ]
+};
print "-- serialize\n";
print "JSON::XS: $JSON::XS::VERSION\n";
print "Data::MessagePack: $Data::MessagePack::VERSION\n";
print "Storable: $Storable::VERSION\n";
timethese(
- -1 => {
- json => sub { JSON::XS::encode_json($a) },
- storable => sub { Storable::nfreeze($a) },
- mp => sub { Data::MessagePack->pack($a) },
+ 1000000 => {
+ json => sub { JSON::XS::encode_json($a) },
+ storable => sub { Storable::freeze($a) },
+ mp => sub { Data::MessagePack->pack($a) },
}
);
diff --git a/perl/lib/Data/MessagePack.pm b/perl/lib/Data/MessagePack.pm
index eca24ec6..fbf305a5 100644
--- a/perl/lib/Data/MessagePack.pm
+++ b/perl/lib/Data/MessagePack.pm
@@ -41,9 +41,35 @@ Data::MessagePack - MessagePack serialising/deserialising
This module converts Perl data structures to MessagePack and vice versa.
+=head1 ABOUT MESSAGEPACK FORMAT
+
MessagePack is a binary-based efficient object serialization format.
It enables to exchange structured objects between many languages like JSON. But unlike JSON, it is very fast and small.
+=head2 ADVANTAGES
+
+=over 4
+
+=item PORTABILITY
+
+Messagepack is language independent binary serialize format.
+
+=item SMALL SIZE
+
+ say length(JSON::XS::encode_json({a=>1, b=>2})); # => 13
+ say length(Storable::nfreeze({a=>1, b=>2})); # => 21
+ say length(Data::MessagePack->pack({a=>1, b=>2})); # => 7
+
+MessagePack format saves memory than JSON and Storable format.
+
+=item STREAMING DESERIALIZER
+
+MessagePack supports streaming deserializer. It is useful for networking such as RPC.
+
+=back
+
+If you want to get more informations about messagepack format, please visit to L<http://msgpack.org/>.
+
=head1 METHODS
=over 4
@@ -68,6 +94,28 @@ Pack the string as int when the value looks like int(EXPERIMENTAL).
=back
+=head1 SPEED
+
+This is result of benchmark/serialize.pl and benchmark/deserialize.pl on my SC440(Linux 2.6.32-23-server #37-Ubuntu SMP).
+
+ -- serialize
+ JSON::XS: 2.3
+ Data::MessagePack: 0.20
+ Storable: 2.21
+ Benchmark: timing 1000000 iterations of json, mp, storable...
+ json: 5 wallclock secs ( 3.95 usr + 0.00 sys = 3.95 CPU) @ 253164.56/s (n=1000000)
+ mp: 3 wallclock secs ( 2.69 usr + 0.00 sys = 2.69 CPU) @ 371747.21/s (n=1000000)
+ storable: 26 wallclock secs (27.21 usr + 0.00 sys = 27.21 CPU) @ 36751.19/s (n=1000000)
+
+ -- deserialize
+ JSON::XS: 2.3
+ Data::MessagePack: 0.20
+ Storable: 2.21
+ Benchmark: timing 1000000 iterations of json, mp, storable...
+ json: 4 wallclock secs ( 4.45 usr + 0.00 sys = 4.45 CPU) @ 224719.10/s (n=1000000)
+ mp: 6 wallclock secs ( 5.45 usr + 0.00 sys = 5.45 CPU) @ 183486.24/s (n=1000000)
+ storable: 7 wallclock secs ( 7.77 usr + 0.00 sys = 7.77 CPU) @ 128700.13/s (n=1000000)
+
=head1 AUTHORS
Tokuhiro Matsuno
@@ -90,5 +138,5 @@ it under the same terms as Perl itself.
=head1 SEE ALSO
-L<http://msgpack.org/>
+L<http://msgpack.org/> is official web site for MessagePack format.
From b79c1345b92d8cdb6427e0d83d7191262331fd5a Mon Sep 17 00:00:00 2001
From: tokuhirom <tokuhirom@gmail.com>
Date: Fri, 10 Sep 2010 20:42:40 +0900
Subject: [PATCH 39/43] use gfx's standard header.
---
perl/README | 43 ++++++++++++++++++++++++-
perl/perlxs.h | 76 ++++++++++++++++++++++++++++++++++++++++++++
perl/xs-src/pack.c | 11 +------
perl/xs-src/unpack.c | 46 ++++++++++++---------------
4 files changed, 140 insertions(+), 36 deletions(-)
create mode 100644 perl/perlxs.h
diff --git a/perl/README b/perl/README
index 2ef686c2..d5fc2693 100644
--- a/perl/README
+++ b/perl/README
@@ -8,10 +8,29 @@ SYNOPSIS
DESCRIPTION
This module converts Perl data structures to MessagePack and vice versa.
+ABOUT MESSAGEPACK FORMAT
MessagePack is a binary-based efficient object serialization format. It
enables to exchange structured objects between many languages like JSON.
But unlike JSON, it is very fast and small.
+ ADVANTAGES
+ PORTABILITY
+ Messagepack is language independent binary serialize format.
+
+ SMALL SIZE
+ say length(JSON::XS::encode_json({a=>1, b=>2})); # => 13
+ say length(Storable::nfreeze({a=>1, b=>2})); # => 21
+ say length(Data::MessagePack->pack({a=>1, b=>2})); # => 7
+
+ MessagePack format saves memory than JSON and Storable format.
+
+ STREAMING DESERIALIZER
+ MessagePack supports streaming deserializer. It is useful for
+ networking such as RPC.
+
+ If you want to get more informations about messagepack format, please
+ visit to <http://msgpack.org/>.
+
METHODS
my $packed = Data::MessagePack->pack($data);
pack the $data to messagepack format string.
@@ -23,6 +42,28 @@ Configuration Variables
$Data::MessagePack::PreferInteger
Pack the string as int when the value looks like int(EXPERIMENTAL).
+SPEED
+ This is result of benchmark/serialize.pl and benchmark/deserialize.pl on
+ my SC440(Linux 2.6.32-23-server #37-Ubuntu SMP).
+
+ -- serialize
+ JSON::XS: 2.3
+ Data::MessagePack: 0.20
+ Storable: 2.21
+ Benchmark: timing 1000000 iterations of json, mp, storable...
+ json: 5 wallclock secs ( 3.95 usr + 0.00 sys = 3.95 CPU) @ 253164.56/s (n=1000000)
+ mp: 3 wallclock secs ( 2.69 usr + 0.00 sys = 2.69 CPU) @ 371747.21/s (n=1000000)
+ storable: 26 wallclock secs (27.21 usr + 0.00 sys = 27.21 CPU) @ 36751.19/s (n=1000000)
+
+ -- deserialize
+ JSON::XS: 2.3
+ Data::MessagePack: 0.20
+ Storable: 2.21
+ Benchmark: timing 1000000 iterations of json, mp, storable...
+ json: 4 wallclock secs ( 4.45 usr + 0.00 sys = 4.45 CPU) @ 224719.10/s (n=1000000)
+ mp: 6 wallclock secs ( 5.45 usr + 0.00 sys = 5.45 CPU) @ 183486.24/s (n=1000000)
+ storable: 7 wallclock secs ( 7.77 usr + 0.00 sys = 7.77 CPU) @ 128700.13/s (n=1000000)
+
AUTHORS
Tokuhiro Matsuno
@@ -40,5 +81,5 @@ LICENSE
under the same terms as Perl itself.
SEE ALSO
- <http://msgpack.org/>
+ <http://msgpack.org/> is official web site for MessagePack format.
diff --git a/perl/perlxs.h b/perl/perlxs.h
new file mode 100644
index 00000000..441682de
--- /dev/null
+++ b/perl/perlxs.h
@@ -0,0 +1,76 @@
+/*
+ perlxs.h - Standard XS header file
+ Copyright (c) Fuji, Goro (gfx)
+*/
+
+#ifdef __cplusplus
+extern "C" {
+#endif
+
+#define PERL_NO_GET_CONTEXT /* we want efficiency */
+#include <EXTERN.h>
+
+#include <perl.h>
+#define NO_XSLOCKS /* for exceptions */
+#include <XSUB.h>
+
+#ifdef __cplusplus
+} /* extern "C" */
+#endif
+
+#include "ppport.h"
+
+/* portability stuff not supported by ppport.h yet */
+
+#ifndef STATIC_INLINE /* from 5.13.4 */
+# if defined(__GNUC__) || defined(__cplusplus__) || (defined(__STDC_VERSION__) && (__STDC_VERSION__ >= 199901L))
+# define STATIC_INLINE static inline
+# else
+# define STATIC_INLINE static
+# endif
+#endif /* STATIC_INLINE */
+
+#ifndef __attribute__format__
+#define __attribute__format__(a,b,c) /* nothing */
+#endif
+
+#ifndef LIKELY /* they are just a compiler's hint */
+#define LIKELY(x) (x)
+#define UNLIKELY(x) (x)
+#endif
+
+#ifndef newSVpvs_share
+#define newSVpvs_share(s) Perl_newSVpvn_share(aTHX_ STR_WITH_LEN(s), 0U)
+#endif
+
+#ifndef get_cvs
+#define get_cvs(name, flags) get_cv(name, flags)
+#endif
+
+#ifndef GvNAME_get
+#define GvNAME_get GvNAME
+#endif
+#ifndef GvNAMELEN_get
+#define GvNAMELEN_get GvNAMELEN
+#endif
+
+#ifndef CvGV_set
+#define CvGV_set(cv, gv) (CvGV(cv) = (gv))
+#endif
+
+/* general utility */
+
+#if PERL_BCDVERSION >= 0x5008005
+#define LooksLikeNumber(x) looks_like_number(x)
+#else
+#define LooksLikeNumber(x) (SvPOKp(x) ? looks_like_number(x) : (I32)SvNIOKp(x))
+#endif
+
+#define newAV_mortal() (AV*)sv_2mortal((SV*)newAV())
+#define newHV_mortal() (HV*)sv_2mortal((SV*)newHV())
+
+#define DECL_BOOT(name) EXTERN_C XS(CAT2(boot_, name))
+#define CALL_BOOT(name) STMT_START { \
+ PUSHMARK(SP); \
+ CALL_FPTR(CAT2(boot_, name))(aTHX_ cv); \
+ } STMT_END
diff --git a/perl/xs-src/pack.c b/perl/xs-src/pack.c
index 93b2e2f4..62eb0024 100644
--- a/perl/xs-src/pack.c
+++ b/perl/xs-src/pack.c
@@ -2,16 +2,7 @@
* code is written by tokuhirom.
* buffer alocation technique is taken from JSON::XS. thanks to mlehmann.
*/
-#ifdef __cplusplus
-extern "C" {
-#endif
-#include "EXTERN.h"
-#include "perl.h"
-#include "XSUB.h"
-#include "ppport.h"
-#ifdef __cplusplus
-};
-#endif
+#include "perlxs.h"
#include "msgpack/pack_define.h"
diff --git a/perl/xs-src/unpack.c b/perl/xs-src/unpack.c
index eb6e0ddb..20a07372 100644
--- a/perl/xs-src/unpack.c
+++ b/perl/xs-src/unpack.c
@@ -2,13 +2,9 @@
extern "C" {
#endif
-#include "EXTERN.h"
-#include "perl.h"
-#include "XSUB.h"
-#include "util.h"
#define NEED_newRV_noinc
#define NEED_sv_2pv_flags
-#include "ppport.h"
+#include "perlxs.h"
#ifdef __cplusplus
};
@@ -38,7 +34,7 @@ typedef struct {
/* ---------------------------------------------------------------------- */
/* utility functions */
-static INLINE SV *
+STATIC_INLINE SV *
get_bool (const char *name) {
SV * sv = sv_mortalcopy(get_sv( name, 1 ));
@@ -60,19 +56,19 @@ static SV* template_data(msgpack_unpack_t* u);
static int template_execute(msgpack_unpack_t* u,
const char* data, size_t len, size_t* off);
-static INLINE SV* template_callback_root(unpack_user* u)
+STATIC_INLINE SV* template_callback_root(unpack_user* u)
{ return &PL_sv_undef; }
-static INLINE int template_callback_uint8(unpack_user* u, uint8_t d, SV** o)
+STATIC_INLINE int template_callback_uint8(unpack_user* u, uint8_t d, SV** o)
{ *o = sv_2mortal(newSVuv(d)); return 0; }
-static INLINE int template_callback_uint16(unpack_user* u, uint16_t d, SV** o)
+STATIC_INLINE int template_callback_uint16(unpack_user* u, uint16_t d, SV** o)
{ *o = sv_2mortal(newSVuv(d)); return 0; }
-static INLINE int template_callback_uint32(unpack_user* u, uint32_t d, SV** o)
+STATIC_INLINE int template_callback_uint32(unpack_user* u, uint32_t d, SV** o)
{ *o = sv_2mortal(newSVuv(d)); return 0; }
-static INLINE int template_callback_uint64(unpack_user* u, uint64_t d, SV** o)
+STATIC_INLINE int template_callback_uint64(unpack_user* u, uint64_t d, SV** o)
{
#if IVSIZE==4
*o = sv_2mortal(newSVnv(d));
@@ -82,47 +78,47 @@ static INLINE int template_callback_uint64(unpack_user* u, uint64_t d, SV** o)
return 0;
}
-static INLINE int template_callback_int8(unpack_user* u, int8_t d, SV** o)
+STATIC_INLINE int template_callback_int8(unpack_user* u, int8_t d, SV** o)
{ *o = sv_2mortal(newSViv((long)d)); return 0; }
-static INLINE int template_callback_int16(unpack_user* u, int16_t d, SV** o)
+STATIC_INLINE int template_callback_int16(unpack_user* u, int16_t d, SV** o)
{ *o = sv_2mortal(newSViv((long)d)); return 0; }
-static INLINE int template_callback_int32(unpack_user* u, int32_t d, SV** o)
+STATIC_INLINE int template_callback_int32(unpack_user* u, int32_t d, SV** o)
{ *o = sv_2mortal(newSViv((long)d)); return 0; }
-static INLINE int template_callback_int64(unpack_user* u, int64_t d, SV** o)
+STATIC_INLINE int template_callback_int64(unpack_user* u, int64_t d, SV** o)
{ *o = sv_2mortal(newSViv(d)); return 0; }
-static INLINE int template_callback_float(unpack_user* u, float d, SV** o)
+STATIC_INLINE int template_callback_float(unpack_user* u, float d, SV** o)
{ *o = sv_2mortal(newSVnv(d)); return 0; }
-static INLINE int template_callback_double(unpack_user* u, double d, SV** o)
+STATIC_INLINE int template_callback_double(unpack_user* u, double d, SV** o)
{ *o = sv_2mortal(newSVnv(d)); return 0; }
/* &PL_sv_undef is not so good. see http://gist.github.com/387743 */
-static INLINE int template_callback_nil(unpack_user* u, SV** o)
+STATIC_INLINE int template_callback_nil(unpack_user* u, SV** o)
{ *o = sv_newmortal(); return 0; }
-static INLINE int template_callback_true(unpack_user* u, SV** o)
+STATIC_INLINE int template_callback_true(unpack_user* u, SV** o)
{ *o = get_bool("Data::MessagePack::true") ; return 0; }
-static INLINE int template_callback_false(unpack_user* u, SV** o)
+STATIC_INLINE int template_callback_false(unpack_user* u, SV** o)
{ *o = get_bool("Data::MessagePack::false") ; return 0; }
-static INLINE int template_callback_array(unpack_user* u, unsigned int n, SV** o)
+STATIC_INLINE int template_callback_array(unpack_user* u, unsigned int n, SV** o)
{ AV* a = (AV*)sv_2mortal((SV*)newAV()); *o = sv_2mortal((SV*)newRV_inc((SV*)a)); av_extend(a, n); return 0; }
-static INLINE int template_callback_array_item(unpack_user* u, SV** c, SV* o)
+STATIC_INLINE int template_callback_array_item(unpack_user* u, SV** c, SV* o)
{ av_push((AV*)SvRV(*c), o); SvREFCNT_inc(o); return 0; } /* FIXME set value directry RARRAY_PTR(obj)[RARRAY_LEN(obj)++] */
-static INLINE int template_callback_map(unpack_user* u, unsigned int n, SV** o)
+STATIC_INLINE int template_callback_map(unpack_user* u, unsigned int n, SV** o)
{ HV * h = (HV*)sv_2mortal((SV*)newHV()); *o = sv_2mortal(newRV_inc((SV*)h)); return 0; }
-static INLINE int template_callback_map_item(unpack_user* u, SV** c, SV* k, SV* v)
+STATIC_INLINE int template_callback_map_item(unpack_user* u, SV** c, SV* k, SV* v)
{ hv_store_ent((HV*)SvRV(*c), k, v, 0); SvREFCNT_inc(v); return 0; }
-static INLINE int template_callback_raw(unpack_user* u, const char* b, const char* p, unsigned int l, SV** o)
+STATIC_INLINE int template_callback_raw(unpack_user* u, const char* b, const char* p, unsigned int l, SV** o)
{ *o = sv_2mortal((l==0) ? newSVpv("", 0) : newSVpv(p, l)); return 0; }
/* { *o = newSVpvn_flags(p, l, SVs_TEMP); return 0; } <= this does not works. */
From ef0a86e7ccc78bf632a3dea4b49fe8507d711151 Mon Sep 17 00:00:00 2001
From: tokuhirom <tokuhirom@gmail.com>
Date: Fri, 10 Sep 2010 20:45:17 +0900
Subject: [PATCH 40/43] perl: more inline
---
perl/xs-src/unpack.c | 6 +++---
1 file changed, 3 insertions(+), 3 deletions(-)
diff --git a/perl/xs-src/unpack.c b/perl/xs-src/unpack.c
index 20a07372..16a52d78 100644
--- a/perl/xs-src/unpack.c
+++ b/perl/xs-src/unpack.c
@@ -131,7 +131,7 @@ STATIC_INLINE int template_callback_raw(unpack_user* u, const char* b, const cha
#include "msgpack/unpack_template.h"
-SV* _msgpack_unpack(SV* data, int limit) {
+STATIC_INLINE SV* _msgpack_unpack(SV* data, int limit) {
msgpack_unpack_t mp;
unpack_user u = {0, &PL_sv_undef};
int ret;
@@ -194,7 +194,7 @@ XS(xs_unpack) {
/* ------------------------------ stream -- */
/* http://twitter.com/frsyuki/status/13249304748 */
-static void _reset(SV* self) {
+STATIC_INLINE void _reset(SV* self) {
unpack_user u = {0, &PL_sv_undef, 0};
UNPACKER(self, mp);
@@ -220,7 +220,7 @@ XS(xs_unpacker_new) {
XSRETURN(1);
}
-static SV* _execute_impl(SV* self, SV* data, UV off, I32 limit) {
+STATIC_INLINE SV* _execute_impl(SV* self, SV* data, UV off, I32 limit) {
UNPACKER(self, mp);
size_t from = off;
From 0cd31a4b96d1b8b4084083d3b7ed99b403338e2b Mon Sep 17 00:00:00 2001
From: tokuhirom <tokuhirom@gmail.com>
Date: Fri, 10 Sep 2010 21:00:27 +0900
Subject: [PATCH 41/43] perl: inlining utility functions
---
perl/xs-src/unpack.c | 2 +-
1 file changed, 1 insertion(+), 1 deletion(-)
diff --git a/perl/xs-src/unpack.c b/perl/xs-src/unpack.c
index 16a52d78..f82fe072 100644
--- a/perl/xs-src/unpack.c
+++ b/perl/xs-src/unpack.c
@@ -22,7 +22,7 @@ typedef struct {
struct template ## name
#define msgpack_unpack_func(ret, name) \
- ret template ## name
+ STATIC_INLINE ret template ## name
#define msgpack_unpack_callback(name) \
template_callback ## name
From 0c4f0de13dd9cfaa2f50b48177a0545e258c81b7 Mon Sep 17 00:00:00 2001
From: tokuhirom <tokuhirom@gmail.com>
Date: Fri, 10 Sep 2010 21:18:45 +0900
Subject: [PATCH 42/43] perl: inlining the small functions
---
perl/xs-src/pack.c | 10 +++++-----
1 file changed, 5 insertions(+), 5 deletions(-)
diff --git a/perl/xs-src/pack.c b/perl/xs-src/pack.c
index 62eb0024..e7a7c35b 100644
--- a/perl/xs-src/pack.c
+++ b/perl/xs-src/pack.c
@@ -43,7 +43,7 @@ static void need(enc_t *enc, STRLEN len);
#define ERR_NESTING_EXCEEDED "perl structure exceeds maximum nesting level (max_depth set too low?)"
-static void need(enc_t *enc, STRLEN len)
+STATIC_INLINE void need(enc_t *enc, STRLEN len)
{
if (enc->cur + len >= enc->end) {
STRLEN cur = enc->cur - (char *)SvPVX (enc->sv);
@@ -56,7 +56,7 @@ static void need(enc_t *enc, STRLEN len)
static int s_pref_int = 0;
-static int pref_int_set(pTHX_ SV* sv, MAGIC* mg) {
+STATIC_INLINE int pref_int_set(pTHX_ SV* sv, MAGIC* mg) {
if (SvTRUE(sv)) {
s_pref_int = 1;
} else {
@@ -85,7 +85,7 @@ void boot_Data__MessagePack_pack(void) {
}
-static int try_int(enc_t* enc, const char *p, size_t len) {
+STATIC_INLINE int try_int(enc_t* enc, const char *p, size_t len) {
int negative = 0;
const char* pe = p + len;
uint64_t num = 0;
@@ -141,7 +141,7 @@ static int try_int(enc_t* enc, const char *p, size_t len) {
static void _msgpack_pack_rv(enc_t *enc, SV* sv, int depth);
-static void _msgpack_pack_sv(enc_t *enc, SV* sv, int depth) {
+STATIC_INLINE void _msgpack_pack_sv(enc_t *enc, SV* sv, int depth) {
if (depth <= 0) Perl_croak(aTHX_ ERR_NESTING_EXCEEDED);
SvGETMAGIC(sv);
@@ -176,7 +176,7 @@ static void _msgpack_pack_sv(enc_t *enc, SV* sv, int depth) {
}
}
-static void _msgpack_pack_rv(enc_t *enc, SV* sv, int depth) {
+STATIC_INLINE void _msgpack_pack_rv(enc_t *enc, SV* sv, int depth) {
svtype svt;
if (depth <= 0) Perl_croak(aTHX_ ERR_NESTING_EXCEEDED);
SvGETMAGIC(sv);
From beb22844408b218a9ae7f494f3caa2aefe779a0e Mon Sep 17 00:00:00 2001
From: tokuhirom <tokuhirom@gmail.com>
Date: Fri, 10 Sep 2010 21:25:46 +0900
Subject: [PATCH 43/43] perl: added docs for circular reference and blessed
object.
---
perl/lib/Data/MessagePack.pm | 8 ++++++--
1 file changed, 6 insertions(+), 2 deletions(-)
diff --git a/perl/lib/Data/MessagePack.pm b/perl/lib/Data/MessagePack.pm
index fbf305a5..0229bcab 100644
--- a/perl/lib/Data/MessagePack.pm
+++ b/perl/lib/Data/MessagePack.pm
@@ -74,9 +74,13 @@ If you want to get more informations about messagepack format, please visit to L
=over 4
-=item my $packed = Data::MessagePack->pack($data);
+=item my $packed = Data::MessagePack->pack($data[, $max_depth]);
-pack the $data to messagepack format string.
+Pack the $data to messagepack format string.
+
+This method throws exception when nesting perl structure more than $max_depth(default: 512) for detecting circular reference.
+
+Data::MessagePack->pack() throws exception when encountered blessed object. Because MessagePack is language independent format.
=item my $unpacked = Data::MessagePack->unpack($msgpackstr);