generic-library/msgpack
1
0
Fork 0
mirror of https://github.com/msgpack/msgpack-c.git synced 2025-10-21 15:51:44 +02:00
Code Issues Projects Releases Wiki Activity

removed dependency on Data::Float

Browse Source
This commit is contained in:
makamaka
2010-09-02 23:45:05 +09:00
parent 918dbd1926
commit 8f43e033a4
2 changed files with 28 additions and 47 deletions
Download Patch File Download Diff File Expand all files Collapse all files

5
perl/Makefile.PL
View File

@@ -21,12 +21,9 @@ if ( $] >= 5.008005 and $use_xs ) {
if ($ENV{DEBUG}) { if ($ENV{DEBUG}) {
cc_append_to_ccflags '-g'; 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"; print "configure PP version\n";
requires 'Data::Float' => 0 if ( $] < 5.010 );
} }
clean_files qw{ clean_files qw{

70
perl/lib/Data/MessagePack/PP.pm
View File

@@ -22,37 +22,19 @@ use B ();
BEGIN { BEGIN {
# for pack and unpack compatibility # for pack and unpack compatibility
if ( $] < 5.010 ) { if ( $] < 5.010 ) {
require Data::Float; my $bo_is_le = unpack ( 'd', "\x00\x00\x00\x00\x00\x00\xf0\x3f") == 1; # 1.0LE
*pack_double = sub { *pack_double = $bo_is_le ? sub {
my $float_hex = Data::Float::float_hex( $_[0] ); my @v = unpack( 'V2', pack( 'd', $_[0] ) );
my ( $sign, $sgnf, $exp ) = $float_hex =~ /^([-+])0x1\.([a-z0-9]+)p([-+][\d]+)$/; return pack 'CN2', 0xcb, @v[1,0];
my @bits; } : sub { pack 'Cd', 0xcb, $_[0]; };
*unpack_float = $bo_is_le ? sub {
$sign = $sign eq '-' ? 1 : 0; my @v = unpack( 'v2', substr( $_[0], $_[1], 4 ) );
$exp = sprintf( '%011b', 1023 + $exp ); return unpack( 'f', pack( 'n2', @v[1,0] ) );
} : sub { return unpack( 'f', substr( $_[0], $_[1], 4 ) ); };
my $bit = $sign . $exp . join( '', map { unpack('B4', pack('H', $_) ) } split //, $sgnf ); *unpack_double = $bo_is_le ? sub {
my @v = unpack( 'V2', substr( $_[0], $_[1], 8 ) );
while ( $bit =~ /(.{8})/g ) { return unpack( 'd', pack( 'N2', @v[1,0] ) );
push @bits, $1; } : sub { return unpack( 'd', substr( $_[0], $_[1], 8 ) ); };
}
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 { *unpack_int16 = sub {
my $v = unpack 'n', substr( $_[0], $_[1], 2 ); my $v = unpack 'n', substr( $_[0], $_[1], 2 );
return $v ? $v - 0x10000 : 0; return $v ? $v - 0x10000 : 0;
@@ -62,14 +44,16 @@ BEGIN {
return $v ? -(~$v + 1) : $v; return $v ? -(~$v + 1) : $v;
}; };
*unpack_int64 = sub { Carp::croak("unpack_int64 is disable in less than Perl 5.10"); }; *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 { else {
*pack_double = sub { return pack 'Cd>', 0xcb, $_[0]; }; *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_float = sub { return unpack( 'f>', substr( $_[0], $_[1], 4 ) ); };
*unpack_int16 = sub { return unpack 'n!', substr( $_[0], $_[1], 2 ); }; *unpack_double = sub { return unpack( 'd>', substr( $_[0], $_[1], 8 ) ); };
*unpack_int32 = sub { return unpack 'N!', substr( $_[0], $_[1], 4 ); }; *unpack_int16 = sub { return unpack( 'n!', substr( $_[0], $_[1], 2 ) ); };
*unpack_int64 = sub { return unpack 'Q>', substr( $_[0], $_[1], 8 ); }; *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. # for 5.8 etc.
unless ( defined &utf8::is_utf8 ) { unless ( defined &utf8::is_utf8 ) {
@@ -272,7 +256,7 @@ sub _unpack {
} }
elsif ( $byte == 0xcf ) { # unit64 elsif ( $byte == 0xcf ) { # unit64
$p += 8; $p += 8;
return CORE::unpack 'Q>', substr( $value, $p - 8, 8 ); return pack_uint64( $value, $p - 8 );
} }
elsif ( $byte == 0xd3 ) { # int64 elsif ( $byte == 0xd3 ) { # int64
$p += 8; $p += 8;
@@ -516,25 +500,25 @@ __END__
=head1 NAME =head1 NAME
Data::MessagePack::PP - Pure Perl version of Data::MessagePack 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 requires L<Data::Float> and cannot unpack int64 and float (pack int64 too).
=head1 SEE ALSO =head1 SEE ALSO
L<http://msgpack.sourceforge.jp/>, L<http://msgpack.sourceforge.jp/>,
L<Data::MessagePack>, L<Data::MessagePack>,
L<Data::Float>,
L<http://frox25.no-ip.org/~mtve/wiki/MessagePack.html>, L<http://frox25.no-ip.org/~mtve/wiki/MessagePack.html>,
=head1 AUTHOR =head1 AUTHOR
makamaka 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 =head1 COPYRIGHT AND LICENSE
This library is free software; you can redistribute it and/or modify This library is free software; you can redistribute it and/or modify