Пример #1
0
char *	perlcall (char* sub, char* in, char* out, long item, char* input) 
{
	char *retval=NULL;
	int count, foo;
	an_array *array;

	dSP ;
	if (!isperlrunning)
		RETURN_MSTR(retval);

	++perlcalldepth;
	ENTER; 
	SAVETMPS;
	PUSHMARK(SP);
	if (input && *input) 
		XPUSHs(sv_2mortal(newSVpv(input, 0)));
	if (in && *in && (array=get_array(in))) {
		for (foo=0; foo<array->size; foo++) {
			XPUSHs(sv_2mortal(newSVpv(array->item[foo], 0)));
		}
	}
	PUTBACK ;
	if (out && *out) {
		long size;
		upper(out);
		size=(array=get_array(out))?array->size:0;
		if (0>item) 
			item=size-~item;
		if (item>size) 
			item=-1;
	} else {
		item=-1;
	}
	if (0<=item) {
		I32 ax;
		count = perl_call_pv(sub, G_EVAL|G_ARRAY);
		SPAGAIN ;
		SP -= count ;
		ax = (SP - PL_stack_base) + 1 ;
		for (foo=0; foo<count; foo++) {
			set_item(out, item+foo, (char*)SvPV_nolen(ST(foo)), 1);
		}
		retval=(void*)new_realloc((void**)(&retval),32);
		snprintf(retval,31,"%u",count);
	} else {
		SV *sv;
		count = perl_call_pv(sub, G_EVAL|G_SCALAR);
		SPAGAIN ; sv=POPs ;
		SV2STR(sv,retval);
	}
	PUTBACK ;
	FREETMPS; LEAVE;
	--perlcalldepth;
	RETURN_MSTR(retval);
}
Пример #2
0
static int perl_source_event(PERL_SOURCE_REC *rec)
{
	dSP;
	int retcount;

	ENTER;
	SAVETMPS;

	PUSHMARK(SP);
	XPUSHs(sv_2mortal(new_pv(rec->data)));
	PUTBACK;

	retcount = perl_call_pv(rec->func, G_EVAL|G_DISCARD);
	SPAGAIN;

	if (SvTRUE(ERRSV)) {
		STRLEN n_a;

		signal_emit("perl error", 1, SvPV(ERRSV, n_a));
	}

	PUTBACK;
	FREETMPS;
	LEAVE;

	return 1;
}
Пример #3
0
static int perl_timeout(PERL_TIMEOUT_REC *rec)
{
	dSP;
	int retcount;

	ENTER;
	SAVETMPS;

	PUSHMARK(SP);
	XPUSHs(sv_2mortal(newSVpv(rec->data, strlen(rec->data))));
	PUTBACK;

	retcount = perl_call_pv(rec->func, G_EVAL|G_SCALAR);
	SPAGAIN;

	if (SvTRUE(ERRSV)) {
		STRLEN n_a;

		signal_emit("perl error", 1, SvPV(ERRSV, n_a));
		(void) POPs;
	}
	else while (retcount--) (void) POPi;

	PUTBACK;
	FREETMPS;
	LEAVE;

	return 1;
}
Conversa::Conversa (string nomeArquivo, PerlInterpreter *my_perl) : arquivo(nomeArquivo) {

	dSP;																	// Inicializa o ponteiro da pilha
	ENTER;																	// Tudo criado à partir daqui...
	SAVETMPS;																// ...são variáveis temporárias
	PUSHMARK(SP);															// Lembra o ponteiro para a pilha
	XPUSHs(sv_2mortal(newSVpv(nomeArquivo.c_str(), nomeArquivo.length())));	// Coloca o nomeArquivo na pilha
	PUTBACK;																// Transforma o ponteiro local para a pilha em global
	int numberElemntsOfStack = perl_call_pv("analisaConversa", G_ARRAY);	// Chama a função em Perl
	SPAGAIN;																// Atualiza o ponteiro para a pilha

	interlocutor[0] = POPp;
	interlocutor[1] = POPp;
	
	for (int index = 0; ((index < 2) && (numberElemntsOfStack > 0)); ++index) {

		qtdVezesIniciouConversa[index] = POPi;
		qtdMsg[index] = POPi;
		qtdPalavras[index] = POPi;
		qtdEmoticonsTexto[index] = POPi;
		qtdEmoticonsEmoji[index] = POPi;
		qtdBlocosMsg[index] = POPi;
	}

	PUTBACK;
	FREETMPS;		// Libera os valores de retorno da memória...
	LEAVE;			// ...e os argumentos "mortal XPUSHed"

	defineGenero();
}
Пример #5
0
static void cmd_run(char *data)
{
	dSP;
	struct stat statbuf;
	char *fname;
	int retcount;

	/* add .pl suffix if it's missing */
	data = (strlen(data) <= 3 || strcmp(data+strlen(data)-3, ".pl") == 0) ?
		g_strdup(data) : g_strdup_printf("%s.pl", data);

	if (g_path_is_absolute(data)) {
		/* whole path specified */
		fname = g_strdup(data);
	} else {
		/* check from ~/.irssi/scripts/ */
		fname = g_strdup_printf("%s/.irssi/scripts/%s", g_get_home_dir(), data);
		if (stat(fname, &statbuf) != 0) {
			/* check from SCRIPTDIR */
			g_free(fname),
			fname = g_strdup_printf(SCRIPTDIR"/%s", data);
		}
	}
	g_free(data);

	ENTER;
	SAVETMPS;

	PUSHMARK(SP);
	XPUSHs(sv_2mortal(newSVpv(fname, strlen(fname)))); g_free(fname);
	PUTBACK;

	retcount = perl_call_pv("load_file", G_EVAL|G_SCALAR);
	SPAGAIN;

	if (SvTRUE(ERRSV)) {
		STRLEN n_a;

		signal_emit("gui dialog", 2, "error", SvPV(ERRSV, n_a));
		(void) POPs;
	}
	else if (retcount > 0) {
		char *str = POPp;

		if (str != NULL && *str != '\0')
			signal_emit("gui dialog", 2, "error", str);
	}

	PUTBACK;
	FREETMPS;
	LEAVE;
}
Пример #6
0
static gboolean
load_perl_plugin(PurplePlugin *plugin)
{
	PurplePerlScript *gps = (PurplePerlScript *)plugin->info->extra_info;
	char *atmp[3] = { plugin->path, NULL, NULL };

	if (gps == NULL || gps->load_sub == NULL)
		return FALSE;

	purple_debug(PURPLE_DEBUG_INFO, "perl", "Loading perl script\n");

	if (my_perl == NULL)
		perl_init();

	plugin->handle = gps;

	atmp[1] = gps->package;

	PERL_SET_CONTEXT(my_perl);
	execute_perl("Purple::PerlLoader::load_n_eval", 2, atmp);

	{
		dSP;
		PERL_SET_CONTEXT(my_perl);
		SPAGAIN;
		ENTER;
		SAVETMPS;
		PUSHMARK(sp);
		XPUSHs(sv_2mortal(purple_perl_bless_object(plugin,
		                                         "Purple::Plugin")));
		PUTBACK;

		perl_call_pv(gps->load_sub, G_EVAL | G_SCALAR);
		SPAGAIN;

		if (SvTRUE(ERRSV)) {
			STRLEN len;

			purple_debug(PURPLE_DEBUG_ERROR, "perl",
			           "Perl function %s exited abnormally: %s\n",
			           gps->load_sub, SvPV(ERRSV, len));
		}

		PUTBACK;
		FREETMPS;
		LEAVE;
	}

	return TRUE;
}
Пример #7
0
static void perl_script_destroy_package(PERL_SCRIPT_REC *script)
{
	dSP;

	ENTER;
	SAVETMPS;

	PUSHMARK(SP);
	XPUSHs(sv_2mortal(new_pv(script->package)));
	PUTBACK;

	perl_call_pv("Irssi::Core::destroy", G_VOID|G_EVAL|G_DISCARD);

	FREETMPS;
	LEAVE;
}
Пример #8
0
static gboolean
unload_perl_plugin(PurplePlugin *plugin)
{
	PurplePerlScript *gps = (PurplePerlScript *)plugin->info->extra_info;

	if (gps == NULL)
		return FALSE;

	purple_debug(PURPLE_DEBUG_INFO, "perl", "Unloading perl script\n");

	if (gps->unload_sub != NULL) {
		dSP;
		PERL_SET_CONTEXT(my_perl);
		SPAGAIN;
		ENTER;
		SAVETMPS;
		PUSHMARK(sp);
		XPUSHs(sv_2mortal(purple_perl_bless_object(plugin,
		                                         "Purple::Plugin")));
		PUTBACK;

		perl_call_pv(gps->unload_sub, G_EVAL | G_SCALAR);
		SPAGAIN;

		if (SvTRUE(ERRSV)) {
			STRLEN len;

			purple_debug(PURPLE_DEBUG_ERROR, "perl",
			           "Perl function %s exited abnormally: %s\n",
			           gps->load_sub, SvPV(ERRSV, len));
		}

		PUTBACK;
		FREETMPS;
		LEAVE;
	}

	purple_perl_cmd_clear_for_plugin(plugin);
	purple_perl_signal_clear_for_plugin(plugin);
	purple_perl_timeout_clear_for_plugin(plugin);

	destroy_package(gps->package);

	return TRUE;
}
Пример #9
0
/* do verbose error reporting on Perl side */
void 
_perl_report_err( const char *msg ) 
{
    int n;
    dSP;
    ENTER; SAVETMPS;
    PUSHMARK(sp);
    printf("_perl_report_err: %s\n", msg);
/*    printf("                  SvREFCNT = %d\n", SvREFCNT(userData.handler));*/

    XPUSHs( sv_2mortal( newSVpv( msg, 0 ) ) );

    PUTBACK;
    n = perl_call_pv("XML::Sablotron::__Version::_report_err", G_DISCARD);
    SPAGAIN;
    PUTBACK;
    FREETMPS; LEAVE;
}
Пример #10
0
uschar *
call_perl_cat(uschar *yield, int *sizep, int *ptrp, uschar **errstrp,
              uschar *name, uschar **arg)
{
    dSP;
    SV *sv;
    STRLEN len;
    uschar *str;
    int items;

    if (!interp_perl)
    {
        *errstrp = US"the Perl interpreter has not been started";
        return 0;
    }

    ENTER;
    SAVETMPS;
    PUSHMARK(SP);
    while (*arg != NULL) XPUSHs(newSVpv(CS (*arg++), 0));
    PUTBACK;
    items = perl_call_pv(CS name, G_SCALAR|G_EVAL);
    SPAGAIN;
    sv = POPs;
    PUTBACK;
    if (SvTRUE(ERRSV))
    {
        *errstrp = US SvPV(ERRSV, len);
        return NULL;
    }
    if (!SvOK(sv))
    {
        *errstrp = 0;
        return NULL;
    }
    str = US SvPV(sv, len);
    yield = string_cat(yield, sizep, ptrp, str, (int)len);
    FREETMPS;
    LEAVE;

    setlocale(LC_ALL, "C");    /* In case it got changed */
    return yield;
}
Пример #11
0
static int perl_script_eval(PERL_SCRIPT_REC *script)
{
	dSP;
	char *error;
	int retcount;
	SV *ret;

	ENTER;
	SAVETMPS;

	PUSHMARK(SP);
	XPUSHs(sv_2mortal(new_pv(script->path != NULL ? script->path :
				 script->data)));
	XPUSHs(sv_2mortal(new_pv(script->name)));
	PUTBACK;

	retcount = perl_call_pv(script->path != NULL ?
				"Irssi::Core::eval_file" :
				"Irssi::Core::eval_data",
				G_EVAL|G_SCALAR);
	SPAGAIN;

        error = NULL;
	if (SvTRUE(ERRSV)) {
		error = SvPV(ERRSV, PL_na);

		if (error != NULL) {
			error = g_strdup(error);
			signal_emit("script error", 2, script, error);
			g_free(error);
		}
	} else if (retcount > 0) {
		ret = POPs;
	}

	PUTBACK;
	FREETMPS;
	LEAVE;

        return error == NULL;
}
Пример #12
0
/*
 *  Here be magic...
 *  man perlcall gave me the following steps, to be
 *  able to handle getting return values from the
 *  embedded perl calls.
 */
static char*pl_perl_eval(const char *functionname) {
	int retcount = 0;
	char *retstr = NULL;

	dSP;                            /* initialize stack pointer      */

	ices_log_debug("Interpreting [%s]", functionname);

	ENTER;                          /* everything created after here */
	SAVETMPS;                       /* ...is a temporary variable.   */
	PUSHMARK(SP);                   /* remember the stack pointer    */
	PUTBACK;                        /* make local stack pointer global */

	/* G_SCALAR: get a scalar return | G_EVAL: Trap errors */
	retcount = perl_call_pv(functionname, G_SCALAR | G_EVAL);

	SPAGAIN;                        /* refresh stack pointer         */

	/* Check for errors in execution */
	if (SvTRUE(ERRSV)) {
		STRLEN n_a;
		ices_log_debug("perl error: %s", SvPV(ERRSV, n_a));
		(void) POPs;
	} else if (retcount) {
		/* we're calling strdup here, free() this later! */
		retstr = ices_util_strdup(POPp); /* pop the return value from stack */
		ices_log_debug("perl [%s] returned %d values, last [%s]", functionname, retcount, retstr);
	} else
		ices_log_debug("Perl call returned nothing");

	PUTBACK;
	FREETMPS;                       /* free that return value        */
	LEAVE;                          /* ...and the XPUSHed "mortal" args.*/

	ices_log_debug("Done interpreting [%s]", functionname);

	return retstr;
}
Пример #13
0
static void
destroy_package(const char *package)
{
	dSP;
	PERL_SET_CONTEXT(my_perl);
	SPAGAIN;

	ENTER;
	SAVETMPS;

	PUSHMARK(SP);
	XPUSHs(sv_2mortal(newSVpv(package, strlen(package))));
	PUTBACK;

	perl_call_pv("Purple::PerlLoader::destroy_package",
	             G_VOID | G_EVAL | G_DISCARD);

	SPAGAIN;

	PUTBACK;
	FREETMPS;
	LEAVE;
}
Пример #14
0
static int perl_script_eval(PERL_SCRIPT_REC *script)
{
	dSP;
	char *error;

	ENTER;
	SAVETMPS;

	PUSHMARK(SP);
	XPUSHs(sv_2mortal(new_pv(script->path != NULL ? script->path :
				 script->data)));
	XPUSHs(sv_2mortal(new_pv(script->name)));
	PUTBACK;

	perl_call_pv(script->path != NULL ?
                              "Irssi::Core::eval_file" :
                              "Irssi::Core::eval_data",
                              G_EVAL|G_DISCARD);
	SPAGAIN;

        error = NULL;
	if (SvTRUE(ERRSV)) {
		error = SvPV_nolen(ERRSV);

		if (error != NULL) {
			error = g_strdup(error);
			signal_emit("script error", 2, script, error);
			g_free(error);
		}
	}

	FREETMPS;
	LEAVE;

        return error == NULL;
}
Пример #15
0
static SV  *
plperl_create_sub(char *s, bool trusted)
{
	dSP;
	SV		   *subref;
	int			count;
	char	   *compile_sub;

	if (trusted && !plperl_safe_init_done)
	{
		plperl_safe_init();
		SPAGAIN;
	}

	ENTER;
	SAVETMPS;
	PUSHMARK(SP);
	XPUSHs(sv_2mortal(newSVpv("my $_TD=$_[0]; shift;", 0)));
	XPUSHs(sv_2mortal(newSVpv(s, 0)));
	PUTBACK;

	/*
	 * G_KEEPERR seems to be needed here, else we don't recognize compile
	 * errors properly.  Perhaps it's because there's another level of eval
	 * inside mksafefunc?
	 */

	if (trusted && plperl_use_strict)
		compile_sub = "::mk_strict_safefunc";
	else if (plperl_use_strict)
		compile_sub = "::mk_strict_unsafefunc";
	else if (trusted)
		compile_sub = "::mksafefunc";
	else
		compile_sub = "::mkunsafefunc";

	count = perl_call_pv(compile_sub, G_SCALAR | G_EVAL | G_KEEPERR);
	SPAGAIN;

	if (count != 1)
	{
		PUTBACK;
		FREETMPS;
		LEAVE;
		elog(ERROR, "didn't get a return item from mksafefunc");
	}

	if (SvTRUE(ERRSV))
	{
		(void) POPs;
		PUTBACK;
		FREETMPS;
		LEAVE;
		ereport(ERROR,
				(errcode(ERRCODE_SYNTAX_ERROR),
				 errmsg("creation of Perl function failed: %s",
						strip_trailing_ws(SvPV(ERRSV, PL_na)))));
	}

	/*
	 * need to make a deep copy of the return. it comes off the stack as a
	 * temporary.
	 */
	subref = newSVsv(POPs);

	if (!SvROK(subref) || SvTYPE(SvRV(subref)) != SVt_PVCV)
	{
		PUTBACK;
		FREETMPS;
		LEAVE;

		/*
		 * subref is our responsibility because it is not mortal
		 */
		SvREFCNT_dec(subref);
		elog(ERROR, "didn't get a code ref");
	}

	PUTBACK;
	FREETMPS;
	LEAVE;

	return subref;
}
Пример #16
0
static int call_perl(const char *func, int signal, va_list va)
{
	dSP;
	PERL_SIGNAL_ARGS_REC *rec;
	int retcount, n, ret;
	void *arg;
	HV *stash;

    /* first check if we find exact match */
    rec = NULL;
    for (n = 0; perl_signal_args[n].signal != NULL; n++)
    {
	if (signal == perl_signal_args[n].signal_id)
	{
	    rec = &perl_signal_args[n];
	    break;
	}
    }

    if (rec == NULL)
    {
	/* try to find by name */
	const char *signame;

	signame = module_find_id_str("signals", signal);
	for (n = 0; perl_signal_args[n].signal != NULL; n++)
	{
	    if (strncmp(signame, perl_signal_args[n].signal,
			strlen(perl_signal_args[n].signal)) == 0)
	    {
		rec = &perl_signal_args[n];
		break;
	    }
	}
    }

    ENTER;
    SAVETMPS;

    PUSHMARK(sp);

    if (rec != NULL)
    {
	/* put the arguments to perl stack */
	for (n = 0; n < 7; n++)
	{
	    arg = va_arg(va, gpointer);

            if (rec->args[n] == NULL)
                break;

	    if (strcmp(rec->args[n], "string") == 0)
		XPUSHs(sv_2mortal(newSVpv(arg == NULL ? "" : arg, arg == NULL ? 0 : strlen(arg))));
	    else if (strcmp(rec->args[n], "int") == 0)
		XPUSHs(sv_2mortal(newSViv(GPOINTER_TO_INT(arg))));
	    else if (strcmp(rec->args[n], "ulongptr") == 0)
		XPUSHs(sv_2mortal(newSViv(*(gulong *) arg)));
	    else if (strncmp(rec->args[n], "glist_", 6) == 0)
	    {
		GSList *tmp;

		stash = gv_stashpv(rec->args[n]+6, 0);
		for (tmp = arg; tmp != NULL; tmp = tmp->next)
		    XPUSHs(sv_2mortal(sv_bless(newRV_noinc(newSViv(GPOINTER_TO_INT(tmp->data))), stash)));
	    }
	    else
	    {
                if (arg == NULL)
			XPUSHs(sv_2mortal(newSViv(0)));
		else {
			stash = gv_stashpv(rec->args[n], 0);
			XPUSHs(sv_2mortal(sv_bless(newRV_noinc(newSViv(GPOINTER_TO_INT(arg))), stash)));
		}
	    }
	}
    }

    PUTBACK;
    retcount = perl_call_pv((char *) func, G_EVAL|G_SCALAR);
    SPAGAIN;

    ret = 0;
    if (SvTRUE(ERRSV))
    {
	STRLEN n_a;

	signal_emit("gui dialog", 2, "error", SvPV(ERRSV, n_a));
        (void)POPs;
    }
    else
    {
	SV *sv;

	if (retcount > 0)
	{
	    sv = POPs;
            if (SvIOK(sv) && SvIV(sv) == 1) ret = 1;
	}
	for (n = 2; n <= retcount; n++)
	    (void)POPi;
    }

    PUTBACK;
    FREETMPS;
    LEAVE;

    return ret;
}
Пример #17
0
int   perl_trapd_handler( netsnmp_pdu           *pdu,
                          netsnmp_transport     *transport,
                          netsnmp_trapd_handler *handler)
{
    trapd_cb_data *cb_data;
    SV *pcallback;
    netsnmp_variable_list *vb;
    netsnmp_oid *o;
    SV *arg;
    SV *rarg;
    SV **tmparray;
    int i, c = 0;
    u_char *outbuf;
    size_t ob_len = 0, oo_len = 0;
    AV *varbinds;
    HV *pduinfo;

    dSP;
    ENTER;
    SAVETMPS;

    if (!pdu || !handler)
        return 0;

    /* nuke v1 PDUs */
    if (pdu->command == SNMP_MSG_TRAP)
        pdu = convert_v1pdu_to_v2(pdu);

    cb_data = handler->handler_data;
    if (!cb_data || !cb_data->perl_cb)
        return 0;

    pcallback = cb_data->perl_cb;

    /* get PDU related info */
    pduinfo = newHV();
#define STOREPDU(n, v) hv_store(pduinfo, n, strlen(n), v, 0)
#define STOREPDUi(n, v) STOREPDU(n, newSViv(v))
#define STOREPDUs(n, v) STOREPDU(n, newSVpv(v, 0))
    STOREPDUi("version", pdu->version);
    STOREPDUs("notificationtype", ((pdu->command == SNMP_MSG_INFORM) ? "INFORM":"TRAP"));
    STOREPDUi("requestid", pdu->reqid);
    STOREPDUi("messageid", pdu->msgid);
    STOREPDUi("transactionid", pdu->transid);
    STOREPDUi("errorstatus", pdu->errstat);
    STOREPDUi("errorindex", pdu->errindex);
    if (pdu->version == 3) {
        STOREPDUi("securitymodel", pdu->securityModel);
        STOREPDUi("securitylevel", pdu->securityLevel);
        STOREPDU("contextName",
                 newSVpv(pdu->contextName, pdu->contextNameLen));
        STOREPDU("contextEngineID",
                 newSVpv(pdu->contextEngineID,
                                    pdu->contextEngineIDLen));
        STOREPDU("securityEngineID",
                 newSVpv(pdu->securityEngineID,
                                    pdu->securityEngineIDLen));
        STOREPDU("securityName",
                 newSVpv(pdu->securityName, pdu->securityNameLen));
    } else {
        STOREPDU("community",
                 newSVpv(pdu->community, pdu->community_len));
    }

    if (transport && transport->f_fmtaddr) {
        char *tstr = transport->f_fmtaddr(transport, pdu->transport_data,
                                          pdu->transport_data_length);
        STOREPDUs("receivedfrom", tstr);
        free(tstr);
    }


    /*
     * collect OID objects in a temp array first
     */
    /* get VARBIND related info */
    i = count_varbinds(pdu->variables);
    tmparray = malloc(sizeof(*tmparray) * i);

    for(vb = pdu->variables; vb; vb = vb->next_variable) {

        /* get the oid */
        o = SNMP_MALLOC_TYPEDEF(netsnmp_oid);
        o->name = o->namebuf;
        o->len = vb->name_length;
        memcpy(o->name, vb->name, vb->name_length * sizeof(oid));

#undef CALL_EXTERNAL_OID_NEW

#ifdef CALL_EXTERNAL_OID_NEW
        PUSHMARK(sp);

        rarg = sv_2mortal(newSViv((IV) 0));
        arg = sv_2mortal(newSVrv(rarg, "netsnmp_oidPtr"));
        sv_setiv(arg, (IV) o);
        XPUSHs(rarg);

        PUTBACK;
        i = perl_call_pv("NetSNMP::OID::newwithptr", G_SCALAR);
        SPAGAIN;

        if (i != 1) {
            snmp_log(LOG_ERR, "unhandled OID error.\n");
            /* ack XXX */
        }
        /* get the value */
        tmparray[c++] = POPs;
        SvREFCNT_inc(tmparray[c-1]);
        PUTBACK;
#else /* build it and bless ourselves */
        {
            HV *hv = newHV();
            SV *rv = newRV_noinc((SV *) hv);
            SV *rvsub = newRV_noinc((SV *) newSViv((UV) o));
            SV *sv;
            rvsub = sv_bless(rvsub, gv_stashpv("netsnmp_oidPtr", 1));
            hv_store(hv, "oidptr", 6,  rvsub, 0);
            rv = sv_bless(rv, gv_stashpv("NetSNMP::OID", 1));
            tmparray[c++] = rv;
        }
        
#endif /* build oid ourselves */
    }

    /*
     * build the varbind lists
     */
    varbinds = newAV();
    for(vb = pdu->variables, i = 0; vb; vb = vb->next_variable, i++) {
        /* push the oid */
        AV *vba;
        vba = newAV();


        /* get the value */
        outbuf = NULL;
        ob_len = 0;
        oo_len = 0;
	sprint_realloc_by_type(&outbuf, &ob_len, &oo_len, 1,
                               vb, 0, 0, 0);

        av_push(vba,tmparray[i]);
        av_push(vba,newSVpvn(outbuf, oo_len));
        free(outbuf);
        av_push(vba,newSViv(vb->type));
        av_push(varbinds, (SV *) newRV_noinc((SV *) vba));
    }

    PUSHMARK(sp);

    /* store the collected information on the stack */
    XPUSHs(sv_2mortal(newRV_noinc((SV*) pduinfo)));
    XPUSHs(sv_2mortal(newRV_noinc((SV*) varbinds)));

    /* put the stack back in order */
    PUTBACK;

    /* actually call the callback function */
    if (SvTYPE(pcallback) == SVt_PVCV) {
        perl_call_sv(pcallback, G_DISCARD);
        /* XXX: it discards the results, which isn't right */
    } else if (SvROK(pcallback) && SvTYPE(SvRV(pcallback)) == SVt_PVCV) {
        /* reference to code */
        perl_call_sv(SvRV(pcallback), G_DISCARD);
    } else {
        snmp_log(LOG_ERR, " tried to call a perl function but failed to understand its type: (ref = %x, svrok: %lu, SVTYPE: %lu)\n", (uintptr_t)pcallback, SvROK(pcallback), SvTYPE(pcallback));
    }

#ifdef DUMPIT
    fprintf(stderr, "DUMPDUMPDUMPDUMPDUMPDUMP\n");
    sv_dump(pduinfo);
    fprintf(stderr, "--------------------\n");
    sv_dump(varbinds);
#endif
    
    /* svREFCNT_dec((SV *) pduinfo); */
#ifdef NOT_THIS
    {
        SV *vba;
        while(vba = av_pop(varbinds)) {
            av_undef((AV *) vba);
        }
    }
    av_undef(varbinds);
#endif    
    free(tmparray);

    /* Not needed because of the G_DISCARD flag (I think) */
    /* SPAGAIN; */
    /* PUTBACK; */
#ifndef __x86_64__
    FREETMPS; /* FIXME: known to cause a segfault on x86-64 */
#endif
    LEAVE;
    return NETSNMPTRAPD_HANDLER_OK;
}
Пример #18
0
int run_epn(char *command_line) {
    SV *plugin_hndlr_cr;
    STRLEN n_a;
    int count = 0 ;
    char fname[MAX_INPUT_CHARS];
    char *args[] = {"", "0", "", "", NULL };
    int pclose_result;
    char *plugin_output ;


    dSP;

    command_line[strlen(command_line) - 1] = '\0';

    strncpy(fname, command_line, strcspn(command_line, " "));
    fname[strcspn(command_line, " ")] = '\x0';
    args[0] = fname ;
    args[3] = command_line + strlen(fname) + 1 ;

    args[2] = "";

    /* call our perl interpreter to compile and optionally cache the command */

    ENTER;
    SAVETMPS;
    PUSHMARK(SP);

    XPUSHs(sv_2mortal(newSVpv(args[0], 0)));
    XPUSHs(sv_2mortal(newSVpv(args[1], 0)));
    XPUSHs(sv_2mortal(newSVpv(args[2], 0)));
    XPUSHs(sv_2mortal(newSVpv(args[3], 0)));

    PUTBACK;

    count = call_pv("Embed::Persistent::eval_file", G_SCALAR | G_EVAL);

    SPAGAIN;

    /* check return status  */
    if(SvTRUE(ERRSV)) {
        (void) POPs;

        pclose_result = -2;
        printf("embedded perl ran %s with error %s\n", fname, SvPVX(ERRSV));
        return 1;
        }
    else {
        plugin_hndlr_cr = newSVsv(POPs);

        PUTBACK;
        FREETMPS;
        LEAVE;
        }

    ENTER;
    SAVETMPS;
    PUSHMARK(SP);

    XPUSHs(sv_2mortal(newSVpv(args[0], 0)));
    XPUSHs(sv_2mortal(newSVpv(args[1], 0)));
    XPUSHs(plugin_hndlr_cr);
    XPUSHs(sv_2mortal(newSVpv(args[3], 0)));

    PUTBACK;

    count = perl_call_pv("Embed::Persistent::run_package", G_EVAL | G_ARRAY);

    SPAGAIN;

    plugin_output = POPpx ;
    pclose_result = POPi ;

    printf("plugin return code: %d\n", pclose_result);
    printf("perl plugin output: '%s'\n", plugin_output);

    PUTBACK;
    FREETMPS;
    LEAVE;

    alarm(0);
    return 0;
}
Пример #19
0
static void cmd_run(const char *data)
{
	dSP;
	struct stat statbuf;
	char *fname, *name, *p;
	int retcount;

	if (g_path_is_absolute(data)) {
		/* whole path specified */
		fname = g_strdup(data);
	} else {
		/* add .pl suffix if it's missing */
		name = (strlen(data) > 3 && strcmp(data+strlen(data)-3, ".pl") == 0) ?
			g_strdup(data) : g_strdup_printf("%s.pl", data);

		/* check from ~/.irssi/scripts/ */
		fname = g_strdup_printf("%s/.irssi/scripts/%s", g_get_home_dir(), name);
		if (stat(fname, &statbuf) != 0) {
			/* check from SCRIPTDIR */
			g_free(fname),
			fname = g_strdup_printf(SCRIPTDIR"/%s", name);
		}
		g_free(name);
	}

	/* get script name */
	name = g_strdup(g_basename(fname));
	p = strrchr(name, '.');
	if (p != NULL) *p = '\0';

	script_fix_name(name);
	perl_script_destroy(name);

	ENTER;
	SAVETMPS;

	PUSHMARK(SP);
	XPUSHs(sv_2mortal(new_pv(fname))); g_free(fname);
	XPUSHs(sv_2mortal(new_pv(name)));
	PUTBACK;

	retcount = perl_call_pv("Irssi::Load::eval_file",
				G_EVAL|G_SCALAR);
	SPAGAIN;

	if (SvTRUE(ERRSV)) {
		STRLEN n_a;

		signal_emit("gui dialog", 2, "error", SvPV(ERRSV, n_a));
	}
	else if (retcount > 0) {
		char *str = POPp;

		if (str != NULL && *str != '\0')
			signal_emit("gui dialog", 2, "error", str);
	}

	PUTBACK;
	FREETMPS;
	LEAVE;

	perl_scripts = g_slist_append(perl_scripts, g_strdup(name));
	signal_emit("script new", 2, "PERL", name);
        g_free(name);
}
Пример #20
0
int main(int argc, char **argv, char **env) {

	/*
	#ifdef aTHX
		dTHX;
	#endif
	*/

	char *embedding[] = { "", "p1.pl" };
	char *plugin_output ;
	char fname[MAX_INPUT_CHARS];
	char *args[] = {"", "0", "", "", NULL };
	char command_line[MAX_INPUT_CHARS];
	int exitstatus;
	int pclose_result;

	if((my_perl = perl_alloc()) == NULL) {
		printf("%s\n", "Error: Could not allocate memory for embedded Perl interpreter!");
		exit(1);
		}
	perl_construct(my_perl);
	exitstatus = perl_parse(my_perl, xs_init, 2, embedding, NULL);
	if(!exitstatus) {

		exitstatus = perl_run(my_perl);

		while(printf("Enter file name: ") && fgets(command_line, MAX_INPUT_CHARS - 1, stdin)) {
			SV *plugin_hndlr_cr;
			STRLEN n_a;
			int count = 0 ;

			dSP;

			command_line[strlen(command_line) -1] = '\0';

			strncpy(fname, command_line, strcspn(command_line, " "));
			fname[strcspn(command_line, " ")] = '\x0';
			args[0] = fname ;
			args[3] = command_line + strlen(fname) + 1 ;

			args[2] = "";

			/* call our perl interpreter to compile and optionally cache the command */

			ENTER;
			SAVETMPS;
			PUSHMARK(SP);

			XPUSHs(sv_2mortal(newSVpv(args[0], 0)));
			XPUSHs(sv_2mortal(newSVpv(args[1], 0)));
			XPUSHs(sv_2mortal(newSVpv(args[2], 0)));
			XPUSHs(sv_2mortal(newSVpv(args[3], 0)));

			PUTBACK;

			count = call_pv("Embed::Persistent::eval_file", G_SCALAR | G_EVAL);

			SPAGAIN;

			/* check return status  */
			if(SvTRUE(ERRSV)) {
				(void) POPs;

				pclose_result = -2;
				printf("embedded perl ran %s with error %s\n", fname, SvPVX(ERRSV));
				continue;
				}
			else {
				plugin_hndlr_cr = newSVsv(POPs);

				PUTBACK;
				FREETMPS;
				LEAVE;
				}

			ENTER;
			SAVETMPS;
			PUSHMARK(SP);

			XPUSHs(sv_2mortal(newSVpv(args[0], 0)));
			XPUSHs(sv_2mortal(newSVpv(args[1], 0)));
			XPUSHs(plugin_hndlr_cr);
			XPUSHs(sv_2mortal(newSVpv(args[3], 0)));

			PUTBACK;

			count = perl_call_pv("Embed::Persistent::run_package", G_EVAL | G_ARRAY);

			SPAGAIN;

			plugin_output = POPpx ;
			pclose_result = POPi ;

			printf("embedded perl plugin return code and output was: %d & '%s'\n", pclose_result, plugin_output);

			PUTBACK;
			FREETMPS;
			LEAVE;

			}

		}


	PL_perl_destruct_level = 0;
	perl_destruct(my_perl);
	perl_free(my_perl);
	exit(exitstatus);
	}