--- CBOR-XS/XS.xs 2013/10/27 10:17:12 1.9 +++ CBOR-XS/XS.xs 2013/10/29 18:37:31 1.15 @@ -11,6 +11,17 @@ #include "ecb.h" +// compatibility with perl <5.18 +#ifndef HvNAMELEN_get +# define HvNAMELEN_get(hv) strlen (HvNAME (hv)) +#endif +#ifndef HvNAMELEN +# define HvNAMELEN(hv) HvNAMELEN_get (hv) +#endif +#ifndef HvNAMEUTF8 +# define HvNAMEUTF8(hv) 0 +#endif + // known tags enum cbor_tag { @@ -62,8 +73,8 @@ # define CBOR_STASH cbor_stash #endif -static HV *cbor_stash, *cbor_boolean_stash, *cbor_tagged_stash; // CBOR::XS:: -static SV *cbor_true, *cbor_false; +static HV *cbor_stash, *types_boolean_stash, *types_error_stash, *cbor_tagged_stash; // CBOR::XS:: +static SV *types_true, *types_false, *types_error, *sv_cbor; typedef struct { U32 flags; @@ -261,16 +272,24 @@ if (ecb_expect_false (SvOBJECT (sv))) { - HV *boolean_stash = !CBOR_SLOW || cbor_boolean_stash - ? cbor_boolean_stash - : gv_stashpv ("CBOR::XS::Boolean", 1); + HV *boolean_stash = !CBOR_SLOW || types_boolean_stash + ? types_boolean_stash + : gv_stashpv ("Types::Serialiser::Boolean", 1); + HV *error_stash = !CBOR_SLOW || types_error_stash + ? types_error_stash + : gv_stashpv ("Types::Serialiser::Error", 1); HV *tagged_stash = !CBOR_SLOW || cbor_tagged_stash ? cbor_tagged_stash : gv_stashpv ("CBOR::XS::Tagged" , 1); - if (SvSTASH (sv) == boolean_stash) + HV *stash = SvSTASH (sv); + GV *method; + + if (stash == boolean_stash) encode_ch (enc, SvIV (sv) ? 0xe0 | 21 : 0xe0 | 20); - else if (SvSTASH (sv) == tagged_stash) + else if (stash == error_stash) + encode_ch (enc, 0xe0 | 23); + else if (stash == tagged_stash) { if (svt != SVt_PVAV) croak ("encountered CBOR::XS::Tagged object that isn't an array"); @@ -278,38 +297,61 @@ encode_uint (enc, 0xc0, SvUV (*av_fetch ((AV *)sv, 0, 1))); encode_sv (enc, *av_fetch ((AV *)sv, 1, 1)); } - else + else if ((method = gv_fetchmethod_autoload (stash, "TO_CBOR", 0))) { + dSP; + + ENTER; SAVETMPS; PUSHMARK (SP); // we re-bless the reference to get overload and other niceties right - GV *to_cbor = gv_fetchmethod_autoload (SvSTASH (sv), "TO_CBOR", 0); + XPUSHs (sv_bless (sv_2mortal (newRV_inc (sv)), stash)); - if (to_cbor) - { - dSP; + PUTBACK; + // G_SCALAR ensures that return value is 1 + call_sv ((SV *)GvCV (method), G_SCALAR); + SPAGAIN; - ENTER; SAVETMPS; PUSHMARK (SP); - XPUSHs (sv_bless (sv_2mortal (newRV_inc (sv)), SvSTASH (sv))); + // catch this surprisingly common error + if (SvROK (TOPs) && SvRV (TOPs) == sv) + croak ("%s::TO_CBOR method returned same object as was passed instead of a new one", HvNAME (stash)); - // calling with G_SCALAR ensures that we always get a 1 return value - PUTBACK; - call_sv ((SV *)GvCV (to_cbor), G_SCALAR); - SPAGAIN; + encode_sv (enc, POPs); - // catch this surprisingly common error - if (SvROK (TOPs) && SvRV (TOPs) == sv) - croak ("%s::TO_CBOR method returned same object as was passed instead of a new one", HvNAME (SvSTASH (sv))); + PUTBACK; - sv = POPs; - PUTBACK; + FREETMPS; LEAVE; + } + else if ((method = gv_fetchmethod_autoload (stash, "FREEZE", 0)) != 0) + { + dSP; - encode_sv (enc, sv); + ENTER; SAVETMPS; PUSHMARK (SP); + EXTEND (SP, 2); + // we re-bless the reference to get overload and other niceties right + PUSHs (sv_bless (sv_2mortal (newRV_inc (sv)), stash)); + PUSHs (sv_cbor); - FREETMPS; LEAVE; - } - else - croak ("encountered object '%s', but no TO_CBOR method available on it", - SvPV_nolen (sv_2mortal (newRV_inc (sv)))); + PUTBACK; + int count = call_sv ((SV *)GvCV (method), G_ARRAY); + SPAGAIN; + + // catch this surprisingly common error + if (count == 1 && SvROK (TOPs) && SvRV (TOPs) == sv) + croak ("%s::FREEZE(CBOR) method returned same object as was passed instead of a new one", HvNAME (stash)); + + encode_uint (enc, 0xc0, CBOR_TAG_PERL_OBJECT); + encode_uint (enc, 0x80, count + 1); + encode_str (enc, HvNAMEUTF8 (stash), HvNAME (stash), HvNAMELEN (stash)); + + while (count) + encode_sv (enc, SP[1 - count--]); + + PUTBACK; + + FREETMPS; LEAVE; } + else + croak ("encountered object '%s', but no TO_CBOR or FREEZE methods available on it", + SvPV_nolen (sv_2mortal (newRV_inc (sv)))); } else if (svt == SVt_PVHV) encode_hv (enc, (HV *)sv); @@ -569,6 +611,7 @@ SV *v = decode_sv (dec); hv_store_ent (hv, k, v, 0); + SvREFCNT_dec (k); } } else @@ -581,6 +624,7 @@ SV *v = decode_sv (dec); hv_store_ent (hv, k, v, 0); + SvREFCNT_dec (k); } } @@ -645,24 +689,61 @@ if (tag == CBOR_TAG_MAGIC) return sv; - - if (tag == CBOR_TAG_PERL_OBJECT) + else if (tag == CBOR_TAG_PERL_OBJECT) { if (!SvROK (sv) || SvTYPE (SvRV (sv)) != SVt_PVAV) ERR ("corrupted CBOR data (non-array perl object)"); + + AV *av = (AV *)SvRV (sv); + int len = av_len (av) + 1; + HV *stash = gv_stashsv (*av_fetch (av, 0, 1), 0); + + if (!stash) + ERR ("cannot decode perl-object (package does not exist)"); + + GV *method = gv_fetchmethod_autoload (stash, "THAW", 0); - // TODO - } + if (!method) + ERR ("cannot decode perl-object (package does not have a THAW method)"); + + dSP; - AV *av = newAV (); - av_push (av, newSVuv (tag)); - av_push (av, sv); + ENTER; SAVETMPS; PUSHMARK (SP); + EXTEND (SP, len + 1); + // we re-bless the reference to get overload and other niceties right + PUSHs (*av_fetch (av, 0, 1)); + PUSHs (sv_cbor); + + int i; + + for (i = 1; i < len; ++i) + PUSHs (*av_fetch (av, i, 1)); + + PUTBACK; + call_sv ((SV *)GvCV (method), G_SCALAR); + SPAGAIN; + + SvREFCNT_dec (sv); + sv = SvREFCNT_inc (POPs); + + PUTBACK; + + FREETMPS; LEAVE; + + return sv; + } + else + { + AV *av = newAV (); + av_push (av, newSVuv (tag)); + av_push (av, sv); - HV *tagged_stash = !CBOR_SLOW || cbor_tagged_stash - ? cbor_tagged_stash - : gv_stashpv ("CBOR::XS::Tagged" , 1); + HV *tagged_stash = !CBOR_SLOW || cbor_tagged_stash + ? cbor_tagged_stash + : gv_stashpv ("CBOR::XS::Tagged" , 1); - return sv_bless (newRV_noinc ((SV *)av), tagged_stash); + return sv_bless (newRV_noinc ((SV *)av), tagged_stash); + } fail: SvREFCNT_dec (sv); @@ -695,16 +776,21 @@ { case 20: #if CBOR_SLOW - cbor_false = get_bool ("CBOR::XS::false"); + types_false = get_bool ("Types::Serialiser::false"); #endif - return newSVsv (cbor_false); + return newSVsv (types_false); case 21: #if CBOR_SLOW - cbor_true = get_bool ("CBOR::XS::true"); + types_true = get_bool ("Types::Serialiser::true"); #endif - return newSVsv (cbor_true); + return newSVsv (types_true); case 22: return newSVsv (&PL_sv_undef); + case 23: +#if CBOR_SLOW + types_error = get_bool ("Types::Serialiser::error"); +#endif + return newSVsv (types_error); case 25: { @@ -830,20 +916,27 @@ BOOT: { cbor_stash = gv_stashpv ("CBOR::XS" , 1); - cbor_boolean_stash = gv_stashpv ("CBOR::XS::Boolean", 1); cbor_tagged_stash = gv_stashpv ("CBOR::XS::Tagged" , 1); - cbor_true = get_bool ("CBOR::XS::true"); - cbor_false = get_bool ("CBOR::XS::false"); + types_boolean_stash = gv_stashpv ("Types::Serialiser::Boolean", 1); + types_error_stash = gv_stashpv ("Types::Serialiser::Error" , 1); + + types_true = get_bool ("Types::Serialiser::true" ); + types_false = get_bool ("Types::Serialiser::false"); + types_error = get_bool ("Types::Serialiser::error"); + + sv_cbor = newSVpv ("CBOR", 0); + SvREADONLY_on (sv_cbor); } PROTOTYPES: DISABLE void CLONE (...) CODE: - cbor_stash = 0; - cbor_boolean_stash = 0; - cbor_tagged_stash = 0; + cbor_stash = 0; + cbor_tagged_stash = 0; + types_error_stash = 0; + types_boolean_stash = 0; void new (char *klass) PPCODE: @@ -900,41 +993,6 @@ OUTPUT: RETVAL -#if 0 //TODO - -void filter_cbor_object (CBOR *self, SV *cb = &PL_sv_undef) - PPCODE: -{ - SvREFCNT_dec (self->cb_object); - self->cb_object = SvOK (cb) ? newSVsv (cb) : 0; - - XPUSHs (ST (0)); -} - -void filter_cbor_single_key_object (CBOR *self, SV *key, SV *cb = &PL_sv_undef) - PPCODE: -{ - if (!self->cb_sk_object) - self->cb_sk_object = newHV (); - - if (SvOK (cb)) - hv_store_ent (self->cb_sk_object, key, newSVsv (cb), 0); - else - { - hv_delete_ent (self->cb_sk_object, key, G_DISCARD, 0); - - if (!HvKEYS (self->cb_sk_object)) - { - SvREFCNT_dec (self->cb_sk_object); - self->cb_sk_object = 0; - } - } - - XPUSHs (ST (0)); -} - -#endif - void encode (CBOR *self, SV *scalar) PPCODE: PUTBACK; scalar = encode_cbor (scalar, self); SPAGAIN; @@ -956,15 +1014,6 @@ PUSHs (sv_2mortal (newSVuv (offset - SvPVX (cborstr)))); } -#if 0 - -void DESTROY (CBOR *self) - CODE: - SvREFCNT_dec (self->cb_sk_object); - SvREFCNT_dec (self->cb_object); - -#endif - PROTOTYPES: ENABLE void encode_cbor (SV *scalar)