Skip to content

Merge latest 2023 04 28 #51

New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

Open
wants to merge 3 commits into
base: master
Choose a base branch
from
Open
Changes from all commits
Commits
File filter

Filter by extension

Filter by extension

Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
3 changes: 2 additions & 1 deletion lib/Data/MessagePack.pm
Original file line number Diff line number Diff line change
@@ -36,7 +36,7 @@ sub new {
return bless \%args, $class;
}

foreach my $name(qw(canonical prefer_integer utf8)) {
foreach my $name(qw(canonical prefer_integer prefer_float32 utf8)) {
my $setter = sub {
my($self, $value) = @_;
$self->{$name} = defined($value) ? $value : 1;
@@ -49,6 +49,7 @@ foreach my $name(qw(canonical prefer_integer utf8)) {
no strict 'refs';
*{$name} = $setter;
*{'get_' . $name} = $getter;

}


16 changes: 15 additions & 1 deletion lib/Data/MessagePack/PP.pm
Original file line number Diff line number Diff line change
@@ -87,11 +87,17 @@ BEGIN {
my @v = unpack( 'V2', pack( 'q', $_[0] ) );
return pack 'CN2', 0xd3, @v[1,0];
};

*pack_double = $pack_double_oabi || sub {
my @v = unpack( 'V2', pack( 'd', $_[0] ) );
return pack 'CN2', 0xcb, @v[1,0];
};

*pack_float = sub {
my @v = unpack( 'V2', pack( 'f', $_[0] ) );
return pack 'CN2', 0xca, @v[1,0];
};

*unpack_float = sub {
my @v = unpack( 'v2', substr( $_[0], $_[1], 4 ) );
return unpack( 'f', pack( 'n2', @v[1,0] ) );
@@ -113,6 +119,7 @@ BEGIN {
else { # big endian
*pack_uint64 = sub { return pack 'CQ', 0xcf, $_[0]; };
*pack_int64 = sub { return pack 'Cq', 0xd3, $_[0]; };
*pack_float = sub { return pack 'Cf', 0xca, $_[0]; };
*pack_double = $pack_double_oabi || sub { return pack 'Cd', 0xcb, $_[0]; };

*unpack_float = sub { return unpack( 'f', substr( $_[0], $_[1], 4 ) ); };
@@ -139,6 +146,7 @@ BEGIN {
# pack_int64/uint64 are used only when the perl support quad types
*pack_uint64 = sub { return pack 'CQ>', 0xcf, $_[0]; };
*pack_int64 = sub { return pack 'Cq>', 0xd3, $_[0]; };
*pack_float = sub { return pack 'Cf>', 0xca, $_[0]; };
*pack_double = $pack_double_oabi || sub { return pack 'Cd>', 0xcb, $_[0]; };

*unpack_float = sub { return unpack( 'f>', substr( $_[0], $_[1], 4 ) ); };
@@ -175,6 +183,7 @@ sub pack :method {
Carp::croak('Usage: Data::MessagePack->pack($dat [,$max_depth])') if @_ < 2;
$_max_depth = defined $max_depth ? $max_depth : 512; # init

# back-compat
if(not ref $self) {
$self = $self->new(
prefer_integer => $Data::MessagePack::PreferInteger || 0,
@@ -271,7 +280,12 @@ sub _pack {
return $header . $value;

}
elsif( $flags & B::SVp_NOK ) { # double only
elsif( $flags & B::SVp_NOK ) {
# double unless user prefers single precision
if($self->{prefer_float32}) {
return pack_float( $value );
}

return pack_double( $value );
}
elsif ( $flags & B::SVp_IOK ) {
16 changes: 15 additions & 1 deletion t/01_pack.t
Original file line number Diff line number Diff line change
@@ -19,6 +19,13 @@ sub packit_utf8 {
$_;
}

sub packit_float32 {
local $_ = unpack("H*", Data::MessagePack->new->prefer_float32->pack($_[0]));
s/(..)/$1 /g;
s/ $//;
$_;
}

sub pis ($$) {
is packit($_[0]), $_[1], 'dump ' . $_[1];
}
@@ -27,6 +34,10 @@ sub pis_utf8 ($$) {
is packit_utf8($_[0]), $_[1], 'dump ' . $_[1];
}

sub pis_float32 ($$) {
is packit_float32($_[0]), $_[1], 'dump ' . $_[1];
}

my @dat = (
0, '00',
(my $foo="0")+0, '00',
@@ -88,7 +99,7 @@ my @dat_utf8 = (
'a' x 0x0100, 'da 01 00' . (' 61' x 0x0100),
);

plan tests => 1*(scalar(@dat)/2) + 1*(scalar(@dat_utf8)/2);
plan tests => 1*(scalar(@dat)/2) + 1*(scalar(@dat_utf8)/2) + 1;

for (my $i=0; $i<scalar(@dat); ) {
pis $dat[$i++], $dat[$i++];
@@ -97,3 +108,6 @@ for (my $i=0; $i<scalar(@dat); ) {
for (my $i=0; $i<scalar(@dat_utf8); ) {
pis_utf8 $dat_utf8[$i++], $dat_utf8[$i++];
}

pis_float32 1.0, 'ca 3f 80 00 00';

20 changes: 20 additions & 0 deletions t/25_single_float.t
Original file line number Diff line number Diff line change
@@ -0,0 +1,20 @@
#!perl
use strict;
use Config;
use if $Config{nvsize} > 8,
'Test::More', skip_all => 'long double is not supported';
use Test::More;
use Data::MessagePack;

my $mp = Data::MessagePack->new();
$mp->prefer_float32();

foreach my $float(0.123, 3.14) {
is $mp->unpack($mp->pack($float)), unpack('f', pack('f',$float));

scalar( $float > 0 );

is $mp->unpack($mp->pack($float)), unpack('f', pack('f',$float));
}
done_testing;

13 changes: 12 additions & 1 deletion xs-src/pack.c
Original file line number Diff line number Diff line change
@@ -19,6 +19,7 @@ typedef struct {
SV *sv; /* result scalar */

bool prefer_int;
bool prefer_float32;
bool canonical;
} enc_t;

@@ -191,7 +192,11 @@ STATIC_INLINE void _msgpack_pack_sv(pTHX_ enc_t* const enc, SV* const sv, int co
}
}
} else if (SvNOKp(sv)) {
msgpack_pack_double(enc, (double)SvNVX(sv));
if(enc->prefer_float32) {
msgpack_pack_float(enc, (float)SvNVX(sv));
} else {
msgpack_pack_double(enc, (double)SvNVX(sv));
}
} else if (SvIOKp(sv)) {
if(SvUOK(sv)) {
PACK_UV(enc, SvUVX(sv));
@@ -323,6 +328,7 @@ XS(xs_pack) {
// setup configuration
dMY_CXT;
enc.prefer_int = MY_CXT.prefer_int; // back compat
enc.prefer_float32 = false;
if(SvROK(self) && SvTYPE(SvRV(self)) == SVt_PVHV) {
HV* const hv = (HV*)SvRV(self);
SV** svp;
@@ -332,6 +338,11 @@ XS(xs_pack) {
enc.prefer_int = SvTRUE(*svp) ? true : false;
}

svp = hv_fetchs(hv, "prefer_float32", FALSE);
if(svp) {
enc.prefer_float32 = SvTRUE(*svp) ? true : false;
}

svp = hv_fetchs(hv, "canonical", FALSE);
if(svp) {
enc.canonical = SvTRUE(*svp) ? true : false;
1 change: 1 addition & 0 deletions xs-src/unpack.c
Original file line number Diff line number Diff line change
@@ -1,5 +1,6 @@
#define NEED_newRV_noinc
#define NEED_sv_2pv_flags
#include "msgpack/unpack.h"
#include "xshelper.h"

#define MY_CXT_KEY "Data::MessagePack::_unpack_guts" XS_VERSION