Merge latest 2023 04 28

lib/Data/MessagePack.pm

@@ -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;
+
 }
 
 

lib/Data/MessagePack/PP.pm

@@ -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 ) {

t/01_pack.t

@@ -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';
+

t/25_single_float.t

@@ -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;
+

xs-src/pack.c

@@ -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;

xs-src/unpack.c

@@ -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