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);
}
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;
}
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();
}
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;
}
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;
}
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;
}
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;
}
/* 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;
}
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;
}
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;
}
/*
* 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;
}
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;
}
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;
}
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;
}
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;
}
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;
}
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;
}
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);
}
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);
}
