Пример #1
0
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;
}
Пример #2
0
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;
}
Пример #3
0
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;
}
Пример #4
0
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;
}
Пример #5
0
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);
	}

}
Пример #6
0
/* 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;
}
Пример #7
0
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);
    }
}
Пример #8
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);
}
Пример #9
0
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");
}
Пример #10
0
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;
}
Пример #11
0
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();
}
Пример #12
0
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
}
Пример #13
0
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;
}
Пример #14
0
SV*
ExPolygon::to_SV_clone_ref() const {
    SV* sv = newSV(0);
    sv_setref_pv( sv, "Slic3r::ExPolygon", new ExPolygon(*this) );
    return sv;
}
Пример #15
0
SV*
ExPolygon::to_SV_ref() {
    SV* sv = newSV(0);
    sv_setref_pv( sv, "Slic3r::ExPolygon::Ref", this );
    return sv;
}
Пример #16
0
SV*
Polygon::to_SV_ref() {
    SV* sv = newSV(0);
    sv_setref_pv( sv, "Slic3r::Polygon::Ref", (void*)this );
    return sv;
}
Пример #17
0
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;
}
Пример #18
0
SV*
Point::to_SV_ref() {
    SV* sv = newSV(0);
    sv_setref_pv( sv, perl_class_name_ref(this), (void*)this );
    return sv;
}
Пример #19
0
SV*
c2p_pkg(void *p)
{
	SV *rv = newSV(0);
	return sv_setref_pv(rv, "ALPM::Package", p);
}
Пример #20
0
SV*
Point::to_SV_clone_ref() const {
    SV* sv = newSV(0);
    sv_setref_pv( sv, "Slic3r::Point", new Point(*this) );
    return sv;
}
Пример #21
0
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;
}
Пример #22
0
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;
}
Пример #23
0
/*
 * 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;
}
Пример #24
0
SV*
Line::to_SV_ref() {
    SV* sv = newSV(0);
    sv_setref_pv( sv, perl_class_name_ref(this), this );
    return sv;
}
Пример #25
0
/* 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);
}
Пример #26
0
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;
}
Пример #27
0
SV*
TriangleMesh::to_SV() {
    SV* sv = newSV(0);
    sv_setref_pv( sv, "Slic3r::TriangleMesh", (void*)this );
    return sv;
}
Пример #28
0
SV*
Line::to_SV_ref() {
    SV* sv = newSV(0);
    sv_setref_pv( sv, "Slic3r::Line::Ref", this );
    return sv;
}
Пример #29
0
SV*
Point::to_SV_clone_ref() const {
    SV* sv = newSV(0);
    sv_setref_pv( sv, perl_class_name(this), new Point(*this) );
    return sv;
}
Пример #30
0
SV*
Line::to_SV_clone_ref() const {
    SV* sv = newSV(0);
    sv_setref_pv( sv, "Slic3r::Line", new Line(*this) );
    return sv;
}