@@ -4,6 +4,80 @@ Revision history for Perl extension Sereal-Decoder
* of the decoder before upgrading to version 2 of the
* encoder!
+2.11 Sun Apr 13 23:04
+ - Work around regression in Perl 5.16.3 - 5.17.0
+ As of 8ae39f603f0f5778c160e18e08df60 while each
+ automagically becomes while $_= defined(each);
+ which manages to break some of our test code.
+
+2.10 Sun Apr 13 21:30
+ - Fix broken MANIFEST
+
+2.09 Sun Apr 13 16:30 2013
+ - Work around bug in 5.8.9 sv_upgrade() where
+ RITER() is set to 0, when it should be set to -1.
+ This could result in perl skipping items in the zeroth
+ bucket under some circumstances. Thanks to pjcj for the
+ report the perlbrew guys for making it easy as pie to
+ debug.
+
+2.08 Thu Apr 10 22:10 2013
+ - Production release for previous changes.
+
+2.070_103 Tue Apr 09 00:33 2013 * DEV RELEASE *
+ - Fix issue with croak_xs_usage() not being available
+ in older perls. We use the version from Win32::API
+ which had already solved the problem. See
+ https://metacpan.org/source/BULKDD/Win32-API-0.77/API.h#L311
+ Thanks to bulk88 for pointing out the code.
+
+2.070_102 Sun Apr 06 17:27 2013 * DEV RELEASE *
+ - Fixes for how we load XS so Sereal.pm works properly
+ with dev releases.
+ - Add scalar_looks_like_sereal as a custom opcode
+ From Zefram.
+
+2.070_101 Sun Apr 06 17:27 2013 * DEV RELEASE *
+ - Fix for newer perls.
+ - Changes to 'fixver.pl' and version numbering so we do
+ a 3 digit minor version, and a 3 digit dev version,
+ so once this dev release cycle is done we will be at
+ v2.071 everywhere. This eliminates a version numbering
+ inconsistency in Sereal.pm from Encoder.pm and Decoder.pm
+
+2.07_01 Wed Mar 26 18:10 2014 * DEV RELEASE *
+ - Add sereal_decode_with_object(), functional/custom-opcode implementation
+ of the OO interface, with much less overhead. In practice this will make
+ a very modest impact on dumping, but if your applications needs it...
+ Thanks to Zefram for the custom op implementation.
+ - Resolved: [rt.cpan.org #93888] does not preserve special SV identity
+ We now handle \!0 and \!1 properly. Being able to distinguish
+ \undef from \{my $x= undef} is left for a new protocol release.
+ Reported by Zefram.
+ - Resolved [rt.cpan.org #93892] downgrade breaks unwritable strings
+ When decoding a UTF8-on SV we now sv_mortalcopy() it before
+ we sv_utf8_downgrade() it. This prevents us from modifying the
+ buffer during deserialization.
+ Reported By Zefram.
+
+2.06 Sun Mar 0 11:40 2014 (AMS time)
+ - Fix bug causing needless decoder cloning.
+ - Fix refcount issues in some undocumented (but publicly callable)
+ functions.
+
+2.05 Fri Mar 7 10:30 2014 (AMS time)
+ - Fix rt.cpan.org #93563 - Decoder object wasn't re-entrant from
+ THAW calls.
+
+2.04 Wed Mar 5 18:15 2014 (AMS time)
+ - decode_sereal() now gives a better error message if a reference is passed
+ as the input string.
+ - Fix issue with OBJECT items that use COPY for the class name.
+ => In certain situations, the Sereal Go implementation would encode
+ objects in slightly different way than the Perl encoder and the
+ Perl decoder failed to support this. See commit
+ 8b3c661e0157960272b056769a7169d4ca2f1d89 for details.
+
2.03 Tue Jan 7 20:00 2014 (AMS time)
- (Hopefully) final fixes to FREEZE/THAW functionality:
=> Add safe assertion to make sure that we don't segfault on invalid
@@ -8,16 +8,393 @@
#include "ppport.h"
+#include "srl_common.h"
#include "srl_decoder.h"
#include "srl_protocol.h"
/* Generated code for exposing C constants to Perl */
#include "const-c.inc"
+#ifndef GvCV_set
+# define GvCV_set(gv, cv) (GvCV(gv) = (cv))
+#endif
+
+#ifndef PERL_ARGS_ASSERT_CROAK_XS_USAGE
+#define PERL_ARGS_ASSERT_CROAK_XS_USAGE assert(cv); assert(params)
+
+/* prototype to pass -Wmissing-prototypes */
+STATIC void
+S_croak_xs_usage(pTHX_ const CV *const cv, const char *const params);
+
+STATIC void
+S_croak_xs_usage(pTHX_ const CV *const cv, const char *const params)
+{
+ const GV *const gv = CvGV(cv);
+
+ PERL_ARGS_ASSERT_CROAK_XS_USAGE;
+
+ if (gv) {
+ const char *const gvname = GvNAME(gv);
+ const HV *const stash = GvSTASH(gv);
+ const char *const hvname = stash ? HvNAME(stash) : NULL;
+
+ if (hvname)
+ Perl_croak_nocontext("Usage: %s::%s(%s)", hvname, gvname, params);
+ else
+ Perl_croak_nocontext("Usage: %s(%s)", gvname, params);
+ } else {
+ /* Pants. I don't think that it should be possible to get here. */
+ Perl_croak_nocontext("Usage: CODE(0x%"UVxf")(%s)", PTR2UV(cv), params);
+ }
+}
+
+#ifdef PERL_IMPLICIT_CONTEXT
+#define croak_xs_usage(a,b) S_croak_xs_usage(aTHX_ a,b)
+#else
+#define croak_xs_usage S_croak_xs_usage
+#endif
+
+#endif
+
+
+#if defined(cv_set_call_checker) && defined(XopENTRY_set)
+# define USE_CUSTOM_OPS 1
+#else
+# define USE_CUSTOM_OPS 0
+#endif
+
+#define OPOPT_DO_BODY (1<<0)
+#define OPOPT_DO_HEADER (1<<1)
+#define OPOPT_OFFSET (1<<2)
+#define OPOPT_OUTARG_BODY (1<<3)
+#define OPOPT_OUTARG_HEADER (1<<4)
+#define OPOPT_LOOKS_LIKE (1<<5)
+
+#define pp1_sereal_decode(opopt) THX_pp1_sereal_decode(aTHX_ opopt)
+static void
+THX_pp1_sereal_decode(pTHX_ U8 opopt)
+{
+ bool need_retvalue = GIMME_V != G_VOID;
+ SV *decoder_ref_sv, *decoder_sv, *src_sv;
+ UV offset;
+ SV *body_into, *header_into;
+ srl_decoder_t *decoder;
+ char *stash_name;
+ dSP;
+
+ header_into = expect_false(opopt & OPOPT_OUTARG_HEADER)
+ ? POPs
+ : expect_false(opopt & OPOPT_DO_HEADER) ? sv_newmortal() : NULL;
+ body_into = expect_false(opopt & OPOPT_OUTARG_BODY)
+ ? POPs
+ : expect_true(opopt & OPOPT_DO_BODY) ? sv_newmortal() : NULL;
+
+ offset = expect_false(opopt & OPOPT_OFFSET) ? SvUVx(POPs) : 0;
+ src_sv = POPs;
+ decoder_ref_sv = POPs;
+ PUTBACK;
+
+ if (!expect_true(
+ decoder_ref_sv &&
+ SvROK(decoder_ref_sv) &&
+ (decoder_sv = SvRV(decoder_ref_sv)) &&
+ SvOBJECT(decoder_sv) &&
+ (stash_name = HvNAME(SvSTASH(decoder_sv))) &&
+ !strcmp(stash_name, "Sereal::Decoder")
+ ))
+ {
+ croak("handle is not a Sereal::Decoder handle");
+ }
+
+ decoder = (srl_decoder_t *)SvIV(decoder_sv);
+ if (expect_true(opopt & OPOPT_DO_BODY)) {
+ if (opopt & OPOPT_DO_HEADER) {
+ srl_decode_all_into(aTHX_ decoder, src_sv, header_into,
+ body_into, offset);
+ } else {
+ srl_decode_into(aTHX_ decoder, src_sv, body_into, offset);
+ }
+ } else {
+ srl_decode_header_into(aTHX_ decoder, src_sv, header_into, offset);
+ }
+
+ if (expect_true(need_retvalue)) {
+ SV *retvalue;
+ if (expect_true(opopt & OPOPT_DO_BODY)) {
+ if (opopt & OPOPT_DO_HEADER) {
+ AV *retav = newAV();
+ retvalue = newRV_noinc((SV*)retav);
+ sv_2mortal(retvalue);
+ av_extend(retav, 1);
+ av_store(retav, 0, SvREFCNT_inc(header_into));
+ av_store(retav, 1, SvREFCNT_inc(body_into));
+ } else {
+ retvalue = body_into;
+ }
+ } else {
+ retvalue = header_into;
+ }
+ SPAGAIN;
+ XPUSHs(retvalue);
+ PUTBACK;
+ }
+}
+
+#define pp1_looks_like_sereal() THX_pp1_looks_like_sereal(aTHX)
+static void
+THX_pp1_looks_like_sereal(pTHX)
+{
+ dSP;
+ SV *data = TOPs;
+ char *strdata;
+ STRLEN len;
+ SETs(boolSV(
+ SvOK(data) &&
+ (strdata = SvPV(data, len), len >= SRL_MAGIC_STRLEN+3) /* at least one version/flag byte, one byte for header len, one type byte (smallest payload) */ &&
+ memcmp(strdata, SRL_MAGIC_STRING, SRL_MAGIC_STRLEN) == 0 &&
+ strdata[SRL_MAGIC_STRLEN] != (U8)0 /* FIXME this check could be much better using the proto versions and all*/
+ ));
+}
+
+#if USE_CUSTOM_OPS
+
+static OP *
+THX_pp_sereal_decode(pTHX)
+{
+ pp1_sereal_decode(PL_op->op_private);
+ return NORMAL;
+}
+
+static OP *
+THX_pp_looks_like_sereal(pTHX)
+{
+ pp1_looks_like_sereal();
+ return NORMAL;
+}
+
+static OP *
+THX_ck_entersub_args_sereal_decoder(pTHX_ OP *entersubop, GV *namegv, SV *ckobj)
+{
+
+ /* pull apart a standard entersub op tree */
+
+ CV *cv = (CV*)ckobj;
+ I32 cv_private = CvXSUBANY(cv).any_i32;
+ U8 opopt = cv_private & 0xff;
+ U8 min_arity = (cv_private >> 8) & 0xff;
+ U8 max_arity = (cv_private >> 16) & 0xff;
+ OP *pushop, *firstargop, *cvop, *lastargop, *argop, *newop;
+ int arity;
+
+ /* Walk the OP structure under the "entersub" to validate that we
+ * can use the custom OP implementation. */
+
+ entersubop = ck_entersub_args_proto(entersubop, namegv, (SV*)cv);
+ pushop = cUNOPx(entersubop)->op_first;
+ if ( ! pushop->op_sibling )
+ pushop = cUNOPx(pushop)->op_first;
+ firstargop = pushop->op_sibling;
+
+ for (cvop = firstargop; cvop->op_sibling; cvop = cvop->op_sibling) ;
+
+ lastargop = pushop;
+ for (
+ arity = 0, lastargop = pushop, argop = firstargop;
+ argop != cvop;
+ lastargop = argop, argop = argop->op_sibling
+ ){
+ arity++;
+ }
+
+ if (expect_false(arity < min_arity || arity > max_arity))
+ return entersubop;
+
+ /* If we get here, we can replace the entersub with a suitable
+ * custom OP. */
+
+ if (arity > min_arity && (opopt & OPOPT_DO_BODY)) {
+ opopt |= OPOPT_OUTARG_BODY;
+ min_arity++;
+ }
+
+ if (arity > min_arity)
+ opopt |= OPOPT_OUTARG_HEADER;
+
+ pushop->op_sibling = cvop;
+ lastargop->op_sibling = NULL;
+ op_free(entersubop);
+ newop = newUNOP(OP_CUSTOM, 0, firstargop);
+ newop->op_private = opopt;
+ newop->op_ppaddr = opopt & OPOPT_LOOKS_LIKE ? THX_pp_looks_like_sereal : THX_pp_sereal_decode;
+ return newop;
+}
+
+#endif /* USE_CUSTOM_OPS */
+
+static void
+THX_xsfunc_sereal_decode(pTHX_ CV *cv)
+{
+ dMARK;
+ dSP;
+ SSize_t arity = SP - MARK;
+ I32 cv_private = CvXSUBANY(cv).any_i32;
+ U8 opopt = cv_private & 0xff;
+ U8 min_arity = (cv_private >> 8) & 0xff;
+ U8 max_arity = (cv_private >> 16) & 0xff;
+
+ if (arity < min_arity || arity > max_arity)
+ croak("bad Sereal decoder usage");
+ if (arity > min_arity && (opopt & OPOPT_DO_BODY)) {
+ opopt |= OPOPT_OUTARG_BODY;
+ min_arity++;
+ }
+ if (arity > min_arity)
+ opopt |= OPOPT_OUTARG_HEADER;
+
+ pp1_sereal_decode(opopt);
+}
+
+static void
+THX_xsfunc_looks_like_sereal(pTHX_ CV *cv)
+{
+ dMARK;
+ dSP;
+ SSize_t arity = SP - MARK;
+ I32 cv_private = CvXSUBANY(cv).any_i32;
+ U8 max_arity = (cv_private >> 16) & 0xff;
+
+ if (arity < 1 || arity > max_arity)
+ croak_xs_usage(cv, max_arity == 1 ? "data" : "[invocant,] data");
+ if(arity == 2) {
+ SV *data = POPs;
+ SETs(data);
+ PUTBACK;
+ }
+ pp1_looks_like_sereal();
+}
+
+
MODULE = Sereal::Decoder PACKAGE = Sereal::Decoder
PROTOTYPES: DISABLE
+BOOT:
+{
+ struct {
+ char const *name_suffix;
+ U8 opopt;
+ } const funcs_to_install[] = {
+ { "", OPOPT_DO_BODY },
+ { "_only_header", OPOPT_DO_HEADER },
+ { "_with_header", (OPOPT_DO_BODY|OPOPT_DO_HEADER) },
+ { "_with_offset", (OPOPT_DO_BODY|OPOPT_OFFSET) },
+ { "_only_header_with_offset", (OPOPT_DO_HEADER|OPOPT_OFFSET) },
+ { "_with_header_and_offset", (OPOPT_DO_BODY|OPOPT_DO_HEADER|OPOPT_OFFSET) },
+ /*012345678901234567890123*/
+ }, *fti;
+ int i;
+#if USE_CUSTOM_OPS
+ {
+ XOP *xop;
+ Newxz(xop, 1, XOP);
+ XopENTRY_set(xop, xop_name, "sereal_decode_with_object");
+ XopENTRY_set(xop, xop_desc, "sereal_decode_with_object");
+ XopENTRY_set(xop, xop_class, OA_UNOP);
+ Perl_custom_op_register(aTHX_ THX_pp_sereal_decode, xop);
+ }
+#endif /* USE_CUSTOM_OPS */
+ for (i = sizeof(funcs_to_install)/sizeof(*fti); i--; ) {
+# define LONG_CLASS_FMT "Sereal::Decoder::sereal_decode%s_with_object"
+ char name[sizeof(LONG_CLASS_FMT)+24];
+ char proto[7], *p = proto;
+ U8 opopt;
+ I32 cv_private;
+ GV *gv;
+ CV *cv;
+
+ fti = &funcs_to_install[i];
+ opopt = fti->opopt;
+ /*
+ * The cv_private value incorporates flags describing the operation to be
+ * performed by the sub and precomputed arity limits. 0x020200 corresponds
+ * to min_arity=2 and max_arity=2. The various additions to cv_private
+ * increment one or both of these sub-values.
+
+ * The six subs created there share a single C body function, and are
+ * differentiated only by the option flags in cv_private. The custom ops
+ * likewise share one op_ppaddr function, and the operations they perform
+ * are differentiated by the same flags, stored in op_private.
+ */
+ cv_private = opopt | 0x020200;
+
+ /* Yes, the subs have prototypes. The protoypes have no effect when the
+ * subs are used as methods, so there's no break of compatibility for those
+ * using the documented API. There is a change that could be detected by
+ * code such as "Sereal::Decoder::decode($dec, @v)", that uses the methods
+ * directly in an undocumented way.
+ *
+ * The prototype, specifically the putting of argument expressions into
+ * scalar context, is required in order to be able to resolve arity at
+ * compile time. If this wasn't done, there would have to be a pushmark
+ * op preceding the argument ops, and pp_sereal_decode() would need the
+ * same code as xsfunc_sereal_decode() to check arity and resolve the
+ * optional-parameter flags.
+ */
+ *p++ = '$';
+ *p++ = '$';
+
+ if (opopt & OPOPT_OFFSET) {
+ *p++ = '$';
+ cv_private += 0x010100;
+ }
+ *p++ = ';';
+ if (opopt & OPOPT_DO_BODY) {
+ *p++ = '$';
+ cv_private += 0x010000;
+ }
+ if (opopt & OPOPT_DO_HEADER) {
+ *p++ = '$';
+ cv_private += 0x010000;
+ }
+ *p = 0;
+ /* setup the name of the sub */
+ sprintf(name, LONG_CLASS_FMT, fti->name_suffix);
+ cv = newXSproto_portable(name, THX_xsfunc_sereal_decode, __FILE__,
+ proto);
+ CvXSUBANY(cv).any_i32 = cv_private;
+#if USE_CUSTOM_OPS
+ cv_set_call_checker(cv, THX_ck_entersub_args_sereal_decoder, (SV*)cv);
+#endif /* USE_CUSTOM_OPS */
+ sprintf(name, "Sereal::Decoder::decode%s", fti->name_suffix);
+ gv = gv_fetchpv(name, GV_ADDMULTI, SVt_PVCV);
+ GvCV_set(gv, cv);
+ }
+}
+
+BOOT:
+{
+#if USE_CUSTOM_OPS
+ {
+ XOP *xop;
+ Newxz(xop, 1, XOP);
+ XopENTRY_set(xop, xop_name, "scalar_looks_like_sereal");
+ XopENTRY_set(xop, xop_desc, "scalar_looks_like_sereal");
+ XopENTRY_set(xop, xop_class, OA_UNOP);
+ Perl_custom_op_register(aTHX_ THX_pp_looks_like_sereal, xop);
+ }
+#endif /* USE_CUSTOM_OPS */
+ {
+ CV *cv;
+ cv = newXSproto_portable("Sereal::Decoder::scalar_looks_like_sereal", THX_xsfunc_looks_like_sereal, __FILE__, "$");
+ CvXSUBANY(cv).any_i32 = 0x010100 | OPOPT_LOOKS_LIKE;
+#if USE_CUSTOM_OPS
+ cv_set_call_checker(cv, THX_ck_entersub_args_sereal_decoder, (SV*)cv);
+#endif /* USE_CUSTOM_OPS */
+ cv = newXS("Sereal::Decoder::looks_like_sereal", THX_xsfunc_looks_like_sereal, __FILE__);
+ CvXSUBANY(cv).any_i32 = 0x020100 | OPOPT_LOOKS_LIKE;
+ }
+}
+
srl_decoder_t *
new(CLASS, opt = NULL)
char *CLASS;
@@ -33,88 +410,6 @@ DESTROY(dec)
CODE:
srl_destroy_decoder(aTHX_ dec);
-
-void
-decode(dec, src, into = NULL)
- srl_decoder_t *dec;
- SV *src;
- SV *into;
- PPCODE:
- ST(0)= srl_decode_into(aTHX_ dec, src, into, 0);
- XSRETURN(1);
-
-AV *
-decode_with_header(dec, src, body_into = NULL, header_into = NULL)
- srl_decoder_t *dec;
- SV *src;
- SV *body_into;
- SV *header_into;
- CODE:
- if (header_into == NULL)
- header_into = sv_newmortal();
- if (body_into == NULL)
- body_into = sv_newmortal();
- srl_decode_all_into(aTHX_ dec, src, header_into, body_into, 0);
- RETVAL = newAV();
- sv_2mortal((SV *)RETVAL);
- av_extend(RETVAL, 1);
- av_store(RETVAL, 0, header_into);
- av_store(RETVAL, 1, body_into);
- OUTPUT: RETVAL
-
-AV *
-decode_with_header_and_offset(dec, src, offset, body_into = NULL, header_into = NULL)
- srl_decoder_t *dec;
- SV *src;
- UV offset;
- SV *body_into;
- SV *header_into;
- CODE:
- if (header_into == NULL)
- header_into = sv_newmortal();
- if (body_into == NULL)
- body_into = sv_newmortal();
- srl_decode_all_into(aTHX_ dec, src, header_into, body_into, offset);
- RETVAL = newAV();
- sv_2mortal((SV *)RETVAL);
- av_extend(RETVAL, 1);
- av_store(RETVAL, 0, header_into);
- av_store(RETVAL, 1, body_into);
- OUTPUT: RETVAL
-
-
-
-void
-decode_only_header(dec, src, header_into = NULL)
- srl_decoder_t *dec;
- SV *src;
- SV *header_into;
- PPCODE:
- ST(0)= srl_decode_header_into(aTHX_ dec, src, header_into, 0);
- XSRETURN(1);
-
-
-void
-decode_with_offset(dec, src, offset, into = NULL)
- srl_decoder_t *dec;
- SV *src;
- UV offset;
- SV *into;
- PPCODE:
- ST(0)= srl_decode_into(aTHX_ dec, src, into, offset);
- XSRETURN(1);
-
-void
-decode_only_header_with_offset(dec, src, offset, header_into = NULL)
- srl_decoder_t *dec;
- SV *src;
- UV offset;
- SV *header_into;
- PPCODE:
- ST(0)= srl_decode_header_into(aTHX_ dec, src, header_into, offset);
- XSRETURN(1);
-
-
void
decode_sereal(src, opt = NULL, into = NULL)
SV *src;
@@ -123,6 +418,8 @@ decode_sereal(src, opt = NULL, into = NULL)
PREINIT:
srl_decoder_t *dec= NULL;
PPCODE:
+ if (SvROK(src))
+ croak("We can't decode a reference as Sereal!");
/* Support no opt at all, undef, hashref */
if (opt != NULL) {
SvGETMAGIC(opt);
@@ -165,34 +462,8 @@ decode_sereal_with_header_data(src, opt = NULL, body_into = NULL, header_into =
RETVAL = newAV();
sv_2mortal((SV *)RETVAL);
av_extend(RETVAL, 1);
- av_store(RETVAL, 0, header_into);
- av_store(RETVAL, 1, body_into);
- OUTPUT: RETVAL
-
-IV
-looks_like_sereal(...)
- PREINIT:
- SV *data;
- char *strdata;
- STRLEN len;
- CODE:
- RETVAL = 1;
- if (items > 2 || items == 0) {
- croak("Invalid number of parameters to looks_like_sereal: "
- "Need one data parameter, possibly preceded by an invocant.");
- }
- data = ST(items-1); /* 1 or two items, use the last parameter as data */
- if (!SvOK(data))
- RETVAL = 0;
- else {
- strdata = SvPV(data, len);
- if (len < SRL_MAGIC_STRLEN+3 /* at least one version/flag byte, one byte for header len, one type byte (smallest payload) */
- || strnNE(strdata, SRL_MAGIC_STRING, SRL_MAGIC_STRLEN)
- || strdata[SRL_MAGIC_STRLEN] == (U8)0) /* FIXME this check could be much better using the proto versions and all*/
- {
- RETVAL = 0;
- }
- }
+ av_store(RETVAL, 0, SvREFCNT_inc(header_into));
+ av_store(RETVAL, 1, SvREFCNT_inc(body_into));
OUTPUT: RETVAL
UV
@@ -13,6 +13,7 @@ inc/Devel/CheckLib.pm
inc/Sereal/BuildTools.pm
lib/Sereal/Decoder.pm
lib/Sereal/Decoder/Constants.pm
+lib/Sereal/Performance.pm
Makefile.PL
MANIFEST This list of files
ppport.h
@@ -32,8 +33,8 @@ t/001_load.t
t/010_desperate.t
t/020_incremental.t
t/030_looks_like_sereal.t
-t/100_roundtrip.t
-t/101_roundtrip_v1.t
+t/040_special_vars.t
+t/060_each.t
t/110_nobless.t
t/150_dec_exception.t
t/160_recursion.t
@@ -41,9 +42,13 @@ t/200_bulk.t
t/300_overload.t
t/400_utf8validate.t
t/500_utf8decoding.t
+t/700_roundtrip.t
+t/701_roundtrip_v1.t
t/800_threads.t
t/900_regr_issue_15.t
t/901_regr_segv.t
+t/902_bad_input.t
+t/903_reentrancy.t
t/data/corpus
t/lib/Sereal/BulkTest.pm
t/lib/Sereal/TestSet.pm
@@ -4,7 +4,7 @@
"Steffen Mueller <smueller@cpan.org>, Yves Orton <yves@cpan.org>"
],
"dynamic_config" : 1,
- "generated_by" : "ExtUtils::MakeMaker version 6.64, CPAN::Meta::Converter version 2.120921",
+ "generated_by" : "ExtUtils::MakeMaker version 6.66, CPAN::Meta::Converter version 2.120921",
"license" : [
"perl_5"
],
@@ -55,5 +55,5 @@
"url" : "git://github.com/Sereal/Sereal.git"
}
},
- "version" : "2.03"
+ "version" : "2.11"
}
@@ -16,7 +16,7 @@ build_requires:
configure_requires:
ExtUtils::MakeMaker: 0
dynamic_config: 1
-generated_by: 'ExtUtils::MakeMaker version 6.64, CPAN::Meta::Converter version 2.120921'
+generated_by: 'ExtUtils::MakeMaker version 6.66, CPAN::Meta::Converter version 2.120921'
license: perl
meta-spec:
url: http://module-build.sourceforge.net/META-spec-v1.4.html
@@ -32,4 +32,4 @@ requires:
resources:
bugtracker: https://github.com/Sereal/Sereal/issues
repository: git://github.com/Sereal/Sereal.git
-version: 2.03
+version: 2.11
@@ -239,7 +239,7 @@ sub parse_hv {
while ($len--) {
my $t = substr($data, 0, 1);
my $o = ord($t);
- print( " ", $ind, ($flipflop++ % 2 == 1 ? "VALUE" : "KEY"), ":\n" );
+ printf "$fmt2%s:\n",("") x $lead_items, $ind, ($flipflop++ %2 == 1 ? "VALUE" : "KEY");
parse_sv($ind." ");
}
}
@@ -629,7 +629,7 @@ constant (pTHX_ const char *name, STRLEN len, IV *iv_return) {
Regenerate these constant functions by feeding this entire source file to
perl -x
-#!/usr/bin/perl -w
+#!/home/yorton/perl5/perlbrew/perls/perl-5.18.2/bin/perl -w
use ExtUtils::Constant qw (constant_types C_constant XS_constant);
my $types = {map {($_, 1)} qw(IV)};
@@ -5,22 +5,27 @@ use warnings;
use Carp qw/croak/;
use XSLoader;
-our $VERSION = '2.03'; # Don't forget to update the TestCompat set for testing against installed encoders!
+our $VERSION = '2.11'; # Don't forget to update the TestCompat set for testing against installed encoders!
+our $XS_VERSION = $VERSION; $VERSION= eval $VERSION;
# not for public consumption, just for testing.
(my $num_version = $VERSION) =~ s/_//;
-my $TestCompat = [ map sprintf("%.2f", $_/100), reverse( 200 .. int($num_version * 100) ) ]; # compat with 2.00 to ...
+my $TestCompat = [ map sprintf("%.2f", $_/100), reverse( 207 .. int($num_version * 100) ) ]; # compat with 2.07 to ...
sub _test_compat {return(@$TestCompat, $VERSION)}
use Exporter 'import';
-our @EXPORT_OK = qw(decode_sereal looks_like_sereal decode_sereal_with_header_data);
+our @EXPORT_OK = qw(
+ decode_sereal looks_like_sereal decode_sereal_with_header_data
+ scalar_looks_like_sereal
+ sereal_decode_with_object sereal_decode_with_header_with_object
+);
our %EXPORT_TAGS = (all => \@EXPORT_OK);
# export by default if run from command line
our @EXPORT = ((caller())[1] eq '-e' ? @EXPORT_OK : ());
sub CLONE_SKIP { 1 }
-XSLoader::load('Sereal::Decoder', $VERSION);
+XSLoader::load('Sereal::Decoder', $XS_VERSION);
1;
@@ -34,7 +39,8 @@ Sereal::Decoder - Fast, compact, powerful binary deserialization
=head1 SYNOPSIS
- use Sereal::Decoder qw(decode_sereal looks_like_sereal);
+ use Sereal::Decoder
+ qw(decode_sereal sereal_decode_with_object scalar_looks_like_sereal);
my $decoder = Sereal::Decoder->new({...options...});
@@ -44,12 +50,16 @@ Sereal::Decoder - Fast, compact, powerful binary deserialization
# or if you don't have references to the top level structure, this works, too:
$structure = $decoder->decode($blob);
- # alternatively functional interface:
+ # alternatively functional interface: (See Sereal::Performance)
+ sereal_decode_with_object($decoder, $blob, $structure);
+ $structure = sereal_decode_with_object($decoder, $blob);
+
+ # much slower functional interface with no persistent objects:
decode_sereal($blob, {... options ...}, $structure);
$structure = decode_sereal($blob, {... options ...});
# Not a full validation, but just a quick check for a reasonable header:
- my $is_likely_sereal = looks_like_sereal($some_string);
+ my $is_likely_sereal = scalar_looks_like_sereal($some_string);
# or:
$is_likely_sereal = $decoder->looks_like_sereal($some_string);
@@ -144,7 +154,7 @@ This means you can do this:
=head2 decode
-Given a byte string of Sereal data, the C<decode> call derializes that data
+Given a byte string of Sereal data, the C<decode> call deserializes that data
structure. The result can be obtained in one of two ways: C<decode> accepts
a second parameter, which is a scalar to write the result to, AND C<decode>
will return the resulting data structure.
@@ -210,6 +220,19 @@ For reference, sereal's magic string is a four byte string C<=srl>.
=head1 EXPORTABLE FUNCTIONS
+=head2 sereal_decode_with_object
+
+The functional interface that is equivalent to using C<decode>. Takes a
+decoder object reference as first argument, followed by a byte string
+to deserialize. Optionally takes a third parameter, which is the output
+scalar to write to. See the documentation for C<decode> above for details.
+
+This functional interface is marginally faster than the OO interface
+since it avoids method resolution overhead and, on sufficiently modern
+Perl versions, can usually avoid subroutine call overhead. See
+L<Sereal::Performance> for a discussion on how to tune Sereal for maximum
+performance if you need to.
+
=head2 decode_sereal
The functional interface that is equivalent to using C<new> and C<decode>.
@@ -218,12 +241,12 @@ by a hash reference of options (see documentation for C<new()>). Finally,
C<decode_sereal> supports a third parameter, which is the output scalar
to write to. See the documentation for C<decode> above for details.
-The functional interface is marginally slower than the OO interface since
+This functional interface is significantly slower than the OO interface since
it cannot reuse the decoder object.
-=head2 looks_like_sereal
+=head2 scalar_looks_like_sereal
-Same as the object method of the same name.
+The functional interface that is equivalent to using C<looks_like_sereal>.
=head1 ROBUSTNESS
@@ -232,7 +255,7 @@ input data as reasonably possible. This means that it should never
(though read on) segfault. It may, however, cause a large malloc
to fail. Generally speaking, invalid data should cause a Perl-trappable
exception. The one exception is that for Snappy-compressed Sereal documents,
-the Snappy library may cause segmentation faults (invalid reads orwrites).
+the Snappy library may cause segmentation faults (invalid reads or writes).
This should only be a problem if you do not checksum your data (internal
checksum support is a To-Do) or if you accept data from potentially
malicious sources.
@@ -263,11 +286,9 @@ the C<FREEZE/THAW> mechanism, please refer to L<Sereal::Encoder>.
=head1 PERFORMANCE
-The exact performance in time and space depends heavily on the data structure
-to be serialized. For ready-made comparison scripts, see the
-F<author_tools/bench.pl> and F<author_tools/dbench.pl> programs that are part
-of this distribution. Suffice to say that this library is easily competitive
-in both time and space efficiency with the best alternatives.
+Please refer to the L<Sereal::Performance> document
+that has more detailed information about Sereal performance and
+tuning thereof.
=head1 THREAD-SAFETY
@@ -290,7 +311,7 @@ L<https://groups.google.com/forum/?fromgroups#!forum/sereal-announce>
Sereal development list:
L<https://groups.google.com/forum/?fromgroups#!forum/sereal-dev>
-=head1 AUTHORS
+=head1 AUTHORS AND CONTRIBUTORS
Yves Orton E<lt>demerphq@gmail.comE<gt>
@@ -302,8 +323,14 @@ Rafaël Garcia-Suarez
Ævar Arnfjörð Bjarmason E<lt>avar@cpan.orgE<gt>
+Tim Bunce
+
Daniel Dragan E<lt>bulkdd@cpan.orgE<gt> (Windows support and bugfixes)
+Zefram
+
+Borislav Nikolov
+
Some inspiration and code was taken from Marc Lehmann's
excellent JSON::XS module due to obvious overlap in
problem domain.
@@ -0,0 +1,265 @@
+package Sereal::Performance;
+use 5.008;
+use warnings;
+1;
+
+__END__
+
+=encoding utf8
+
+=head1 NAME
+
+Sereal::Performance - Getting the most out of the Perl-Sereal implementation
+
+=head1 SYNOPSIS
+
+ # This is different from the standard module synopsis in
+ # that it chooses performance over ease-of-use.
+ # Think twice before micro-optimizing your Sereal usage.
+ # Usually, Sereal is a lot faster than most of one's code,
+ # so unless you are doing bulk encoding/decoding, you are
+ # better off optimizing for maintainability.
+
+ use Sereal qw(sereal_encode_with_object
+ sereal_decode_with_object);
+ my $enc = Sereal::Encoder->new();
+ my $dec = Sereal::Decoder->new();
+
+ my $big_data_structure = {...};
+
+ my $srldoc = sereal_encode_with_object($enc, $big_data_structure);
+
+ my $and_back = sereal_decode_with_object($dec, $srldoc);
+
+=head1 DESCRIPTION
+
+Using Sereal in the way that is optimally performant for your use
+case can make quite a significant difference in performance. Broadly
+speaking, there are two classes of tweaks you can do: choosing
+the right options during encoding (sometimes incurring
+trade-offs in output size) and calling the Sereal encode/decode
+functions in the most efficient way.
+
+If you are not yet using re-usable
+L<Sereal::Encoder> and L<Sereal::Decoder> objects, then
+read no further. By switching from the C<encode_sereal> and
+C<decode_sereal> functions to either the OO interface or the
+advanced functional interface, you will get a noticeable
+speed boost as encoder and decoder structures can be reused.
+This is particularly significant for the encoder, which can
+re-use its output buffer. In some cases, such a warmed-up
+encoder can avoid most memory allocations.
+
+B<I repeat, if you care about performance, then do not use
+the C<encode_sereal> and C<decode_sereal> interface.>
+
+The exact performance in time and space depends heavily on the data structure
+to be (de-)serialized. Often there is a trade-off between space and time. If in doubt,
+do your own testing and most importantly B<ALWAYS TEST WITH REAL DATA>. If you
+care purely about speed at the expense of output size, you can use the
+C<no_shared_hashkeys> option for a small speed-up, see below.
+If you need smaller output at the cost of higher CPU load and more memory
+used during encoding/decoding, try the C<dedupe_strings> option and
+enable Snappy compression.
+
+For ready-made comparison scripts, see the
+F<author_tools/bench.pl> and F<author_tools/dbench.pl> programs that are part
+of this distribution. Suffice to say that this library is easily competitive
+in both time and space efficiency with the best alternatives.
+
+If switching to the OO interface is not enough, you may consider
+switching to the advanced functional interface that avoids
+method lookup overhead, and by inlining as custom Perl OPs,
+may also avoid some of the Perl function call overhead (Perl
+5.14 and up). This additional speed-up is only a constant-offset,
+avoiding said method/function call, rather than speeding up encoding
+itself and so will be most significant if you are working with
+very small data sets.
+
+C<sereal_encode_with_object> and C<sereal_decode_with_object>
+are optionally exported from the L<Sereal> module (or
+C<Sereal::Encoder> and C<Sereal::Decoder> respectively).
+They work the same as the object-oriented interface except
+that they are invoked differently:
+
+ $srl_doc = $encoder->encode($data);
+
+becomes
+
+ $srl_doc = sereal_encode_with_object($encoder, $data);
+
+and
+
+ $data = $decoder->decode($srl_doc);
+
+becomes
+
+ $data = sereal_decode_with_object($decoder, $srl_doc);
+
+On Perl versions before 5.14, this will be marginally faster than
+the OO interface as it avoids method lookup. This should rarely matter.
+On Perl versions starting from 5.14, the function call to
+C<sereal_encode_with_object> or C<sereal_decode_with_object> will
+also be replaced with a custom Perl OP, thus avoiding most of the
+function call overhead as well.
+
+=head2 Tuning the C<Sereal::Encoder>
+
+Several of the C<Sereal::Encoder> options add or remove useful
+behaviour and some of them come at a runtime performance cost.
+
+=over 2
+
+=item C<no_shared_hashkeys>
+
+By default, Sereal will emit a "repetition" marker for hash keys
+that were already previously encountered. Depending on your data
+structure, this can save quite a bit of space in the generated
+document. Consider, for example, encoding an array of many objects
+of the same class. But it may not save anything if you don't have
+a lot of repeated hash keys or don't even encode any hashes to
+begin with.
+
+In those cases, you can turn this feature off with the C<no_shared_hashkeys>
+option for a small but measurable speed-up.
+
+=item C<dedupe_strings>
+
+If set, this option will apply the de-duplication logic to all
+strings that is only applied to hash keys by default. This
+can be quite expensive in both memory and performance.
+The same is true for C<aliased_dedupe_strings>.
+
+=item C<snappy> and C<snappy_incr>
+
+Enabling Snappy compression can (but doesn't have to) make your
+Sereal documents significantly smaller. How effective this
+compression is for you depends entirely on the nature of your data.
+Snappy compression is designed to be very fast. The additional
+space savings are very often worth the small overhead.
+
+=item C<freeze_callbacks>
+
+Using custom Perl C<FREEZE> callbacks is very expensive. If enabled,
+the encoder has to do a method lookup at least once per class of an
+object being serialized. If a C<FREEZE> hook actually exists, calling
+it will be even more expensive. If you care about ultimate performance,
+use with care.
+
+=item C<sort_keys>
+
+This option forces the encoder to always C<sort> the entries in a hash
+by its keys before writing them to the Sereal document. This can be
+somewhat expensive for large hashes.
+
+=back
+
+=head2 General Considerations
+
+Perl variables (scalars specifically) can, at the same time,
+hold multiple representations of the same data. If you create
+and integer and use it as a string, it will be cached in its
+string form. Sereal attempts to detect the most compact of
+these representations for encoding, but can not always
+succeed. For example, if a data structure was previously
+also traversed by certain other serialization modules
+(such as L<Storable>), then the scalars in the structure
+may have been irrevocably upgraded to a more complex
+(and bigger) type. This is only an issue in crude benchmarks.
+So if you plan to benchmark serialization, take care not
+to re-use the test data structure between serializers for
+results that do not depend on the order of operations.
+
+=head1 BUGS, CONTACT AND SUPPORT
+
+For reporting bugs, please use the github bug tracker at
+L<http://github.com/Sereal/Sereal/issues>.
+
+For support and discussion of Sereal, there are two Google Groups:
+
+Announcements around Sereal (extremely low volume):
+L<https://groups.google.com/forum/?fromgroups#!forum/sereal-announce>
+
+Sereal development list:
+L<https://groups.google.com/forum/?fromgroups#!forum/sereal-dev>
+
+=head1 AUTHORS AND CONTRIBUTORS
+
+Yves Orton E<lt>demerphq@gmail.comE<gt>
+
+Damian Gryski
+
+Steffen Mueller E<lt>smueller@cpan.orgE<gt>
+
+Rafaël Garcia-Suarez
+
+Ævar Arnfjörð Bjarmason E<lt>avar@cpan.orgE<gt>
+
+Tim Bunce
+
+Daniel Dragan E<lt>bulkdd@cpan.orgE<gt> (Windows support and bugfixes)
+
+Zefram
+
+Some inspiration and code was taken from Marc Lehmann's
+excellent JSON::XS module due to obvious overlap in
+problem domain.
+
+=head1 ACKNOWLEDGMENT
+
+This module was originally developed for Booking.com.
+With approval from Booking.com, this module was generalized
+and published on CPAN, for which the authors would like to express
+their gratitude.
+
+=head1 COPYRIGHT AND LICENSE
+
+Copyright (C) 2012, 2013, 2014 by Steffen Mueller
+Copyright (C) 2012, 2013, 2014 by Yves Orton
+
+The license for the code in this distribution is the following,
+with the exceptions listed below:
+
+This library is free software; you can redistribute it and/or modify
+it under the same terms as Perl itself.
+
+Except portions taken from Marc Lehmann's code for the JSON::XS
+module, which is licensed under the same terms as this module.
+(Many thanks to Marc for inspiration, and code.)
+
+Also except the code for Snappy compression library, whose license
+is reproduced below and which, to the best of our knowledge,
+is compatible with this module's license. The license for the
+enclosed Snappy code is:
+
+ Copyright 2011, Google Inc.
+ All rights reserved.
+
+ Redistribution and use in source and binary forms, with or without
+ modification, are permitted provided that the following conditions are
+ met:
+
+ * Redistributions of source code must retain the above copyright
+ notice, this list of conditions and the following disclaimer.
+ * Redistributions in binary form must reproduce the above
+ copyright notice, this list of conditions and the following disclaimer
+ in the documentation and/or other materials provided with the
+ distribution.
+ * Neither the name of Google Inc. nor the names of its
+ contributors may be used to endorse or promote products derived from
+ this software without specific prior written permission.
+
+ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+ "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+ LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
+ A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
+ OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+ SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
+ LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
+ DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+ THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+ (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
+ OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+
+=cut
+
@@ -40,7 +40,9 @@ extern "C" {
#define MY_CAN_FIND_PLACEHOLDERS
#define HAS_SV2OBJ
#endif
-
+#if (PERL_VERSION < 10)
+# define FIXUP_RITER 1
+#endif
#define DEFAULT_MAX_RECUR_DEPTH 10000
#include "srl_decoder.h"
@@ -92,7 +94,8 @@ void srl_destroy_decoder(pTHX_ srl_decoder_t *dec); /* destructo
void srl_decoder_destructor_hook(pTHX_ void *p); /* destructor hook - called automagically */
/* the top level components of the decode process - called by srl_decode_into() */
-SRL_STATIC_INLINE void srl_begin_decoding(pTHX_ srl_decoder_t *dec, SV *src, UV start_offset); /* set up the decoder to handle a given var */
+/* srl_begin_decoding: set up the decoder to handle a given var */
+SRL_STATIC_INLINE srl_decoder_t *srl_begin_decoding(pTHX_ srl_decoder_t *dec, SV *src, UV start_offset);
SRL_STATIC_INLINE void srl_read_header(pTHX_ srl_decoder_t *dec, SV *header_user_data); /* read/validate header */
SRL_STATIC_INLINE void srl_read_single_value(pTHX_ srl_decoder_t *dec, SV* into); /* main recursive dump routine */
SRL_STATIC_INLINE void srl_finalize_structure(pTHX_ srl_decoder_t *dec); /* optional finalize structure logic */
@@ -142,15 +145,9 @@ SRL_STATIC_INLINE SV *srl_read_extend(pTHX_ srl_decoder_t *dec, SV* into);
* be an RV. Differs on old perls since there used to be an RV type.
*/
#if PERL_VERSION < 12
-# define SRL_ASSERT_TYPE_FOR_RV(sv) STMT_START { \
- if (SvTYPE(sv) < SVt_PV) \
- sv_upgrade(into, SVt_RV); \
- } STMT_END
+# define SVt_RV_FAKE SVt_RV
#else
-# define SRL_ASSERT_TYPE_FOR_RV(sv) STMT_START { \
- if (SvTYPE(sv) < SVt_PV) \
- sv_upgrade(into, SVt_IV); \
- } STMT_END
+# define SVt_RV_FAKE SVt_IV
#endif
#define SRL_ASSERT_REF_PTR_TABLES(dec) STMT_START { \
@@ -220,6 +217,24 @@ srl_build_decoder_struct(pTHX_ HV *opt)
return dec;
}
+/* Clone a decoder whilst resetting ephemeral state on the clone. */
+SRL_STATIC_INLINE srl_decoder_t *
+srl_build_decoder_struct_alike(pTHX_ srl_decoder_t *proto)
+{
+ srl_decoder_t *dec;
+
+ Newxz(dec, 1, srl_decoder_t);
+
+ dec->ref_seenhash = PTABLE_new();
+ dec->max_recursion_depth = proto->max_recursion_depth;
+ dec->max_num_hash_entries = proto->max_num_hash_entries;
+
+ dec->flags = proto->flags;
+ SRL_DEC_RESET_VOLATILE_FLAGS(dec);
+
+ return dec;
+}
+
/* Explicit destructor */
void
srl_destroy_decoder(pTHX_ srl_decoder_t *dec)
@@ -248,9 +263,6 @@ srl_decoder_destructor_hook(pTHX_ void *p)
{
srl_decoder_t *dec = (srl_decoder_t *)p;
- assert(SRL_DEC_HAVE_OPTION(dec, SRL_F_DECODER_DESTRUCTOR_OK));
- SRL_DEC_UNSET_OPTION(dec, SRL_F_DECODER_DESTRUCTOR_OK);
-
/* Only free decoder if not for reuse */
if (!SRL_DEC_HAVE_OPTION(dec, SRL_F_REUSE_DECODER)) {
srl_destroy_decoder(aTHX_ dec);
@@ -263,12 +275,12 @@ srl_decoder_destructor_hook(pTHX_ void *p)
/* Logic shared by the various decoder entry points. */
SRL_STATIC_INLINE void
-srl_decode_into_internal(pTHX_ srl_decoder_t *dec, SV *src, SV *header_into, SV *body_into, UV start_offset)
+srl_decode_into_internal(pTHX_ srl_decoder_t *origdec, SV *src, SV *header_into, SV *body_into, UV start_offset)
{
- assert(dec != NULL);
- if (SvUTF8(src))
- sv_utf8_downgrade(src, 0);
- srl_begin_decoding(aTHX_ dec, src, start_offset);
+ srl_decoder_t *dec;
+
+ assert(origdec != NULL);
+ dec = srl_begin_decoding(aTHX_ origdec, src, start_offset);
srl_read_header(aTHX_ dec, header_into);
SRL_UPDATE_BODY_POS(dec);
if (SRL_DEC_HAVE_OPTION(dec, SRL_F_DECODER_DECOMPRESS_SNAPPY)) {
@@ -288,6 +300,7 @@ srl_decode_into_internal(pTHX_ srl_decoder_t *dec, SV *src, SV *header_into, SV
/* all decl's above here, or we break C89 compilers */
dec->bytes_consumed= compressed_packet_len + (dec->pos - dec->buf_start);
+ origdec->bytes_consumed = dec->bytes_consumed;
header_len = csnappy_get_uncompressed_length(
(char *)dec->pos,
@@ -331,8 +344,10 @@ srl_decode_into_internal(pTHX_ srl_decoder_t *dec, SV *src, SV *header_into, SV
/* If we aren't reading from a decompressed buffer we have to remember the number
* of bytes used for the user to query. */
- if (dec->bytes_consumed == 0)
+ if (dec->bytes_consumed == 0) {
dec->bytes_consumed = dec->pos - dec->buf_start;
+ origdec->bytes_consumed = dec->bytes_consumed;
+ }
if (SRL_DEC_HAVE_OPTION(dec, SRL_F_DECODER_DESTRUCTIVE_INCREMENTAL)) {
STRLEN len;
@@ -346,12 +361,11 @@ srl_decode_into_internal(pTHX_ srl_decoder_t *dec, SV *src, SV *header_into, SV
/* This is the main routine to deserialize just the header of a document. */
SV *
-srl_decode_header_into(pTHX_ srl_decoder_t *dec, SV *src, SV* header_into, UV start_offset)
+srl_decode_header_into(pTHX_ srl_decoder_t *origdec, SV *src, SV* header_into, UV start_offset)
{
- assert(dec != NULL);
- if (SvUTF8(src))
- sv_utf8_downgrade(src, 0);
- srl_begin_decoding(aTHX_ dec, src, start_offset);
+ srl_decoder_t *dec;
+ assert(origdec != NULL);
+ dec = srl_begin_decoding(aTHX_ origdec, src, start_offset);
if (header_into == NULL)
header_into = sv_newmortal();
srl_read_header(aTHX_ dec, header_into);
@@ -410,20 +424,40 @@ srl_clear_decoder_body_state(pTHX_ srl_decoder_t *dec)
dec->recursion_depth = 0;
}
-SRL_STATIC_INLINE void
+SRL_STATIC_INLINE srl_decoder_t *
srl_begin_decoding(pTHX_ srl_decoder_t *dec, SV *src, UV start_offset)
{
STRLEN len;
unsigned char *tmp;
- /* Assert that we did not push a destructor before */
- assert(!SRL_DEC_HAVE_OPTION(dec, SRL_F_DECODER_DESTRUCTOR_OK));
- /* Push destructor, set destructor-is-pushed flag */
- SRL_DEC_SET_OPTION(dec, SRL_F_DECODER_DESTRUCTOR_OK);
+ /* Check whether decoder is in use and create a new one on the
+ * fly if necessary. Should only happen in edge cases such as
+ * a THAW hook calling back into the same decoder. */
+ if (SRL_DEC_HAVE_OPTION(dec, SRL_F_DECODER_DIRTY)) {
+ srl_decoder_t * const proto = dec;
+ dec = srl_build_decoder_struct_alike(aTHX_ proto);
+ SRL_DEC_UNSET_OPTION(dec, SRL_F_REUSE_DECODER);
+ }
+
+ /* Needs to be before setting DIRTY because DIRTY is volatile. */
+ SRL_DEC_RESET_VOLATILE_FLAGS(dec);
+
+ /* Set to being in use. */;
+ SRL_DEC_SET_OPTION(dec, SRL_F_DECODER_DIRTY);
+
/* Register our structure for destruction on scope exit */
SAVEDESTRUCTOR_X(&srl_decoder_destructor_hook, (void *)dec);
- SRL_DEC_RESET_VOLATILE_FLAGS(dec);
+ if (SvUTF8(src)) {
+ /* If we are being asked to decode a utf8-on string then we
+ * make a mortal copy, and then try to downgrade the copy.
+ * The downgrade will croak if it cannot successfully downgrade
+ * the buffer. If it is sucessful then decode the downgraded
+ * copy. */
+ src= sv_mortalcopy(src);
+ sv_utf8_downgrade(src, 0);
+ }
+
tmp = (unsigned char*)SvPV(src, len);
if (expect_false( start_offset > len )) {
SRL_ERROR("Start offset is beyond input string length");
@@ -433,6 +467,8 @@ srl_begin_decoding(pTHX_ srl_decoder_t *dec, SV *src, UV start_offset)
dec->buf_len= len - start_offset;
SRL_SET_BODY_POS(dec, dec->buf_start);
dec->bytes_consumed = 0;
+
+ return dec;
}
SRL_STATIC_INLINE void
@@ -789,7 +825,7 @@ srl_read_array(pTHX_ srl_decoder_t *dec, SV *into, U8 tag) {
if (tag) {
SV *referent= (SV *)newAV();
len= tag & 15;
- SRL_ASSERT_TYPE_FOR_RV(into);
+ (void)SvUPGRADE(into, SVt_RV_FAKE);
SvTEMP_off(referent);
SvRV_set(into, referent);
SvROK_on(into);
@@ -833,7 +869,7 @@ srl_read_hash(pTHX_ srl_decoder_t *dec, SV* into, U8 tag) {
if (tag) {
SV *referent= (SV *)newHV();
num_keys= tag & 15;
- SRL_ASSERT_TYPE_FOR_RV(into);
+ (void)SvUPGRADE(into,SVt_RV_FAKE);
SvTEMP_off(referent);
SvRV_set(into, referent);
SvROK_on(into);
@@ -842,6 +878,9 @@ srl_read_hash(pTHX_ srl_decoder_t *dec, SV* into, U8 tag) {
num_keys= srl_read_varint_uv_count(aTHX_ dec," while reading HASH");
(void)SvUPGRADE(into, SVt_PVHV);
}
+#ifdef FIXUP_RITER
+ HvRITER_set(into,-1);
+#endif
/* Limit the maximum number of hash keys that we accept to whetever was configured */
if (expect_false( dec->max_num_hash_entries != 0 && num_keys > dec->max_num_hash_entries )) {
@@ -935,13 +974,37 @@ srl_read_refn(pTHX_ srl_decoder_t *dec, SV* into)
{
SV *referent;
ASSERT_BUF_SPACE(dec, 1, " while reading REFN referent");
- referent= newSV(SVt_NULL);
-
- SRL_ASSERT_TYPE_FOR_RV(into);
- SvTEMP_off(referent);
+ U8 tag= *(dec->pos); /* Look ahead for special vars. */
+ if (tag == SRL_HDR_TRUE) {
+ dec->pos++;
+ referent= &PL_sv_yes;
+ }
+ else if (tag == SRL_HDR_FALSE) {
+ dec->pos++;
+ referent= &PL_sv_no;
+ }
+ /*
+ * We cant do the below, as we have use SRL_HDR_UNDEF also
+ * to represent "any SV which is undef". We need a different
+ * tag for true perl undef.
+ *
+ */
+ /*
+ else if (tag == SRL_HDR_UNDEF) {
+ dec->pos++;
+ referent= &PL_sv_undef;
+ }
+ */
+ else {
+ referent= newSV(SVt_NULL);
+ SvTEMP_off(referent);
+ tag = 0;
+ }
+ (void)SvUPGRADE(into, SVt_RV_FAKE);
SvRV_set(into, referent);
SvROK_on(into);
- srl_read_single_value(aTHX_ dec, referent);
+ if (!tag)
+ srl_read_single_value(aTHX_ dec, referent);
}
SRL_STATIC_INLINE void
@@ -958,7 +1021,7 @@ srl_read_refp(pTHX_ srl_decoder_t *dec, SV* into)
referent= srl_fetch_item(aTHX_ dec, item, "REFP");
(void)SvREFCNT_inc(referent);
- SRL_ASSERT_TYPE_FOR_RV(into);
+ (void)SvUPGRADE(into, SVt_RV_FAKE);
SvTEMP_off(referent);
SvRV_set(into, referent);
SvROK_on(into);
@@ -1097,9 +1160,16 @@ srl_read_object(pTHX_ srl_decoder_t *dec, SV* into, U8 obj_tag)
if (tag == SRL_HDR_COPY) {
ofs= srl_read_varint_uv_offset(aTHX_ dec, " while reading COPY class name");
storepos= ofs;
- if (expect_true( dec->ref_seenhash != NULL )) {
- class_stash= PTABLE_fetch(dec->ref_seenhash, (void *)ofs);
+ /* if this string was seen before as part of a classname then we expect
+ * a stash available below. However it might have been serialized as a key
+ * or something like that, which would mean we dont have an entry in ref_stashes
+ * anymore. So first we check if we have a stash. If we do, then we can avoid
+ * some work. */
+ if (expect_true( dec->ref_stashes != NULL )) {
+ class_stash= PTABLE_fetch(dec->ref_stashes, (void *)ofs);
}
+ /* Check if we actually got a class_stash back. If we didn't then we need
+ * to deserialize the class name */
if (!class_stash) {
from= dec->body_pos + ofs;
tag= *from++;
@@ -1121,28 +1191,33 @@ srl_read_object(pTHX_ srl_decoder_t *dec, SV* into, U8 obj_tag)
SRL_ERROR_BAD_COPY(dec, SRL_HDR_OBJECT);
}
}
- /* NOTREACHED */
} else {
SRL_ERROR_UNEXPECTED(dec,tag, "a class name");
}
+ /* At this point we may or may not have a class stash. If they used a Copy there
+ * is a decent chance we do. */
SRL_ASSERT_REF_PTR_TABLES(dec);
if (!class_stash) {
+ /* no class stash - so we need to look it up and then store it away for future use */
class_stash= gv_stashpvn((char *)from, key_len, flags);
PTABLE_store(dec->ref_stashes, (void *)storepos, (void *)class_stash);
+ /* Since this is the first time we have seen this stash then it is the first time
+ * that we have stored an item in the ref_bless_av hash as well. So create a new one
+ * and store it away. */
av= newAV();
sv_2mortal((SV*)av);
PTABLE_store(dec->ref_bless_av, (void *)storepos, (void *)av);
} else {
- if (NULL == (av= (AV *)PTABLE_fetch(dec->ref_bless_av, (void *)storepos)) )
+ /* we have a class stash so we should have a ref_bless_av as well. */
+ av= (AV *)PTABLE_fetch(dec->ref_bless_av, (void *)storepos);
+ if ( !av )
SRL_ERRORf1("Panic, no ref_bless_av for %lu", (unsigned long)storepos);
}
if (expect_false( obj_tag == SRL_HDR_OBJECT_FREEZE )) {
srl_read_frozen_object(aTHX_ dec, class_stash, into);
} else {
-
-
/* We now have a stash so we /could/ bless... except that
* we don't actually want to do so right now. We want to defer blessing
* until the full packet has been read. Yes it is more overhead, but
@@ -14,7 +14,7 @@ typedef struct {
unsigned char *body_pos; /* in Sereal V2, all offsets are relative to the body */
STRLEN buf_len;
- U32 flags; /* flag-like options: See F_* defines in srl_decoder.c */
+ U32 flags; /* flag-like options: See SRL_F_DECODER_* defines in srl_decoder.c */
UV max_recursion_depth; /* Configurable limit on the number of recursive calls we're willing to make */
UV max_num_hash_entries; /* Configured maximum number of acceptable entries in a hash */
ptable_ptr ref_seenhash; /* ptr table for avoiding circular refs */
@@ -90,9 +90,9 @@ void srl_decoder_destructor_hook(pTHX_ void *p);
/* If set, the decoder struct needs to be cleared instead of freed at
* the end of a deserialization operation */
#define SRL_F_REUSE_DECODER 1UL
-/* If set, then the decoder destructor was already pushed to the
- * callback stack */
-#define SRL_F_DECODER_DESTRUCTOR_OK 2UL
+/* If set, then the decoder is already in use and srl_decode_into will
+ * clone its own new decoder. */
+#define SRL_F_DECODER_DIRTY 2UL
/* Non-persistent flag! */
#define SRL_F_DECODER_NEEDS_FINALIZE 4UL
/* Non-persistent flag! */
@@ -113,7 +113,7 @@ void srl_decoder_destructor_hook(pTHX_ void *p);
#define SRL_DEC_HAVE_OPTION(dec, flag_num) ((dec)->flags & flag_num)
#define SRL_DEC_SET_OPTION(dec, flag_num) ((dec)->flags |= flag_num)
#define SRL_DEC_UNSET_OPTION(dec, flag_num) ((dec)->flags &= ~flag_num)
-#define SRL_DEC_VOLATILE_FLAGS (SRL_F_DECODER_NEEDS_FINALIZE|SRL_F_DECODER_DECOMPRESS_SNAPPY|SRL_F_DECODER_PROTOCOL_V1)
+#define SRL_DEC_VOLATILE_FLAGS (SRL_F_DECODER_NEEDS_FINALIZE|SRL_F_DECODER_DECOMPRESS_SNAPPY|SRL_F_DECODER_PROTOCOL_V1|SRL_F_DECODER_DIRTY)
#define SRL_DEC_RESET_VOLATILE_FLAGS(dec) ((dec)->flags &= ~SRL_DEC_VOLATILE_FLAGS)
/*
@@ -76,7 +76,7 @@ SKIP: {
};
my $err = $@ || 'Zombie error';
ok($ok, "incremental decoder ($name) had no hissy fit")
- or note("Error: $err");
+ or note("Error: $err. Data structures decoded up to that point:\n" . Data::Dumper::Dumper(\@out));
is($out[$_-1], $_, "Decoding multiple packets from single string works ($name: $_)")
for 1..$n;
@@ -1,7 +1,7 @@
#!perl
use strict;
use warnings;
-use Sereal::Decoder qw(decode_sereal looks_like_sereal);
+use Sereal::Decoder qw(decode_sereal looks_like_sereal scalar_looks_like_sereal);
use Sereal::Decoder::Constants qw(:all);
use Data::Dumper;
use File::Spec;
@@ -22,12 +22,17 @@ my @tests = (
["=Srl". chr(1) . chr(0) . chr(SRL_HDR_UNDEF), 0, "wrong magic string is not Sereal"],
);
-plan tests => @tests * 3;
+plan tests => 2 + @tests * 5;
+
+is prototype(\&looks_like_sereal), undef;
+is prototype(\&scalar_looks_like_sereal), "\$";
my $decoder = Sereal::Decoder->new;
foreach my $t (@tests) {
my ($input, $outcome, $name) = @$t;
- ok(looks_like_sereal($input) == $outcome, $name . " (function)");
- ok($decoder->looks_like_sereal($input) == $outcome, $name . " (object method)");
- ok(Sereal::Decoder->looks_like_sereal($input) == $outcome, $name . " (class method)");
+ is scalar_looks_like_sereal($input), !!$outcome, "$name (new function oppable)";
+ is &scalar_looks_like_sereal($input), !!$outcome, "$name (new function non-oppable)";
+ is looks_like_sereal($input), !!$outcome, "$name (old function)";
+ is $decoder->looks_like_sereal($input), !!$outcome, "$name (object method)";
+ is +Sereal::Decoder->looks_like_sereal($input), !!$outcome, "$name (class method)";
}
@@ -0,0 +1,36 @@
+use strict;
+use warnings;
+
+use Sereal::Decoder;
+use Test::More;
+
+if (eval "use Sereal::Encoder; 1") {
+ plan tests => 6;
+} else {
+ plan skip_all => "Requires Sereal::Encoder to be installed";
+}
+my $enc = Sereal::Encoder->new;
+my $dec = Sereal::Decoder->new;
+
+sub desc_special($) {
+ return $_[0] == \undef() ? "undef" :
+ $_[0] == \!1 ? "false" :
+ $_[0] == \!0 ? "true" :
+ "not-special";
+}
+
+foreach(
+ [ "ref undef", \undef(), "needs new tag in protocol" ],
+ [ "ref undef var", \do { my $z = undef }, "needs new tag in protocol" ],
+ [ "ref false", \!1, ],
+ [ "ref false var", \do { my $z = !1 }, ],
+ [ "ref true", \!0, ],
+ [ "ref true var ", \do { my $z = !0 }, ],
+) {
+ my ($name, $var, $todo)= @$_;
+ TODO: {
+ todo_skip $todo, 1 if $todo;
+ is( desc_special($dec->decode($enc->encode($var))), desc_special($var), $name );
+
+ }
+}
@@ -0,0 +1,31 @@
+#!perl
+use strict;
+use warnings;
+use Sereal::Decoder;
+
+use Test::More;
+if (eval "use Sereal::Encoder; 1") {
+ plan tests => 1004;
+}
+else {
+ plan skip_all => 'Requires an encoder';
+}
+
+my $e= Sereal::Encoder->new();
+my $d= Sereal::Decoder->new();
+
+for ( 1 .. 1000, [ 'a' .. 'z' ], [ 'A' .. 'Z' ], [ 0 .. 100 ], [ 10000 .. 10512 ] ) {
+ my %hash;
+ if (ref $_) {
+ $hash{$_}++ for @$_;
+ } else {
+ $hash{rand()}++ for 1..26;
+ }
+ my $undump= $d->decode($e->encode(\%hash));
+ my $count= 0;
+ while( my ($h, $k)= each %$undump ) {
+ $count++;
+ }
+ is($count, keys %hash, "Got the expected count of keys: [ @{[ sort keys %hash ]} ]");
+}
+
@@ -1,38 +0,0 @@
-#!perl
-use strict;
-use warnings;
-use Sereal::Decoder;
-use Data::Dumper;
-use File::Spec;
-
-# These tests use an installed Decoder (or respectively Encoder) to do
-# round-trip testing. There are two strategies, both with drawbacks:
-# - Test::More's is_deeply is waaaay too lenient to catch all the
-# subtleties that Sereal is supposed to encode.
-# - Serialize - Deserialize - Serialize, then do a string compare.
-# This won't catch if the first serialization has bogus output
-# but the subsequent de- & serialization work for the already
-# bogus output.
-# These tests can't replace carefully crafted manual tests, I fear.
-
-use lib File::Spec->catdir(qw(t lib));
-BEGIN {
- lib->import('lib')
- if !-d 't';
-}
-
-use Sereal::TestSet qw(:all);
-use Test::More;
-
-my $ok = have_encoder_and_decoder();
-if (not $ok) {
- plan skip_all => 'Did not find right version of encoder';
-}
-else {
- run_roundtrip_tests(2); # 2 == run only tests for proto v2
-}
-
-
-pass();
-done_testing();
-
@@ -1,38 +0,0 @@
-#!perl
-use strict;
-use warnings;
-use Sereal::Decoder;
-use Data::Dumper;
-use File::Spec;
-
-# These tests use an installed Decoder (or respectively Encoder) to do
-# round-trip testing. There are two strategies, both with drawbacks:
-# - Test::More's is_deeply is waaaay too lenient to catch all the
-# subtleties that Sereal is supposed to encode.
-# - Serialize - Deserialize - Serialize, then do a string compare.
-# This won't catch if the first serialization has bogus output
-# but the subsequent de- & serialization work for the already
-# bogus output.
-# These tests can't replace carefully crafted manual tests, I fear.
-
-use lib File::Spec->catdir(qw(t lib));
-BEGIN {
- lib->import('lib')
- if !-d 't';
-}
-
-use Sereal::TestSet qw(:all);
-use Test::More;
-
-my $ok = have_encoder_and_decoder();
-if (not $ok) {
- plan skip_all => 'Did not find right version of encoder';
-}
-else {
- run_roundtrip_tests(1); # 1 == run only tests for proto v1
-}
-
-
-pass();
-done_testing();
-
@@ -0,0 +1,38 @@
+#!perl
+use strict;
+use warnings;
+use Sereal::Decoder;
+use Data::Dumper;
+use File::Spec;
+
+# These tests use an installed Decoder (or respectively Encoder) to do
+# round-trip testing. There are two strategies, both with drawbacks:
+# - Test::More's is_deeply is waaaay too lenient to catch all the
+# subtleties that Sereal is supposed to encode.
+# - Serialize - Deserialize - Serialize, then do a string compare.
+# This won't catch if the first serialization has bogus output
+# but the subsequent de- & serialization work for the already
+# bogus output.
+# These tests can't replace carefully crafted manual tests, I fear.
+
+use lib File::Spec->catdir(qw(t lib));
+BEGIN {
+ lib->import('lib')
+ if !-d 't';
+}
+
+use Sereal::TestSet qw(:all);
+use Test::More;
+
+my $ok = have_encoder_and_decoder();
+if (not $ok) {
+ plan skip_all => 'Did not find right version of encoder';
+}
+else {
+ run_roundtrip_tests(2); # 2 == run only tests for proto v2
+}
+
+
+pass();
+done_testing();
+
@@ -0,0 +1,38 @@
+#!perl
+use strict;
+use warnings;
+use Sereal::Decoder;
+use Data::Dumper;
+use File::Spec;
+
+# These tests use an installed Decoder (or respectively Encoder) to do
+# round-trip testing. There are two strategies, both with drawbacks:
+# - Test::More's is_deeply is waaaay too lenient to catch all the
+# subtleties that Sereal is supposed to encode.
+# - Serialize - Deserialize - Serialize, then do a string compare.
+# This won't catch if the first serialization has bogus output
+# but the subsequent de- & serialization work for the already
+# bogus output.
+# These tests can't replace carefully crafted manual tests, I fear.
+
+use lib File::Spec->catdir(qw(t lib));
+BEGIN {
+ lib->import('lib')
+ if !-d 't';
+}
+
+use Sereal::TestSet qw(:all);
+use Test::More;
+
+my $ok = have_encoder_and_decoder();
+if (not $ok) {
+ plan skip_all => 'Did not find right version of encoder';
+}
+else {
+ run_roundtrip_tests(1); # 1 == run only tests for proto v1
+}
+
+
+pass();
+done_testing();
+
@@ -0,0 +1,15 @@
+#!perl
+use strict;
+use warnings;
+use Sereal::Decoder qw(decode_sereal);
+use Sereal::Decoder::Constants qw(:all);
+use Test::More tests => 4;
+
+for my $ref (\"", [], {}, \*STDERR) {
+ eval {
+ decode_sereal($ref);
+ 1;
+ } or do {
+ like($@, qr/We can't decode a reference as Sereal!/, "We'll die on " . ref($ref) . " references");
+ };
+}
@@ -0,0 +1,47 @@
+use strict;
+use warnings;
+use Sereal::Decoder;
+use File::Spec;
+use lib File::Spec->catdir(qw(t lib));
+BEGIN {
+ lib->import('lib')
+ if !-d 't';
+}
+
+use Sereal::TestSet qw(:all);
+use Test::More tests => 2;
+
+# Regression test for RT #93563
+
+# Decoder is (was) not re-entrant.
+
+my $dec;
+package Foo;
+sub FREEZE { my $x = Sereal::Encoder->new->encode($_[0]->{a}); return $x; }
+sub THAW { bless({a => $dec->decode($_[2])}, $_[0]) }
+
+package main;
+
+SKIP: {
+ my $have_enc = have_encoder_and_decoder();
+ if (not $have_enc) {
+ skip "Need encoder for Snappy regression tests", 2;
+ }
+ else {
+ $dec = Sereal::Decoder->new;
+ my $z = [ bless({a=>42},"Foo") ];
+ push @$z, $z;
+ my $a = Sereal::Encoder->new({freeze_callbacks=>1})->encode($z);
+ my $b;
+ my $err;
+ eval {
+ $b = $dec->decode($a);
+ 1
+ } or do {
+ $err = $@ || 'Zombie error';
+ };
+ ok(!$err, "Decoding did not barf")
+ or diag("Decoding barfed with '$err'");
+ is_deeply($b, $z, "Output from decoding is correct");
+ }
+}
@@ -66,12 +66,12 @@ sub read_files {
}
my $count= 0;
- foreach (@$corpus) {
- $count++ if $sub->($_);
+ foreach my $test (@$corpus) {
+ $count++ if $sub->($test);
}
return $count;
}
-
+#use Devel::Peek;
sub run_bulk_tests {
my %opt = @_;
@@ -79,8 +79,9 @@ sub run_bulk_tests {
my $total= read_files(sub { return 1 });
my $read= 0;
my $eval_ok= read_files(sub {
+ my $struct= $_[0];
diag("read $read\n") unless ++$read % 1000;
- my ($dump,$undump);
+ my ($dump, $undump);
my $ok= eval {
$dump = Sereal::Encoder::encode_sereal($_[0]);
$undump= Sereal::Decoder::decode_sereal($dump);
@@ -89,11 +90,19 @@ sub run_bulk_tests {
my $err = $@ || 'Zombie error';
ok($ok,"Error return is empty")
or diag("Error was: '$err'"), return $ok;
+ if ($ok and ref($struct) eq "HASH") {
+ my $each_count= 0;
+
+ $each_count++ while my($k,$v)= each %$undump;
- my $eval_dump= Data::Dumper->new([ $_[0] ])->Sortkeys(1)->Dump();
- my $undump_dump= Data::Dumper->new([ $undump ])->Sortkeys(1)->Dump();
- $ok= is_string($undump_dump, $eval_dump)
- or diag $_[0];
+ my $keys_count= 0 + keys %$struct;
+ is($each_count,$keys_count,"Number of keys match");
+ }
+
+ my $struct_dd= Data::Dumper->new([ $struct ])->Sortkeys(1)->Dump();
+ my $undump_dd= Data::Dumper->new([ $undump ])->Sortkeys(1)->Dump();
+ $ok= is_string($undump_dd, $struct_dd)
+ or diag $struct_dd;
return $ok;
});
is($total,$eval_ok);
@@ -130,5 +139,4 @@ sub run_bulk_tests {
note join "\n","", map {sprintf"%-20s" . (" %20s" x (@$_-1)), @$_ } @$result;
}
}
-
1;
@@ -110,7 +110,9 @@ sub dump_bless {
sub short_string {
die if length($_[0]) > SRL_MASK_SHORT_BINARY_LEN;
- return chr(SRL_HDR_SHORT_BINARY_LOW + length($_[0])) . $_[0];
+ my $tag = SRL_HDR_SHORT_BINARY_LOW + length($_[0]);
+ $tag |= SRL_HDR_TRACK_FLAG if $_[1];
+ return pack("c a*",$tag,$_[0]);
}
sub integer {
@@ -234,7 +236,7 @@ sub setup_tests {
my $d = array_head(3);
my $pos = offset($d);
my $tag = $opt->{aliased_dedupe_strings} ? SRL_HDR_ALIAS : SRL_HDR_COPY;
- $d .= short_string("foooo") . chr($tag) . varint($pos)
+ $d .= short_string("foooo",$opt->{aliased_dedupe_strings} ? 1 : 0) . chr($tag) . varint($pos)
. chr($tag) . varint($pos);
return $d;
}
@@ -258,7 +260,7 @@ sub setup_tests {
my $tag = $opt->{aliased_dedupe_strings} ? SRL_HDR_ALIAS : SRL_HDR_COPY;
my $d = array_head(2) . hash_head(2) . short_string("foooo");
my $pos = offset($d);
- $d .= short_string("foooo") . hash_head(2)
+ $d .= short_string("foooo",$opt->{aliased_dedupe_strings} ? 1 : 0) . hash_head(2)
. short_string("foooo2")
. chr($tag) . varint($pos);
return $d;
@@ -719,18 +721,21 @@ sub run_roundtrip_tests_internal {
my $encoder = Sereal::Encoder->new($opt);
foreach my $meth (
- ['functional',
- sub {Sereal::Encoder::encode_sereal(shift, $opt)},
- sub {Sereal::Decoder::decode_sereal(shift, $opt)}],
+ ['functional simple',
+ sub {Sereal::Encoder::encode_sereal($_[0], $opt)},
+ sub {Sereal::Decoder::decode_sereal($_[0], $opt)}],
['object-oriented',
- sub {$encoder->encode(shift)},
- sub {$decoder->decode(shift)}],
+ sub {$encoder->encode($_[0])},
+ sub {$decoder->decode($_[0])}],
+ ['functional with object',
+ sub {Sereal::Encoder::sereal_encode_with_object($encoder, $_[0])},
+ sub {Sereal::Decoder::sereal_decode_with_object($decoder, $_[0])}],
['header-body',
- sub {$encoder->encode(shift, 123456789)}, # header data is abitrary to stand out for debugging
- sub {$decoder->decode(shift)}],
+ sub {$encoder->encode($_[0], 123456789)}, # header data is abitrary to stand out for debugging
+ sub {$decoder->decode($_[0])}],
['header-only',
- sub {$encoder->encode(987654321, shift)}, # body data is abitrary to stand out for debugging
- sub {$decoder->decode_only_header(shift)}],
+ sub {$encoder->encode(987654321, $_[0])}, # body data is abitrary to stand out for debugging
+ sub {$decoder->decode_only_header($_[0])}],
)
{
my ($mname, $enc, $dec) = @$meth;
@@ -1,5 +1,3 @@
-# from "perlobject.map" Dean Roehrich, version 19960302
-
# O_OBJECT -> link an opaque C or C++ object to a blessed Perl object.
srl_encoder_t * O_OBJECT
srl_decoder_t * O_OBJECT
@@ -17,7 +15,7 @@ INPUT
O_OBJECT
if( sv_isobject($arg) && (SvTYPE(SvRV($arg)) == SVt_PVMG) )
- $var = ($type)SvIV((SV*)SvRV( $arg ));
+ $var = INT2PTR($type, SvIV((SV*)SvRV( $arg )));
else{
warn( \"${Package}::$func_name() -- $var is not a blessed SV reference\" );
XSRETURN_UNDEF;