Types serialiser

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 utf8 prefer_types_serialiser)) {
     my $setter = sub {
         my($self, $value) = @_;
         $self->{$name} = defined($value) ? $value : 1;
@@ -109,6 +109,25 @@ details.
 If you want to get more information about the MessagePack format,
 please visit to L<http://msgpack.org/>.
 
+=head1 ABOUT BOOLEANS
+
+Because Perl lacks a boolean type, this module follows the following
+conventions:
+
+=over
+
+=item * C<Types::Serialiser::true> and C<Data::MessagePack::Boolean::true>
+are serialized as boolean true. Likewise, C<Types::Serialiser::false> and
+C<Data::MessagePack::Boolean::false> are serialized as boolean false.
+
+=item * By default, this module’s C<unpack> method recreates boolean
+values as either C<Data::MessagePack::Boolean::true> or
+C<Data::MessagePack::Boolean::false>. If you enable the
+C<prefer_types_serialiser> flag, then C<unpack> will use
+C<Types::Serialiser::true> and C<Types::Serialiser::false> instead.
+
+=back
+
 =head1 METHODS
 
 =over
@@ -158,6 +177,15 @@ apply C<utf8::encode()> to all the string values.
 In other words, this property tell C<$mp> to deal with B<text strings>.
 See L<perlunifaq> for the meaning of B<text string>.
 
+=item C<< $mp = $mp->prefer_types_serialiser([ $enable ]) >>
+
+=item C<< $enabled = $mp->get_prefer_types_serialiser() >>
+
+If I<$enable> is true (or missing), then the C<unpack> method will use
+L<Types::Serialiser> (rather than C<Data::MessagePack::Boolean>) to represent
+boolean values. This is useful for interoperability with other Perl
+serialization modules like L<JSON>.
+
 =item C<< $packed = $mp->pack($data) >>
 
 =item C<< $packed = $mp->encode($data) >>

lib/Data/MessagePack/PP.pm

@@ -223,7 +223,7 @@ sub _pack {
         }
     }
 
-    elsif ( ref( $value ) eq 'Data::MessagePack::Boolean' ) {
+    elsif ( ref( $value ) eq 'Data::MessagePack::Boolean' || ref( $value )->isa('Types::Serialiser::Boolean') ) {
         return  CORE::pack( 'C', ${$value} ? 0xc3 : 0xc2 );
     }
 
@@ -307,9 +307,14 @@ sub _insufficient {
     Carp::confess("Insufficient bytes (pos=$p, type=@_)");
 }
 
+my @byte2value;
+
 sub unpack :method {
     $p = 0; # init
     $_utf8 = (ref($_[0]) && $_[0]->{utf8}) || $_utf8;
+
+    local @byte2value[ 0xc3, 0xc2 ] = ( $Types::Serialiser::true, $Types::Serialiser::false ) if $_[0]->{'prefer_types_serialiser'};
+
     my $data = _unpack( $_[1] );
     if($p < length($_[1])) {
         Carp::croak("Data::MessagePack->unpack: extra bytes");
@@ -347,7 +352,6 @@ $typemap[$_] |= $T_BIN for
     0xc6,         # bin 32
 ;
 
-my @byte2value;
 foreach my $pair(
     [0xc3, true],
     [0xc2, false],

t/60_types_serialiser.t

@@ -0,0 +1,24 @@
+use Test::More;
+
+use strict;
+use warnings;
+
+use Data::MessagePack;
+
+if ( eval { require Types::Serialiser } ) {
+    plan tests => 1;
+
+    my $mp = Data::MessagePack->new();
+
+    $mp->prefer_types_serialiser(1);
+
+    my $src = [ Types::Serialiser::false(), Types::Serialiser::true() ];
+
+    my $enc = $mp->pack($src);
+    my $dec = $mp->unpack($enc);
+
+    is_deeply( $dec, $src, 'round-trip' ) or diag explain $dec;
+}
+else {
+    plan skip_all => $@;
+};

t/61_types_serialiser_pp.t

@@ -0,0 +1,26 @@
+use Test::More;
+
+use strict;
+use warnings;
+
+BEGIN { $ENV{PERL_ONLY} = 1 }
+
+use Data::MessagePack;
+
+if ( eval { require Types::Serialiser } ) {
+    plan tests => 1;
+
+    my $mp = Data::MessagePack->new();
+
+    $mp->prefer_types_serialiser(1);
+
+    my $src = [ Types::Serialiser::false(), Types::Serialiser::true() ];
+
+    my $enc = $mp->pack($src);
+    my $dec = $mp->unpack($enc);
+
+    is_deeply( $dec, $src, 'round-trip' ) or diag explain $dec;
+}
+else {
+    plan skip_all => $@;
+};

xs-src/MessagePack.xs

@@ -9,6 +9,8 @@ XS(xs_unpack);
 XS(xs_unpacker_new);
 XS(xs_unpacker_utf8);
 XS(xs_unpacker_get_utf8);
+XS(xs_unpacker_prefer_types_serialiser);
+XS(xs_unpacker_get_prefer_types_serialiser);
 XS(xs_unpacker_execute);
 XS(xs_unpacker_execute_limit);
 XS(xs_unpacker_is_finished);
@@ -38,6 +40,9 @@ BOOT:
     newXS("Data::MessagePack::Unpacker::data",          xs_unpacker_data, __FILE__);
     newXS("Data::MessagePack::Unpacker::reset",         xs_unpacker_reset, __FILE__);
     newXS("Data::MessagePack::Unpacker::DESTROY",       xs_unpacker_destroy, __FILE__);
+
+    newXS("Data::MessagePack::Unpacker::prefer_types_serialiser",          xs_unpacker_prefer_types_serialiser, __FILE__);
+    newXS("Data::MessagePack::Unpacker::get_prefer_types_serialiser",      xs_unpacker_get_prefer_types_serialiser, __FILE__);
 }
 
 #ifdef USE_ITHREADS

xs-src/pack.c

@@ -231,8 +231,17 @@ STATIC_INLINE void _msgpack_pack_rv(pTHX_ enc_t *enc, SV* sv, int depth, bool ut
                 msgpack_pack_false(enc);
             }
         } else {
-            croak ("encountered object '%s', Data::MessagePack doesn't allow the object",
-                           SvPV_nolen(sv_2mortal(newRV_inc(sv))));
+            HV *stash = gv_stashpv ("Types::Serialiser::Boolean", 1); // TODO: cache?
+            if (stash && (SvSTASH (sv) == stash)) {
+                if (SvIV(sv)) {
+                    msgpack_pack_true(enc);
+                } else {
+                    msgpack_pack_false(enc);
+                }
+            } else {
+                croak ("encountered object '%s', Data::MessagePack doesn't allow the object",
+                            SvPV_nolen(sv_2mortal(newRV_inc(sv))));
+            }
         }
     } else if (svt == SVt_PVHV) {
         HV* hval = (HV*)sv;

xs-src/unpack.c

@@ -13,9 +13,10 @@ START_MY_CXT
 typedef struct {
     bool finished;
     bool utf8;
+    bool prefer_types_serialiser;
     SV*  buffer;
 } unpack_user;
-#define UNPACK_USER_INIT { false, false, NULL }
+#define UNPACK_USER_INIT { false, false, false, NULL }
 
 #include "msgpack/unpack_define.h"
 
@@ -47,8 +48,6 @@ void init_Data__MessagePack_unpack(pTHX_ bool const cloning) {
     MY_CXT.msgpack_false = NULL;
 }
 
-
-
 /* ---------------------------------------------------------------------- */
 /* utility functions                                                      */
 
@@ -74,18 +73,26 @@ load_bool(pTHX_ const char* const name) {
 }
 
 static SV*
-get_bool(bool const value) {
+get_bool(unpack_user* u, bool const value) {
     dTHX;
     dMY_CXT;
     if(value) {
         if(!MY_CXT.msgpack_true) {
-            MY_CXT.msgpack_true = load_bool(aTHX_ "Data::MessagePack::true");
+            if(u->prefer_types_serialiser) {
+                MY_CXT.msgpack_true = load_bool(aTHX_ "Types::Serialiser::true");
+            } else {
+                MY_CXT.msgpack_true = load_bool(aTHX_ "Data::MessagePack::true");
+            }
         }
         return newSVsv(MY_CXT.msgpack_true);
     }
     else {
         if(!MY_CXT.msgpack_false) {
-            MY_CXT.msgpack_false = load_bool(aTHX_ "Data::MessagePack::false");
+            if(u->prefer_types_serialiser) {
+                MY_CXT.msgpack_false = load_bool(aTHX_ "Types::Serialiser::false");
+            } else {
+                MY_CXT.msgpack_false = load_bool(aTHX_ "Data::MessagePack::false");
+            }
         }
         return newSVsv(MY_CXT.msgpack_false);
     }
@@ -208,15 +215,15 @@ STATIC_INLINE int template_callback_nil(unpack_user* u PERL_UNUSED_DECL, SV** o)
     return 0;
 }
 
-STATIC_INLINE int template_callback_true(unpack_user* u PERL_UNUSED_DECL, SV** o)
+STATIC_INLINE int template_callback_true(unpack_user* u, SV** o)
 {
-    *o = get_bool(true);
+    *o = get_bool(u, true);
     return 0;
 }
 
-STATIC_INLINE int template_callback_false(unpack_user* u PERL_UNUSED_DECL, SV** o)
+STATIC_INLINE int template_callback_false(unpack_user* u, SV** o)
 {
-    *o = get_bool(false);
+    *o = get_bool(u, false);
     return 0;
 }
 
@@ -313,6 +320,11 @@ XS(xs_unpack) {
         if(svp) {
             u.utf8 = SvTRUE(*svp) ? true : false;
         }
+
+        svp = hv_fetchs(hv, "prefer_types_serialiser", FALSE);
+        if(svp) {
+            u.prefer_types_serialiser = SvTRUE(*svp) ? true : false;
+        }
     }
 
     if (!(items == 2 || items == 3)) {
@@ -372,10 +384,35 @@ XS(xs_unpacker_new) {
     XSRETURN(1);
 }
 
+XS(xs_unpacker_prefer_types_serialiser) {
+    dXSARGS;
+    if (!(items == 1 || items == 2)) {
+        Perl_croak(aTHX_ "Usage: $unpacker->prefer_types_serialiser([$bool])");
+    }
+    UNPACKER(ST(0), mp);
+    mp->user.prefer_types_serialiser = (items == 1 || sv_true(ST(1))) ? true : false;
+
+    dMY_CXT;
+    MY_CXT.msgpack_true  = NULL;
+    MY_CXT.msgpack_false = NULL;
+
+    XSRETURN(1); // returns $self
+}
+
+XS(xs_unpacker_get_prefer_types_serialiser) {
+    dXSARGS;
+    if (items != 1) {
+        Perl_croak(aTHX_ "Usage: $unpacker->get_prefer_types_serialiser()");
+    }
+    UNPACKER(ST(0), mp);
+    ST(0) = boolSV(mp->user.prefer_types_serialiser);
+    XSRETURN(1);
+}
+
 XS(xs_unpacker_utf8) {
     dXSARGS;
     if (!(items == 1 || items == 2)) {
-        Perl_croak(aTHX_ "Usage: $unpacker->utf8([$bool)");
+        Perl_croak(aTHX_ "Usage: $unpacker->utf8([$bool])");
     }
     UNPACKER(ST(0), mp);
     mp->user.utf8 = (items == 1 || sv_true(ST(1))) ? true : false;