The Perl Toolchain Summit needs more sponsors. If your company depends on Perl, please support this very important event.
/* Must be defined before including Perl header files or we slow down by 2x! */
#define PERL_NO_GET_CONTEXT

#include "EXTERN.h"
#include "perl.h"
#include "XSUB.h"

#define NEED_newSV_type
#include "ppport.h"

#include "srl_encoder.h"
#include "srl_buffer.h"

/* Generated code for exposing C constants to Perl */
#include "srl_protocol.h"
#include "const-c.inc"

#include "ptable.h"

#ifndef GvCV_set
# define GvCV_set(gv, cv) (GvCV(gv) = (cv))
#endif

#if defined(cv_set_call_checker) && defined(XopENTRY_set)
# define USE_CUSTOM_OPS 1
#else
# define USE_CUSTOM_OPS 0
#endif

#define pp1_sereal_encode_with_object(has_hdr) THX_pp1_sereal_encode_with_object(aTHX_ has_hdr)
static void
THX_pp1_sereal_encode_with_object(pTHX_ U8 has_hdr)
{
  SV *encoder_ref_sv, *encoder_sv, *body_sv, *header_sv;
  srl_encoder_t *enc;
  char *stash_name;
  SV *ret_sv;
  dSP;

  header_sv = has_hdr ? POPs : NULL;
  body_sv = POPs;
  PUTBACK;

  encoder_ref_sv = TOPs;

  if (!expect_true(
        encoder_ref_sv &&
        SvROK(encoder_ref_sv) &&
        (encoder_sv = SvRV(encoder_ref_sv)) &&
        SvOBJECT(encoder_sv) &&
        (stash_name= HvNAME(SvSTASH(encoder_sv))) &&
        !strcmp(stash_name, "Sereal::Encoder")
     ))
  {
    croak("handle is not a Sereal::Encoder handle");
  }

  enc= (srl_encoder_t *)SvIV(encoder_sv);

  if (header_sv && !SvOK(header_sv))
    header_sv = NULL;

  /* We always copy the string since we might reuse the string buffer. That
   * means we already have to do a malloc and we might as well use the
   * opportunity to allocate only as much memory as we really need to hold
   * the output. */
  ret_sv= srl_dump_data_structure_mortal_sv(aTHX_ enc, body_sv, header_sv, SRL_ENC_SV_COPY_ALWAYS);
  SPAGAIN;
  TOPs = ret_sv;
}

#if USE_CUSTOM_OPS

static OP *
THX_pp_sereal_encode_with_object(pTHX)
{
  pp1_sereal_encode_with_object(PL_op->op_private);
  return NORMAL;
}

static OP *
THX_ck_entersub_args_sereal_encode_with_object(pTHX_ OP *entersubop, GV *namegv, SV *ckobj)
{
  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, ckobj);
  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 < 2 || arity > 3))
    return entersubop;

  /* If we get here, we can replace the entersub with a suitable
   * sereal_encode_with_object custom OP. */

  pushop->op_sibling = cvop;
  lastargop->op_sibling = NULL;
  op_free(entersubop);
  newop = newUNOP(OP_CUSTOM, 0, firstargop);
  newop->op_private = arity == 3;
  newop->op_ppaddr = THX_pp_sereal_encode_with_object;

  return newop;
}

#endif /* USE_CUSTOM_OPS */

static void
THX_xsfunc_sereal_encode_with_object(pTHX_ CV *cv)
{
  dMARK;
  dSP;
  SSize_t arity = SP - MARK;
  PERL_UNUSED_ARG(cv);
  if (arity < 2 || arity > 3)
    croak("bad Sereal encoder usage");
  pp1_sereal_encode_with_object(arity == 3);
}

MODULE = Sereal::Encoder        PACKAGE = Sereal::Encoder
PROTOTYPES: DISABLE

BOOT:
{
#if USE_CUSTOM_OPS
  {
    XOP *xop;
    Newxz(xop, 1, XOP);
    XopENTRY_set(xop, xop_name, "sereal_encode_with_object");
    XopENTRY_set(xop, xop_desc, "sereal_encode_with_object");
    XopENTRY_set(xop, xop_class, OA_UNOP);
    Perl_custom_op_register(aTHX_ THX_pp_sereal_encode_with_object, xop);
  }
#endif /* USE_CUSTOM_OPS */
  {
    GV *gv;
    CV *cv = newXSproto_portable("Sereal::Encoder::sereal_encode_with_object",
                THX_xsfunc_sereal_encode_with_object, __FILE__, "$$;$");
#if USE_CUSTOM_OPS
    cv_set_call_checker(cv, THX_ck_entersub_args_sereal_encode_with_object, (SV*)cv);
#endif /* USE_CUSTOM_OPS */
    gv = gv_fetchpv("Sereal::Encoder::encode", GV_ADDMULTI, SVt_PVCV);
    GvCV_set(gv, cv);
  }
}

srl_encoder_t *
new(CLASS, opt = NULL)
    char *CLASS;
    HV *opt;
  CODE:
    RETVAL = srl_build_encoder_struct(aTHX_ opt);
    RETVAL->flags |= SRL_F_REUSE_ENCODER;
  OUTPUT: RETVAL

void
DESTROY(enc)
    srl_encoder_t *enc;
  CODE:
    srl_destroy_encoder(aTHX_ enc);


void
encode_sereal(src, opt = NULL)
    SV *src;
    HV *opt;
  PREINIT:
    srl_encoder_t *enc;
  PPCODE:
    enc = srl_build_encoder_struct(aTHX_ opt);
    assert(enc != NULL);
    /* Avoid copy by stealing string buffer if it is not too large.
     * This makes sense in the functional interface since the string
     * buffer isn't ever going to be reused. */
    ST(0) = srl_dump_data_structure_mortal_sv(aTHX_ enc, src, NULL, SRL_ENC_SV_REUSE_MAYBE);
    XSRETURN(1);

void
encode_sereal_with_header_data(src, hdr_user_data_src, opt = NULL)
    SV *src;
    SV *hdr_user_data_src;
    HV *opt;
  PREINIT:
    srl_encoder_t *enc;
  PPCODE:
    if (!SvOK(hdr_user_data_src))
      hdr_user_data_src = NULL;
    enc = srl_build_encoder_struct(aTHX_ opt);
    assert(enc != NULL);
    /* Avoid copy by stealing string buffer if it is not too large.
     * This makes sense in the functional interface since the string
     * buffer isn't ever going to be reused. */
    ST(0) = srl_dump_data_structure_mortal_sv(aTHX_ enc, src, hdr_user_data_src, SRL_ENC_SV_REUSE_MAYBE);
    XSRETURN(1);

MODULE = Sereal::Encoder        PACKAGE = Sereal::Encoder::Constants
PROTOTYPES: DISABLE

INCLUDE: const-xs.inc

MODULE = Sereal::Encoder        PACKAGE = Sereal::Encoder::_ptabletest

void
test()
  PREINIT:
    PTABLE_t *tbl;
    PTABLE_ITER_t *iter;
    PTABLE_ENTRY_t *ent;
    UV i, n = 20;
    char *check[20];
    char fail[5] = "not ";
    char noop[1] = "";
  CODE:
    tbl = PTABLE_new_size(10);
    for (i = 0; i < (UV)n; ++i) {
      PTABLE_store(tbl, INT2PTR(void *,(1000+i)), INT2PTR(void *, (1000+i)));
      check[i] = fail;
    }
    for (i = 0; i < (UV)n; ++i) {
      const UV res = (UV)PTABLE_fetch(tbl, INT2PTR(void *, (1000+i)));
      printf("%sok %u - fetch %u\n", (res == (UV)(1000+i)) ? noop : fail, (unsigned int)(1+i), (unsigned int)(i+1));
    }
    iter = PTABLE_iter_new(tbl);
    while ( NULL != (ent = PTABLE_iter_next(iter)) ) {
      const UV res = (PTR2UV(ent->value)) - 1000;
      if (res < 20)
        check[res] = noop;
      else
        abort();
    }
    for (i = 0; i < (UV)n; ++i) {
      printf("%sok %u - iter %u\n", check[i], (unsigned int)(21+i), (unsigned int)(i+1));
    }
    PTABLE_iter_free(iter);
    PTABLE_free(tbl);