//
// (C) Copyright 2011-2012 Sergey A. Babkin.
// This file is a part of Triceps.
// See the file COPYRIGHT for the copyright notice and license information
//
// The Triceps aggregator for Perl calls and the wrapper for it.
#include <typeinfo>
#include "EXTERN.h"
#include "perl.h"
#include "XSUB.h"
#include "ppport.h"
#include "TricepsPerl.h"
#include "PerlCallback.h"
#include "PerlAggregator.h"
#include "WrapAggregatorContext.h"
// ###################################################################################
using namespace TRICEPS_NS;
namespace TRICEPS_NS
{
namespace TricepsPerl
{
// ####################### PerlAggregatorType ########################################
PerlAggregatorType::PerlAggregatorType(const string &name, const RowType *rt,
Onceref<PerlCallback> cbConstructor, Onceref<PerlCallback> cbHandler):
AggregatorType(name, rt),
cbConstructor_(cbConstructor),
cbHandler_(cbHandler)
{ }
AggregatorType *PerlAggregatorType::copy() const
{
return new PerlAggregatorType(*this);
}
AggregatorGadget *PerlAggregatorType::makeGadget(Table *table, IndexType *intype) const
{
// just use the generic gadget, there is nothing special about it
return new AggregatorGadget(this, table, intype);
}
Aggregator *PerlAggregatorType::makeAggregator(Table *table, AggregatorGadget *gadget) const
{
SV *state = NULL;
if (!cbConstructor_.isNull()) {
dSP;
PerlCallbackStartCall(cbConstructor_);
PerlCallbackDoCallScalar(cbConstructor_, state);
if (SvTRUE(ERRSV)) {
// If in eval, croak may cause issues by doing longjmp(), so better just warn.
// Would exit(1) be better?
warn("Error in unit %s table %s aggregator %s constructor: %s",
gadget->getUnit()->getName().c_str(), table->getName().c_str(), gadget->getName().c_str(), SvPV_nolen(ERRSV));
}
}
return new PerlAggregator(table, gadget, state);
}
bool PerlAggregatorType::equals(const Type *t) const
{
if (!AggregatorType::equals(t))
return false;
const PerlAggregatorType *at = static_cast<const PerlAggregatorType *>(t);
return callbackEquals(cbConstructor_, at->cbConstructor_)
&& callbackEquals(cbHandler_, at->cbHandler_);
}
bool PerlAggregatorType::match(const Type *t) const
{
if (!AggregatorType::match(t))
return false;
const PerlAggregatorType *at = static_cast<const PerlAggregatorType *>(t);
return callbackEquals(cbConstructor_, at->cbConstructor_)
&& callbackEquals(cbHandler_, at->cbHandler_);
}
// ######################## PerlAggregator ###########################################
PerlAggregator::PerlAggregator(Table *table, AggregatorGadget *gadget, SV *sv):
sv_(sv)
{
if (sv_ != NULL)
SvREFCNT_inc(sv_);
}
PerlAggregator::~PerlAggregator()
{
if (sv_ != NULL)
SvREFCNT_dec(sv_);
}
void PerlAggregator::setsv(SV *sv)
{
if (sv_ != NULL)
SvREFCNT_dec(sv_);
sv_= sv;
if (sv_ != NULL)
SvREFCNT_inc(sv_);
}
void PerlAggregator::handle(Table *table, AggregatorGadget *gadget, Index *index,
const IndexType *parentIndexType, GroupHandle *gh, Tray *dest,
AggOp aggop, Rowop::Opcode opcode, RowHandle *rh, Tray *copyTray)
{
dSP;
const PerlAggregatorType *at = static_cast<const PerlAggregatorType *>(gadget->getType());
WrapTable *wtab = new WrapTable(table);
SV *svtab = newSV(0);
sv_setref_pv(svtab, "Triceps::Table", (void *)wtab);
WrapAggregatorContext *ctx = new WrapAggregatorContext(table, gadget, index, parentIndexType, gh, dest, copyTray);
SV *svctx = newSV(0);
sv_setref_pv(svctx, "Triceps::AggregatorContext", (void *)ctx); // takes over the reference
// warn("DEBUG PerlAggregator::handle context %p created with refcnt %d ptr %d", ctx, SvREFCNT(svctx), SvROK(svctx));
SV *svctxcopy = newSV(0); // makes sure that the context stays referenced even if Perl code thanges its SV
sv_setsv(svctxcopy, svctx);
SV *svaggop = newSViv(aggop);
SV *svopcode = newSViv(opcode);
WrapRowHandle *wrh = new WrapRowHandle(table, rh);
SV *svrh = newSV(0);
sv_setref_pv(svrh, "Triceps::RowHandle", (void *)wrh);
PerlCallbackStartCall(at->cbHandler_);
XPUSHs(svtab);
XPUSHs(svctx);
XPUSHs(svaggop);
XPUSHs(svopcode);
XPUSHs(svrh);
if (sv_ != NULL)
XPUSHs(sv_);
else
XPUSHs(&PL_sv_undef);
PerlCallbackDoCall(at->cbHandler_);
// warn("DEBUG PerlAggregator::handle invalidating context");
ctx->invalidate(); // context will stop working, even if Perl code kept a reference
// this calls the DELETE methods on wrappers
SvREFCNT_dec(svtab);
// warn("DEBUG PerlAggregator::handle context decrease refcnt %d ptr %d", SvREFCNT(svctx), SvROK(svctx));
SvREFCNT_dec(svctx);
// warn("DEBUG PerlAggregator::handle context copy decrease refcnt %d ptr %d", SvREFCNT(svctxcopy), SvROK(svctxcopy));
SvREFCNT_dec(svctxcopy);
SvREFCNT_dec(svaggop);
SvREFCNT_dec(svopcode);
SvREFCNT_dec(svrh);
if (SvTRUE(ERRSV)) {
// If in eval, croak may cause issues by doing longjmp(), so better just warn.
// Would exit(1) be better?
warn("Error in unit %s table %s aggregator %s handler: %s",
gadget->getUnit()->getName().c_str(), table->getName().c_str(), gadget->getName().c_str(), SvPV_nolen(ERRSV));
}
// warn("DEBUG PerlAggregator::handle done");
}
// ########################## wraps ##################################################
WrapMagic magicWrapAggregatorType = { "AggType" };
}; // Triceps::TricepsPerl
}; // Triceps