Bug #64917 for Storable-AMF: Boolean support, TO_AMF hook

Ugh. Sorry about this - the original patch doesn't work if you have multiple true/false values, as booleans cannot be referenced as AMF objects. I have refactored to avoid adding booleans to the HV_HASH and to avoid polluting HV_HASH with objects that have TO_AMF, but I'm not entirely sure it's bug-free, and the TO_AMF code feels bad in that I'm having to recurse and return.

--- Storable-AMF-0.88/lib/Storable/AMF.xs 2010-11-27 20:02:57.000000000 +0000 +++ Storable-AMF-0.88_patch/lib/Storable/AMF.xs 2011-01-20 11:27:06.000000000 +0000 @@ -576,45 +576,90 @@ inline void format_one(pTHX_ struct io_struct *io, SV * one){ - if (SvROK(one)){ + if ( SvROK(one) && sv_isobject(one) ) { SV * rv = (SV*) SvRV(one); - // test has stored - SV **OK = hv_fetch(io->RV_HASH, (char *)(&rv), sizeof (rv), 1); - if (SvOK(*OK)) { - format_reference(aTHX_ io, *OK); + GV *to_amf = gv_fetchmethod_autoload (SvSTASH (rv), "TO_AMF", 0); + if ( to_amf ) { + dSP; + + ENTER; SAVETMPS; PUSHMARK (SP); + XPUSHs (sv_bless (sv_2mortal (newRV_inc (rv)), SvSTASH (rv))); + PUTBACK; + + // calling with G_SCALAR ensures that we always get a 1 return value + call_sv ((SV *)GvCV (to_amf), G_SCALAR); + SPAGAIN; + + // catch this surprisingly common error + if (SvROK (TOPs) && SvRV (TOPs) == rv) + croak ("%s::TO_AMF method returned same object as was passed instead of a new one", HvNAME (SvSTASH (rv))); + + SV *newsv = POPs; + // recurse rather than carrying on as we need to freetmps etc + format_one( aTHX_ io, newsv); + PUTBACK; + FREETMPS; LEAVE; + return; } - else { - int type = SvTYPE(rv); - sv_setiv(*OK, io->RV_COUNT); - ++io->RV_COUNT; + } + + bool is_perl_ref = SvROK(one) ? 1 : 0; + bool is_perl_bool = 0; + if ( is_perl_ref && sv_isobject(one) ) { + if ( sv_isa(one, "boolean") ) { + is_perl_bool = 1; + } + else if ( sv_isa(one, "JSON::XS::Boolean") ) { + is_perl_bool = 1; + } + } - if (sv_isobject(one)) { - if (SvTYPE(rv) == SVt_PVHV){ - format_typed_object(aTHX_ io, (HV *) rv); + if ( is_perl_ref ){ + // Bools cannot be referenced + if ( is_perl_bool ) { + io_write_marker(aTHX_ io, MARKER0_BOOLEAN ); + io_write_u8(aTHX_ io, SvIV(SvRV(one))); + } + else { + SV * rv = (SV*) SvRV(one); + // test has stored + SV **OK = hv_fetch(io->RV_HASH, (char *)(&rv), sizeof (rv), 1); + if (SvOK(*OK)) { + format_reference(aTHX_ io, *OK); + } + else { + int type = SvTYPE(rv); + sv_setiv(*OK, io->RV_COUNT); + ++io->RV_COUNT; + + if (sv_isobject(one)) { + if (SvTYPE(rv) == SVt_PVHV){ + format_typed_object(aTHX_ io, (HV *) rv); + } + else if ( util_is_date( rv ) ) { + io_write_marker(aTHX_ io, MARKER0_DATE ); + io_write_double(aTHX_ io, util_date_time( rv )); + io_write_s16(aTHX_ io, 0 ); + } + else { + // may be i has to format as undef + io_register_error(io, ERR_BAD_OBJECT); + } } - else if ( util_is_date( rv ) ) { - io_write_marker(aTHX_ io, MARKER0_DATE ); - io_write_double(aTHX_ io, util_date_time( rv )); - io_write_s16(aTHX_ io, 0 ); - } - else { - // may be i has to format as undef + else if (SvTYPE(rv) == SVt_PVAV) + format_strict_array(aTHX_ io, (AV*) rv); + else if (SvTYPE(rv) == SVt_PVHV) { + io_write_marker(aTHX_ io, MARKER0_OBJECT); + format_object(aTHX_ io, (HV*) rv); + } + else if ( type != SVt_PVCV && type != SVt_PVGV ) { + format_scalar_ref(aTHX_ io, (SV*) rv); + } + else { + io->message = "bad type of object in stream"; io_register_error(io, ERR_BAD_OBJECT); } } - else if (SvTYPE(rv) == SVt_PVAV) - format_strict_array(aTHX_ io, (AV*) rv); - else if (SvTYPE(rv) == SVt_PVHV) { - io_write_marker(aTHX_ io, MARKER0_OBJECT); - format_object(aTHX_ io, (HV*) rv); - } - else if ( type != SVt_PVCV && type != SVt_PVGV ) { - format_scalar_ref(aTHX_ io, (SV*) rv); - } - else { - io->message = "bad type of object in stream"; - io_register_error(io, ERR_BAD_OBJECT); - } } } else { @@ -1285,7 +1330,33 @@ STATIC_INLINE SV* parse_boolean(pTHX_ struct io_struct * io){ char marker; marker = io_read_marker(io); - return newSViv(marker == '\000' ? 0 :1); + + int count; + SV *value = 0; + SAVETMPS; + + dSP; + + ENTER; SAVETMPS; PUSHMARK (SP); + PUTBACK; + if ( marker == '\000' ) { + count = call_pv("JSON::XS::false", G_SCALAR); + } + else { + count = call_pv("JSON::XS::true", G_SCALAR); + } + SPAGAIN; + if (count == 1) + value = newSVsv(POPs); + + if (count != 1 || !SvOK(value)) { + // fallback, return 0/1 + value = newSViv( marker == '\000' ? 0 : 1 ); + } + + PUTBACK; + FREETMPS; LEAVE; + return value; } inline SV * amf3_parse_one(pTHX_ struct io_struct *io);

use strict; use ExtUtils::testlib; use Storable::AMF0 qw(parse_option freeze thaw new_amfdate); use Data::Dumper; use Devel::Peek; use JSON::XS; use boolean; my $total = 13; #*CORE::GLOBAL::caller = sub { CORE::caller($_[0] + $Carp::CarpLevel + 1) }; use warnings; eval "use Test::More tests=>$total;"; warn $@ if $@; my $nop = parse_option('prefer_number'); our $var; # constants ok( !is_amf_boolean ( !!1 ), 'perl bool context not converted(t)'); ok( !is_amf_boolean ( !!0 ), 'perl bool context not converted(f)'); ok( is_amf_boolean ( true ), '"boolean" true'); ok( is_amf_boolean ( false ), '"boolean" false'); ok( is_amf_boolean ( JSON::XS::true ), 'JSON::XS::true'); ok( is_amf_boolean ( JSON::XS::false ), 'JSON::XS::false'); # Vars ok( !is_amf_boolean ( $a = 4 ), 'int var'); ok( !is_amf_boolean ( $a = 4.0 ), 'double var'); ok( !is_amf_boolean ( $a = "4" ), 'str var'); ok( is_amf_boolean ( $a = JSON::XS::true ), 'JSON::XS bool var'); ok( is_amf_boolean ( $a = true ), 'boolean var'); # booleans cannot be referenced in amf my $object = { a => {a => 1}, jxb1 => JSON::XS::true, jxb2 => JSON::XS::true, c => {a => 1, jxb3 => JSON::XS::true }, }; is_deeply( amf_roundtrip($object), $object, "roundtrip multi-bool" ); is_deeply( amf_roundtrip( true ), JSON::XS::true, '"boolean" comes back as JSON::XS' ); sub is_amf_boolean{ ord( freeze( $_[0], $_[1]||0 )) == 1; } sub amf_roundtrip { my $src = shift; #use Data::Dumper; #print "src: ", Dumper($src); my $amf = freeze( $src ); #diag( "stored: $amf" ); #diag( "stored(hex): ", unpack("H*", $amf) ); my $struct = thaw($amf); #diag(Dumper($struct)); return $struct; }