MP_INLINE SV *modperl_ptr2obj(pTHX_ char *classname, void *ptr)
{
SV *sv = newSV(0);
MP_TRACE_h(MP_FUNC, "sv_setref_pv(%s, 0x%lx)",
classname, (unsigned long)ptr);
sv_setref_pv(sv, classname, ptr);
return sv;
}
SV *
plu_new_table_object_perl(pTHX_ lua_State *L)
{
SV *sv;
PLU_dSTACKASSERT;
PLU_ENTER_STACKASSERT(L);
plu_table_t *tbl = plu_new_table_object(aTHX_ L);
sv = newSV(0);
sv_setref_pv( sv, "PLua::Table", (void*)tbl );
PLU_LEAVE_STACKASSERT_MODIFIED(L, -1);
return sv;
}
SV * bless_pointer_to_package(void *data, const char *package)
{
SV *ret = newSV(0);
sv_setref_pv(ret, package, data);
/* If this function is being called, then the XS method in question
* is declared as returning SV*, which means the magic typemap code
* doesn't get called, and we have to do this manually.
*/
register_object_reference(ret);
return ret;
}
SV *
new_sv_for_c_obj(
gpointer c_obj,
const char *perl_class)
{
SV *sv = newSV(0);
/* Make an SV that contains a pointer to the object, and bless it
* with the appropriate class. */
sv_setref_pv(sv, perl_class, c_obj);
return sv;
}
void EQWParser::SetHTTPRequest(const char *pkg, HTTPRequest *it) {
char namebuf[64];
snprintf(namebuf, 64, "package %s;", pkg);
eval_pv(namebuf, FALSE);
snprintf(namebuf, 64, "request");
// snprintf(namebuf, 64, "%s::EQW", pkg);
SV *l = get_sv(namebuf, true);
if(it != nullptr) {
sv_setref_pv(l, "HTTPRequest", it);
} else {
//clear out the value, mainly to get rid of blessedness
sv_setsv(l, _empty_sv);
}
}
/* Get a new specfile */
void _newspec(rpmts ts, char * filename, SV * svpassphrase, SV * svrootdir, SV * svcookies, SV * svanyarch, SV * svforce, SV * svverify) {
Spec spec = NULL;
char * passphrase = NULL;
char * rootdir = NULL;
char * cookies = NULL;
int anyarch = 0;
int force = 0;
int verify = 0;
dSP;
if (svpassphrase && SvOK(svpassphrase))
passphrase = SvPV_nolen(svpassphrase);
if (svrootdir && SvOK(svrootdir))
rootdir = SvPV_nolen(svrootdir);
else
rootdir = "/";
if (svcookies && SvOK(svcookies))
cookies = SvPV_nolen(svcookies);
if (svanyarch && SvOK(svanyarch))
anyarch = SvIV(svanyarch);
if (svforce && SvOK(svforce))
force = SvIV(svforce);
if (svverify && SvOK(svverify))
verify = SvIV(svverify);
if (filename) {
if (!parseSpec(ts, filename, rootdir, 0, passphrase, cookies, anyarch, force, verify))
spec = rpmtsSetSpec(ts, NULL);
#ifdef HHACK
} else {
spec = newSpec();
#endif
}
if (spec) {
XPUSHs(sv_2mortal(sv_setref_pv(newSVpv("", 0), "RPM::Spec", (void *)spec)));
} else
XPUSHs(sv_2mortal(&PL_sv_undef));
PUTBACK;
return;
}
void PJS_store_class(PJS_Context *pcx, PJS_Class *cls) {
/* Add class to list of classes in contexts */
SV *sv = newSV(0);
sv_setref_pv(sv, "JavaScript::PerlClass", (void*) cls);
if (cls->clasp->name != NULL) {
if(hv_store(pcx->class_by_name, cls->clasp->name, strlen(cls->clasp->name), sv, 0) == NULL) {
/* TODO: better error here */
croak("Failed to store class: %s in class_by_name in context", cls->clasp->name);
return;
}
}
if (cls->pkg != NULL) {
SvREFCNT_inc(sv);
hv_store(pcx->class_by_package, cls->pkg, strlen(cls->pkg), sv, 0);
}
}
static int
hbm_perl_exec (HBArgs *d, char *code)
{
dSP;
SV *args;
SV *retval;
args = perl_get_sv("args", TRUE);
if (!args)
printf("PANIC: No args\n");
sv_setref_pv(args, "hbargsPtr", (void*) d);
retval = perl_eval_pv(code, TRUE);
return SvIV(retval);
}
MP_INLINE static void
modperl_io_perlio_override_stdhandle(pTHX_ request_rec *r, int mode)
{
dHANDLE(mode == O_RDONLY ? "STDIN" : "STDOUT");
int status;
SV *sv = sv_newmortal();
MP_TRACE_o(MP_FUNC, "start STD%s", mode == O_RDONLY ? "IN" : "OUT");
save_gp(handle, 1);
sv_setref_pv(sv, "Apache2::RequestRec", (void*)r);
status = do_open9(handle, mode == O_RDONLY ? "<:Apache2" : ">:Apache2",
9, FALSE, mode, 0, (PerlIO *)NULL, sv, 1);
if (status == 0) {
Perl_croak(aTHX_ "Failed to open STD%s: %" SVf,
mode == O_RDONLY ? "IN" : "OUT", get_sv("!", TRUE));
}
MP_TRACE_o(MP_FUNC, "end STD%s", mode==O_RDONLY ? "IN" : "OUT");
}
SV*
PmmContextSv( xmlParserCtxtPtr ctxt )
{
ProxyNodePtr dfProxy= NULL;
SV * retval = &PL_sv_undef;
const char * CLASS = "XML::LibXML::ParserContext";
if ( ctxt != NULL ) {
dfProxy = PmmNewContext(ctxt);
retval = NEWSV(0,0);
sv_setref_pv( retval, CLASS, (void*)dfProxy );
PmmREFCNT_inc(dfProxy);
/* fprintf(stderr, "REFCNT incremented on new context: 0x%08.8X\n", dfProxy); */
}
else {
xs_warn( "PmmContextSv: no node found!\n" );
}
return retval;
}
void
perl_command_handler(struct sourceinfo *si, const int parc, char **parv)
{
struct perl_command * pc = (struct perl_command *) si->command;
dTHX;
dSP;
ENTER;
SAVETMPS;
PUSHMARK(SP);
XPUSHs(pc->handler);
SV *sourceinfo_sv = newSV(0);
sv_setref_pv(sourceinfo_sv, "Atheme::Sourceinfo", si);
XPUSHs(sv_2mortal(sourceinfo_sv));
for (int i = 0; i < parc; ++i)
XPUSHs(sv_2mortal(newSVpv(parv[i], 0)));
PUTBACK;
call_pv("Atheme::Init::call_wrapper", G_VOID | G_DISCARD | G_EVAL);
SPAGAIN;
if (SvTRUE(ERRSV))
{
command_fail(si, fault_unimplemented, _("Unexpected error occurred: %s"), SvPV_nolen(ERRSV));
slog(LG_ERROR, "Perl handler for command %s/%s returned error: %s",
si->service->internal_name, si->command->name, SvPV_nolen(ERRSV));
}
PUTBACK;
FREETMPS;
LEAVE;
/* Control has now handed back to Atheme, so all references held
* by Perl to Atheme objects are invalid.
*/
invalidate_object_references();
}
void EQWParser::DoInit() {
const char *argv_eqemu[] = { "",
"-w", "-W",
"-e", "0;", nullptr };
int argc = 5;
char **argv = (char **)argv_eqemu;
char **env = { nullptr };
PL_perl_destruct_level = 1;
perl_construct(my_perl);
PERL_SYS_INIT3(&argc, &argv, &env);
perl_parse(my_perl, xs_init, argc, argv, env);
perl_run(my_perl);
//a little routine we use a lot.
eval_pv("sub my_eval {eval $_[0];}", TRUE); //dies on error
//ruin the perl exit and command:
eval_pv("sub my_exit {}",TRUE);
eval_pv("sub my_sleep {}",TRUE);
if(gv_stashpv("CORE::GLOBAL", FALSE)) {
GV *exitgp = gv_fetchpv("CORE::GLOBAL::exit", TRUE, SVt_PVCV);
GvCV_set(exitgp, perl_get_cv("my_exit", TRUE)); //dies on error
GvIMPORTED_CV_on(exitgp);
GV *sleepgp = gv_fetchpv("CORE::GLOBAL::sleep", TRUE, SVt_PVCV);
GvCV_set(sleepgp, perl_get_cv("my_sleep", TRUE)); //dies on error
GvIMPORTED_CV_on(sleepgp);
}
//setup eval_file
eval_pv(
"our %Cache;"
"use Symbol qw(delete_package);"
"sub eval_file {"
"my($package, $filename) = @_;"
"$filename=~s/\'//g;"
"if(! -r $filename) { print \"Unable to read perl file '$filename'\\n\"; return; }"
"my $mtime = -M $filename;"
"if(defined $Cache{$package}{mtime}&&$Cache{$package}{mtime} <= $mtime && !($package eq 'plugin')){"
" return;"
"} else {"
//we 'my' $filename,$mtime,$package,$sub to prevent them from changing our state up here.
" eval(\"package $package; my(\\$filename,\\$mtime,\\$package,\\$sub); \\$isloaded = 1; require '$filename'; \");"
"}"
"}"
,FALSE);
//make a tie-able class to capture IO and get it where it needs to go
eval_pv(
"package EQWIO; "
// "&boot_EQEmuIO;"
"sub TIEHANDLE { my $me = bless {}, $_[0]; $me->PRINT('Creating '.$me); return($me); } "
"sub WRITE { } "
"sub PRINTF { my $me = shift; my $fmt = shift; $me->PRINT(sprintf($fmt, @_)); } "
"sub CLOSE { my $me = shift; $me->PRINT('Closing '.$me); } "
"sub DESTROY { my $me = shift; $me->PRINT('Destroying '.$me); } "
//this ties us for all packages
"package MAIN;"
" if(tied *STDOUT) { untie(*STDOUT); }"
" if(tied *STDERR) { untie(*STDERR); }"
" tie *STDOUT, 'EQWIO';"
" tie *STDERR, 'EQWIO';"
,FALSE);
eval_pv(
"package world; "
,FALSE
);
//make sure the EQW pointer is set up in this package
EQW *curc = EQW::Singleton();
SV *l = get_sv("world::EQW", true);
if(curc != nullptr) {
sv_setref_pv(l, "EQW", curc);
} else {
//clear out the value, mainly to get rid of blessedness
sv_setsv(l, _empty_sv);
}
//make sure the EQDB pointer is set up in this package
EQDB::SetMySQL(database.getMySQL());
EQDB *curc_db = EQDB::Singleton();
SV *l_db = get_sv("world::EQDB", true);
if(curc_db != nullptr) {
sv_setref_pv(l_db, "EQDB", curc_db);
} else {
//clear out the value, mainly to get rid of blessedness
sv_setsv(l_db, _empty_sv);
}
//load up EQW
eval_pv(
"package EQW;"
"&boot_EQW;" //load our EQW XS
"package EQDB;"
"&boot_EQDB;" //load our EQW XS
"package EQDBRes;"
"&boot_EQDBRes;" //load our EQW XS
"package HTTPRequest;"
"&boot_HTTPRequest;" //load our HTTPRequest XS
"package EQLConfig;"
"&boot_EQLConfig;" //load our EQLConfig XS
, FALSE );
#ifdef EMBPERL_PLUGIN
Log.Out(Logs::Detail, Logs::World_Server, "Loading worldui perl plugins.");
std::string err;
if(!eval_file("world", "worldui.pl", err)) {
Log.Out(Logs::Detail, Logs::World_Server, "Warning - world.pl: %s", err.c_str());
}
eval_pv(
"package world; "
"if(opendir(D,'worldui')) { "
" my @d = readdir(D);"
" closedir(D);"
" foreach(@d){ "
" next unless(/\\.pl$); "
" require 'templates/'.$_;"
" }"
"}"
,FALSE);
#endif //EMBPERL_PLUGIN
}
SV *
x_PmmNodeToSv(xmlNodePtr node, ProxyNodePtr owner)
{
ProxyNodePtr dfProxy= NULL;
SV * retval = &PL_sv_undef;
const char * CLASS = "XML::LibXML::Node";
if ( node != NULL ) {
#ifdef XML_LIBXML_THREADS
if( x_PmmUSEREGISTRY )
SvLOCK(x_PROXY_NODE_REGISTRY_MUTEX);
#endif
/* find out about the class */
CLASS = x_PmmNodeTypeName( node );
if ( node->_private != NULL ) {
dfProxy = x_PmmNewNode(node);
/* warn(" at 0x%08.8X\n", dfProxy); */
}
else {
dfProxy = x_PmmNewNode(node);
/* fprintf(stderr, " at 0x%08.8X\n", dfProxy); */
if ( dfProxy != NULL ) {
if ( owner != NULL ) {
dfProxy->owner = x_PmmNODE( owner );
x_PmmREFCNT_inc( owner );
/* fprintf(stderr, "REFCNT incremented on owner: 0x%08.8X\n", owner); */
}
}
else {
warn("x_PmmNodeToSv: proxy creation failed!\n");
}
}
retval = NEWSV(0,0);
sv_setref_pv( retval, CLASS, (void*)dfProxy );
#ifdef XML_LIBXML_THREADS
if( x_PmmUSEREGISTRY )
x_PmmRegistryREFCNT_inc(dfProxy);
#endif
x_PmmREFCNT_inc(dfProxy);
/* fprintf(stderr, "REFCNT incremented on node: 0x%08.8X\n", dfProxy); */
switch ( node->type ) {
case XML_DOCUMENT_NODE:
case XML_HTML_DOCUMENT_NODE:
case XML_DOCB_DOCUMENT_NODE:
if ( ((xmlDocPtr)node)->encoding != NULL ) {
x_SetPmmENCODING(dfProxy, (int)xmlParseCharEncoding( (const char*)((xmlDocPtr)node)->encoding ));
}
break;
default:
break;
}
#ifdef XML_LIBXML_THREADS
if( x_PmmUSEREGISTRY )
SvUNLOCK(x_PROXY_NODE_REGISTRY_MUTEX);
#endif
}
else {
warn( "x_PmmNodeToSv: no node found!\n" );
}
return retval;
}
SV*
ExPolygon::to_SV_clone_ref() const {
SV* sv = newSV(0);
sv_setref_pv( sv, "Slic3r::ExPolygon", new ExPolygon(*this) );
return sv;
}
SV*
ExPolygon::to_SV_ref() {
SV* sv = newSV(0);
sv_setref_pv( sv, "Slic3r::ExPolygon::Ref", this );
return sv;
}
SV*
Polygon::to_SV_ref() {
SV* sv = newSV(0);
sv_setref_pv( sv, "Slic3r::Polygon::Ref", (void*)this );
return sv;
}
SV *
PmmNodeToGdomeSv( xmlNodePtr node )
{
SV * retval = &PL_sv_undef;
#ifdef XML_LIBXML_GDOME_SUPPORT
GdomeNode * gnode = NULL;
GdomeException exc;
const char * CLASS = "";
if ( node != NULL ) {
gnode = gdome_xml_n_mkref( node );
if ( gnode != NULL ) {
switch (gdome_n_nodeType(gnode, &exc)) {
case GDOME_ELEMENT_NODE:
CLASS = "XML::GDOME::Element";
break;
case GDOME_ATTRIBUTE_NODE:
CLASS = "XML::GDOME::Attr";
break;
case GDOME_TEXT_NODE:
CLASS = "XML::GDOME::Text";
break;
case GDOME_CDATA_SECTION_NODE:
CLASS = "XML::GDOME::CDATASection";
break;
case GDOME_ENTITY_REFERENCE_NODE:
CLASS = "XML::GDOME::EntityReference";
break;
case GDOME_ENTITY_NODE:
CLASS = "XML::GDOME::Entity";
break;
case GDOME_PROCESSING_INSTRUCTION_NODE:
CLASS = "XML::GDOME::ProcessingInstruction";
break;
case GDOME_COMMENT_NODE:
CLASS = "XML::GDOME::Comment";
break;
case GDOME_DOCUMENT_TYPE_NODE:
CLASS = "XML::GDOME::DocumentType";
break;
case GDOME_DOCUMENT_FRAGMENT_NODE:
CLASS = "XML::GDOME::DocumentFragment";
break;
case GDOME_NOTATION_NODE:
CLASS = "XML::GDOME::Notation";
break;
case GDOME_DOCUMENT_NODE:
CLASS = "XML::GDOME::Document";
break;
default:
break;
}
retval = NEWSV(0,0);
sv_setref_pv( retval, CLASS, gnode);
}
}
#endif
return retval;
}
SV*
Point::to_SV_ref() {
SV* sv = newSV(0);
sv_setref_pv( sv, perl_class_name_ref(this), (void*)this );
return sv;
}
SV*
c2p_pkg(void *p)
{
SV *rv = newSV(0);
return sv_setref_pv(rv, "ALPM::Package", p);
}
SV*
Point::to_SV_clone_ref() const {
SV* sv = newSV(0);
sv_setref_pv( sv, "Slic3r::Point", new Point(*this) );
return sv;
}
int perl_exec2(struct sip_msg* _msg, char* fnc, char* mystr) {
int retval;
SV *m;
str reason;
app_perl_reset_interpreter();
dSP;
if (!perl_checkfnc(fnc)) {
LM_ERR("unknown perl function called.\n");
reason.s = "Internal error";
reason.len = sizeof("Internal error")-1;
if (slb.freply(_msg, 500, &reason) == -1)
{
LM_ERR("failed to send reply\n");
}
return -1;
}
switch ((_msg->first_line).type) {
case SIP_REQUEST:
if (parse_sip_msg_uri(_msg) < 0) {
LM_ERR("failed to parse Request-URI\n");
reason.s = "Bad Request-URI";
reason.len = sizeof("Bad Request-URI")-1;
if (slb.freply(_msg, 400, &reason) == -1) {
LM_ERR("failed to send reply\n");
}
return -1;
}
break;
case SIP_REPLY:
break;
default:
LM_ERR("invalid firstline");
return -1;
}
ENTER; /* everything created after here */
SAVETMPS; /* ...is a temporary variable. */
PUSHMARK(SP); /* remember the stack pointer */
m = sv_newmortal();
sv_setref_pv(m, "Kamailio::Message", (void *)_msg);
SvREADONLY_on(SvRV(m));
XPUSHs(m); /* Our reference to the stack... */
if (mystr)
XPUSHs(sv_2mortal(newSVpv(mystr, strlen(mystr))));
/* Our string to the stack... */
PUTBACK; /* make local stack pointer global */
call_pv(fnc, G_EVAL|G_SCALAR); /* call the function */
SPAGAIN; /* refresh stack pointer */
/* pop the return value from stack */
retval = POPi;
PUTBACK;
FREETMPS; /* free that return value */
LEAVE; /* ...and the XPUSHed "mortal" args.*/
return retval;
}
int PerlembParser::SendCommands(const char *pkgprefix, const char *event, uint32 npcid, Mob* other, Mob* mob, ItemInst* iteminst) {
if(!perl)
return 0;
int ret_value = 0;
if(mob && mob->IsClient())
quest_manager.StartQuest(other, mob->CastToClient(), iteminst);
else
quest_manager.StartQuest(other, nullptr, nullptr);
try {
std::string cmd = "package " + (std::string)(pkgprefix) + (std::string)(";");
perl->eval(cmd.c_str());
#ifdef EMBPERL_XS_CLASSES
{
std::string cl = (std::string)"$" + (std::string)pkgprefix + (std::string)"::client";
std::string np = (std::string)"$" + (std::string)pkgprefix + (std::string)"::npc";
std::string qi = (std::string)"$" + (std::string)pkgprefix + (std::string)"::questitem";
std::string enl = (std::string)"$" + (std::string)pkgprefix + (std::string)"::entity_list";
if(clear_vars_.find(cl) != clear_vars_.end()) {
std::string eval_str = cl;
eval_str += " = undef;";
perl->eval(eval_str.c_str());
}
if (clear_vars_.find(np) != clear_vars_.end()) {
std::string eval_str = np;
eval_str += " = undef;";
perl->eval(eval_str.c_str());
}
if (clear_vars_.find(qi) != clear_vars_.end()) {
std::string eval_str = qi;
eval_str += " = undef;";
perl->eval(eval_str.c_str());
}
if (clear_vars_.find(enl) != clear_vars_.end()) {
std::string eval_str = enl;
eval_str += " = undef;";
perl->eval(eval_str.c_str());
}
}
char namebuf[64];
//init a couple special vars: client, npc, entity_list
Client *curc = quest_manager.GetInitiator();
snprintf(namebuf, 64, "%s::client", pkgprefix);
SV *client = get_sv(namebuf, true);
if(curc != nullptr) {
sv_setref_pv(client, "Client", curc);
} else {
//clear out the value, mainly to get rid of blessedness
sv_setsv(client, _empty_sv);
}
//only export NPC if it's a npc quest
if(!other->IsClient()) {
NPC *curn = quest_manager.GetNPC();
snprintf(namebuf, 64, "%s::npc", pkgprefix);
SV *npc = get_sv(namebuf, true);
sv_setref_pv(npc, "NPC", curn);
}
//only export QuestItem if it's an item quest
if(iteminst) {
ItemInst* curi = quest_manager.GetQuestItem();
snprintf(namebuf, 64, "%s::questitem", pkgprefix);
SV *questitem = get_sv(namebuf, true);
sv_setref_pv(questitem, "QuestItem", curi);
}
snprintf(namebuf, 64, "%s::entity_list", pkgprefix);
SV *el = get_sv(namebuf, true);
sv_setref_pv(el, "EntityList", &entity_list);
#endif
//now call the requested sub
ret_value = perl->dosub(std::string(pkgprefix).append("::").append(event).c_str());
#ifdef EMBPERL_XS_CLASSES
{
std::string cl = (std::string)"$" + (std::string)pkgprefix + (std::string)"::client";
std::string np = (std::string)"$" + (std::string)pkgprefix + (std::string)"::npc";
std::string qi = (std::string)"$" + (std::string)pkgprefix + (std::string)"::questitem";
std::string enl = (std::string)"$" + (std::string)pkgprefix + (std::string)"::entity_list";
clear_vars_[cl] = 1;
clear_vars_[np] = 1;
clear_vars_[qi] = 1;
clear_vars_[enl] = 1;
}
#endif
} catch(const char * err) {
//try to reduce some of the console spam...
//todo: tweak this to be more accurate at deciding what to filter (we don't want to gag legit errors)
if(!strstr(err,"Undefined subroutine")) {
std::string error = "Script error: ";
error += pkgprefix;
error += "::";
error += event;
error += " - ";
if(strlen(err) > 0)
error += err;
AddError(error);
}
}
quest_manager.EndQuest();
#ifdef EMBPERL_XS_CLASSES
if(!quest_manager.QuestsRunning()) {
auto iter = clear_vars_.begin();
std::string eval_str;
while(iter != clear_vars_.end()) {
eval_str += iter->first;
eval_str += " = undef;";
++iter;
}
clear_vars_.clear();
try {
perl->eval(eval_str.c_str());
}
catch (const char * err) {
std::string error = "Script clear error: ";
if (strlen(err) > 0)
error += err;
AddError(error);
}
}
#endif
return ret_value;
}
/*
* Run function, with current SIP message as a parameter
*/
int perl_exec(struct sip_msg* _msg, str* _fnc_s, str* mystr)
{
int retval;
SV *m;
str reason;
str pfnc, pparam;
char *fnc;
fnc = pkg_malloc(_fnc_s->len);
if (!fnc) {
LM_ERR("No more pkg mem!\n");
return -1;
}
memcpy(fnc, _fnc_s->s, _fnc_s->len);
fnc[_fnc_s->len] = 0;
dSP;
if (!perl_checkfnc(fnc)) {
LM_ERR("unknown perl function called.\n");
reason.s = "Internal error";
reason.len = sizeof("Internal error")-1;
if (sigb.reply(_msg, 500, &reason, NULL) == -1)
{
LM_ERR("failed to send reply\n");
}
goto error;
}
switch ((_msg->first_line).type) {
case SIP_REQUEST:
if (parse_sip_msg_uri(_msg) < 0) {
LM_ERR("failed to parse Request-URI\n");
reason.s = "Bad Request-URI";
reason.len = sizeof("Bad Request-URI")-1;
if (sigb.reply(_msg, 400, &reason, NULL) == -1) {
LM_ERR("failed to send reply\n");
}
goto error;
}
break;
case SIP_REPLY:
break;
default:
LM_ERR("invalid firstline\n");
goto error;
}
ENTER; /* everything created after here */
SAVETMPS; /* ...is a temporary variable. */
PUSHMARK(SP); /* remember the stack pointer */
m = sv_newmortal(); /* create a mortal SV to be killed on FREETMPS */
sv_setref_pv(m, "OpenSIPS::Message", (void *)_msg); /* bless the message with a class */
SvREADONLY_on(SvRV(m)); /* set the content of m to be readonly */
XPUSHs(m); /* Our reference to the stack... */
if (mystr)
XPUSHs(sv_2mortal(newSVpv(mystr->s, mystr->len)));
/* Our string to the stack... */
PUTBACK; /* make local stack pointer global */
call_pv(fnc, G_EVAL|G_SCALAR); /* call the function */
SPAGAIN; /* refresh stack pointer */
/* pop the return value from stack */
retval = POPi;
PUTBACK;
FREETMPS; /* free that return value */
LEAVE; /* ...and the XPUSHed "mortal" args.*/
return retval;
error:
pkg_free(fnc);
return -1;
}
SV*
Line::to_SV_ref() {
SV* sv = newSV(0);
sv_setref_pv( sv, perl_class_name_ref(this), this );
return sv;
}
/* This may call Perl code (via get_field), so it needs to be wrapped with
* PUTBACK/SPAGAIN by the caller. */
static SV *
struct_to_sv (GIBaseInfo* info,
GIInfoType info_type,
gpointer pointer,
gboolean own)
{
HV *hv;
dwarn ("pointer = %p\n", pointer);
if (pointer == NULL) {
return &PL_sv_undef;
}
if (is_struct_disguised (info)) {
SV *sv;
gchar *package;
dwarn (" disguised struct\n");
g_assert (!own);
package = get_struct_package (info);
g_assert (package);
sv = newSV (0);
sv_setref_pv (sv, package, pointer);
g_free (package);
return sv;
}
hv = newHV ();
switch (info_type) {
case GI_INFO_TYPE_BOXED:
case GI_INFO_TYPE_STRUCT:
{
gint i, n_fields =
g_struct_info_get_n_fields ((GIStructInfo *) info);
for (i = 0; i < n_fields; i++) {
GIFieldInfo *field_info;
SV *sv;
field_info =
g_struct_info_get_field ((GIStructInfo *) info, i);
dwarn (" field %d (%s)\n", i, g_base_info_get_name (field_info));
/* FIXME: Check GIFieldInfoFlags. */
/* FIXME: Is it right to use GI_TRANSFER_NOTHING
* here? */
sv = get_field (field_info, pointer,
GI_TRANSFER_NOTHING);
if (gperl_sv_is_defined (sv)) {
const gchar *name;
name = g_base_info_get_name (
(GIBaseInfo *) field_info);
gperl_hv_take_sv (hv, name, strlen (name), sv);
}
g_base_info_unref ((GIBaseInfo *) field_info);
}
break;
}
case GI_INFO_TYPE_UNION:
ccroak ("%s: unions not handled yet", G_STRFUNC);
default:
ccroak ("%s: unhandled info type %d", G_STRFUNC, info_type);
}
if (own) {
/* FIXME: Is it correct to just call g_free here? What if the
* thing was allocated via GSlice? */
g_free (pointer);
}
return newRV_noinc ((SV *) hv);
}
void PerlSortCondition::initialize(Erref &errors, TableType *tabtype, SortedIndexType *indtype)
{
if (initialized_)
return; // skip the second initialization
dSP;
tabType_ = tabtype;
// save the wrapped row type in any case
if (svRowType_ != NULL)
SvREFCNT_dec(svRowType_);
WrapRowType *wrowt = new WrapRowType(const_cast<RowType *>(rt_.get()));
svRowType_ = newSV(0);
sv_setref_pv(svRowType_, "Triceps::RowType", (void *)wrowt);
Erref errInit, errComp;
if (!cbInitialize_.isNull()) {
cbInitialize_->initialize(hrt_);
errInit = cbInitialize_->getErrors();
errors.fAppend(errInit, "PerlSortedIndex(%s) initialize function is not compatible with multithreading:", name_.c_str());
}
if (!cbCompare_.isNull()) {
cbCompare_->initialize(hrt_);
errComp = cbCompare_->getErrors();
errors.fAppend(errComp, "PerlSortedIndex(%s) compare function is not compatible with multithreading:", name_.c_str());
}
if (errInit->hasError() || errComp->hasError()) {
return; // no point in going further
}
if (!cbInitialize_.isNull()) {
WrapTableType *wtabt = new WrapTableType(tabtype);
SV *svtabt = newSV(0);
sv_setref_pv(svtabt, "Triceps::TableType", (void *)wtabt);
WrapIndexType *widxt = new WrapIndexType(indtype);
SV *svidxt = newSV(0);
sv_setref_pv(svidxt, "Triceps::IndexType", (void *)widxt);
PerlCallbackStartCall(cbInitialize_);
XPUSHs(svtabt);
XPUSHs(svidxt);
XPUSHs(svRowType_);
SV *sverrmsg = NULL;
PerlCallbackDoCallScalar(cbInitialize_, sverrmsg);
// this calls the DELETE methods on wrappers
SvREFCNT_dec(svtabt);
SvREFCNT_dec(svidxt);
if (sverrmsg != NULL && SvTRUE(sverrmsg)) {
errors->appendMultiline(true, SvPV_nolen(sverrmsg));
return;
}
if (SvTRUE(ERRSV)) {
errors->appendMultiline(true, SvPV_nolen(ERRSV));
return;
}
}
// the comparator must be set by now, or it's an error
if (cbCompare_.isNull()) {
errors->appendMsg(true, "the mandatory comparator Perl function is not set by PerlSortedIndex(" + name_ + ")");
}
hrt_ = NULL; // its work is done
initialized_ = true;
}
SV*
TriangleMesh::to_SV() {
SV* sv = newSV(0);
sv_setref_pv( sv, "Slic3r::TriangleMesh", (void*)this );
return sv;
}
SV*
Line::to_SV_ref() {
SV* sv = newSV(0);
sv_setref_pv( sv, "Slic3r::Line::Ref", this );
return sv;
}
SV*
Point::to_SV_clone_ref() const {
SV* sv = newSV(0);
sv_setref_pv( sv, perl_class_name(this), new Point(*this) );
return sv;
}
SV*
Line::to_SV_clone_ref() const {
SV* sv = newSV(0);
sv_setref_pv( sv, "Slic3r::Line", new Line(*this) );
return sv;
}
