static void
gplp_func_load_stub (GOPluginService *service, GnmFunc *func)
{
char const *name = gnm_func_get_name (func, FALSE);
char *args[] = { NULL };
gchar *help_perl_func = g_strconcat ("help_", name, NULL);
gchar *desc_perl_func = g_strconcat ("desc_", name, NULL);
GnmFuncHelp *help = NULL;
gchar *arg_spec = NULL;
int count;
dSP;
ENTER;
SAVETMPS;
PUSHMARK(SP);
PUTBACK;
count = call_argv (help_perl_func, G_EVAL | G_ARRAY | G_NOARGS, args);
SPAGAIN;
if (SvTRUE(ERRSV)) { /* Error handling */
STRLEN n_a;
g_print ( _("Perl error: %s\n"), SvPV (ERRSV, n_a));
while (count-- > 0) POPs;
} else {
help = make_gnm_help(name, count, SP);
}
PUTBACK;
FREETMPS;
LEAVE;
ENTER;
SAVETMPS;
PUSHMARK(SP);
PUTBACK;
call_argv (desc_perl_func, G_EVAL | G_ARRAY | G_NOARGS, args);
SPAGAIN;
if (SvTRUE(ERRSV)) { /* Error handling */
STRLEN n_a;
g_print ( _("Perl error: %s\n"), SvPV (ERRSV, n_a));
POPs;
} else {
arg_spec = g_strdup (POPp);
gnm_perl_loader_free_later (arg_spec);
}
PUTBACK;
FREETMPS;
LEAVE;
g_free (help_perl_func);
g_free (desc_perl_func);
gnm_func_set_fixargs (func, call_perl_function_args, arg_spec);
gnm_func_set_help (func, help, -1);
gnm_func_set_impl_status (func, GNM_FUNC_IMPL_STATUS_UNIQUE_TO_GNUMERIC);
}
/**
* count executions and rest interpreter
*
*/
int app_perl_reset_interpreter(void)
{
struct timeval t1;
struct timeval t2;
char *args[] = { NULL };
if(*_ap_reset_cycles==0)
return 0;
_ap_exec_cycles++;
LM_DBG("perl interpreter exec cycle [%d/%d]\n",
_ap_exec_cycles, *_ap_reset_cycles);
if(_ap_exec_cycles<=*_ap_reset_cycles)
return 0;
if(perl_destroy_func)
call_argv(perl_destroy_func, G_DISCARD | G_NOARGS, args);
gettimeofday(&t1, NULL);
if (perl_reload()<0) {
LM_ERR("perl interpreter cannot be reset [%d/%d]\n",
_ap_exec_cycles, *_ap_reset_cycles);
return -1;
}
gettimeofday(&t2, NULL);
LM_INFO("perl interpreter has been reset [%d/%d] (%d.%06d => %d.%06d)\n",
_ap_exec_cycles, *_ap_reset_cycles,
(int)t1.tv_sec, (int)t1.tv_usec,
(int)t2.tv_sec, (int)t2.tv_usec);
_ap_exec_cycles = 0;
return 0;
}
int perl_exec_simple(char* fnc, char* args[], int flags) {
if (perl_checkfnc(fnc)) {
LM_DBG("running perl function \"%s\"", fnc);
call_argv(fnc, flags, args);
} else {
LM_ERR("unknown function '%s' called.\n", fnc);
return -1;
}
return 1;
}
static gboolean
_call_perl_function_with_no_arguments(PerlDestDriver *self, const gchar *fname)
{
PerlInterpreter *my_perl = self->perl;
char *args[] = { NULL };
dSP;
int count, r = 0;
ENTER;
SAVETMPS;
count = call_argv(fname, G_SCALAR | G_EVAL | G_NOARGS, args);
SPAGAIN;
if (SvTRUE(ERRSV))
{
msg_error("Error while calling a Perl function",
evt_tag_str("driver", self->super.super.super.id),
evt_tag_str("script", self->filename),
evt_tag_str("function", fname),
evt_tag_str("error-message", SvPV_nolen(ERRSV)),
NULL);
(void) POPs;
goto exit;
}
if (count != 1)
{
msg_error("Too many values returned by a Perl function",
evt_tag_str("driver", self->super.super.super.id),
evt_tag_str("script", self->filename),
evt_tag_str("function", fname),
evt_tag_int("returned-values", count),
evt_tag_int("expected-values", 1),
NULL);
return FALSE;
}
r = POPi;
exit:
PUTBACK;
FREETMPS;
LEAVE;
return (r != 0);
}
int perl_exec_simple(struct sip_msg* _msg, str *_fnc_s, str *_param_s)
{
char *fnc;
char* args[2] = {NULL, NULL};
int flags = G_DISCARD | G_EVAL;
int ret;
if (_param_s) {
args[0] = pkg_malloc(_param_s->len+1);
if (!args[0]) {
LM_ERR("No more pkg mem!\n");
return -1;
}
memcpy(args[0], _param_s->s, _param_s->len);
args[0][_param_s->len] = 0;
} else
flags |= G_NOARGS;
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;
if (perl_checkfnc(fnc)) {
LM_DBG("running perl function \"%s\"", fnc);
call_argv(fnc, flags, args);
ret = 0;
} else {
LM_ERR("unknown function '%s' called.\n", fnc);
ret = -1;
}
if (_param_s)
pkg_free(args[0]);
pkg_free(fnc);
return ret;
}
int main(int argc, char **argv, char **env)
{
char *args[] = { NULL };
int exitstatus, i;
AV* plargv;
PERL_SYS_INIT3(&argc,&argv,&env);
my_perl = perl_alloc();
perl_construct(my_perl);
perl_parse(my_perl, xs_init, argc, argv, NULL);
PL_exit_flags |= PERL_EXIT_DESTRUCT_END;
/*** skipping perl_run() ***/
plargv = GvAV(PL_argvgv);
for (i = 0; i <= av_len(plargv); ++i) {
SV **item = av_fetch(plargv, i, 0);
call_argv(SvPV_nolen(*item), G_SCALAR | G_NOARGS, args);
{
dSP;
SV *res = POPs;
printf("RES=%s\n", SvOK(res) ? SvPV_nolen(res) : "undef");
}
}
exitstatus = perl_destruct(my_perl);
perl_free(my_perl);
PERL_SYS_TERM();
return exitstatus;
}
/**
Executes a Perl function in ARRAY context
@param args arguments to pass to the Perl function in form of
a NULL terminated list of C strings
@param functionName name of the Perl function to call
@return a C2PERLResult_t result set structure
*/
C2PERLResult_t *ExecuteFunctionResult(char **args, const char *functionName)
{
dSP;
int i;
C2PERLResult_t *result;
if (!g_init)
{
printf ("Error: not connected to C2PERL\nPlease, do C2PERLConnect\n");
return 0;
}
result=(C2PERLResult_t*)malloc (sizeof(C2PERLResult_t));
if (!result)
{
printf ("Error asking for memory in %s\n", functionName);
return NULL;
}
// let perl remember the status of the stack (+ tmp variables) before
// we issue a call
ENTER ;
SAVETMPS ;
result->result_count=call_argv(functionName, G_ARRAY , args);
SPAGAIN ;
result->current=0;
result->results=NULL;
if (getenv("DEBUG_C2PERL")) {
printf("C2PERL: no. of results: %d\n", result->result_count);
}
if (result->result_count)
{
result->results=(char**)malloc((result->result_count)*sizeof (char*));
if (!result->results)
{
printf ("Error asking for memory in %s\n", functionName);
free (result);
return 0;
}
}
// copy results away, so that perl can correctly free the memory
for (i=0; i<result->result_count; i++) {
char* tptr;
tptr = POPp;
if((result->results[i]=malloc(strlen(tptr)+1))==NULL) {
fprintf(stderr,"Error: Could not allocate memory (result->results[])\n");
}
strcpy(result->results[i],tptr);
if (getenv("DEBUG_C2PERL")) {
printf("---C2Perl: result(%d)---\n%s\n---C2Perl: result(%d)---\n",i,result->results[i],i);
}
}
// local stack pointer to global stack pointer
PUTBACK ;
// let perl free its temporary variables
FREETMPS ;
LEAVE ;
return result;
}
isc_result_t
dlz_create(const char *dlzname, unsigned int argc, char *argv[],
void **dbdata, ...)
{
config_data_t *cd;
char *init_args[] = { NULL, NULL };
char *perlrun[] = { "", NULL, "dlz perl", NULL };
char *perl_class_name;
int r;
va_list ap;
const char *helper_name;
const char *missing_method_name;
char *call_argv_args = NULL;
#ifdef MULTIPLICITY
PerlInterpreter *my_perl;
#endif
cd = malloc(sizeof(config_data_t));
if (cd == NULL)
return (ISC_R_NOMEMORY);
memset(cd, 0, sizeof(config_data_t));
/* fill in the helper functions */
va_start(ap, dbdata);
while ((helper_name = va_arg(ap, const char *)) != NULL) {
b9_add_helper(cd, helper_name, va_arg(ap, void*));
}
va_end(ap);
if (argc < 2) {
cd->log(ISC_LOG_ERROR,
"DLZ Perl '%s': Missing script argument.",
dlzname);
return (ISC_R_FAILURE);
}
if (argc < 3) {
cd->log(ISC_LOG_ERROR,
"DLZ Perl '%s': Missing class name argument.",
dlzname);
return (ISC_R_FAILURE);
}
perl_class_name = argv[2];
cd->log(ISC_LOG_INFO, "DLZ Perl '%s': Loading '%s' from location '%s'",
dlzname, perl_class_name, argv[1], argc);
#ifndef MULTIPLICITY
if (global_perl) {
/*
* PERL_SET_CONTEXT not needed here as we're guaranteed to
* have an implicit context thanks to an undefined
* MULTIPLICITY.
*/
PL_perl_destruct_level = 1;
perl_destruct(global_perl);
perl_free(global_perl);
global_perl = NULL;
global_perl_dont_free = 1;
}
#endif
cd->perl = perl_alloc();
if (cd->perl == NULL) {
free(cd);
return (ISC_R_FAILURE);
}
#ifdef MULTIPLICITY
my_perl = cd->perl;
#endif
PERL_SET_CONTEXT(cd->perl);
/*
* We will re-create the interpreter during an rndc reconfig, so we
* must set this variable per perlembed in order to insure we can
* clean up Perl at a later time.
*/
PL_perl_destruct_level = 1;
perl_construct(cd->perl);
PL_exit_flags |= PERL_EXIT_DESTRUCT_END;
/* Prevent crashes from clients writing to $0 */
PL_origalen = 1;
cd->perl_source = strdup(argv[1]);
if (cd->perl_source == NULL) {
free(cd);
return (ISC_R_NOMEMORY);
}
perlrun[1] = cd->perl_source;
if (perl_parse(cd->perl, xs_init, 3, perlrun, (char **)NULL)) {
cd->log(ISC_LOG_ERROR,
"DLZ Perl '%s': Failed to parse Perl script, aborting",
dlzname);
goto CLEAN_UP_PERL_AND_FAIL;
}
/* Let Perl know about our callbacks. */
call_argv("DLZ_Perl::clientinfo::bootstrap",
G_DISCARD|G_NOARGS, &call_argv_args);
call_argv("DLZ_Perl::bootstrap",
G_DISCARD|G_NOARGS, &call_argv_args);
/*
* Run the script. We don't really need to do this since we have
* the init callback, but there's not really a downside either.
*/
if (perl_run(cd->perl)) {
cd->log(ISC_LOG_ERROR,
"DLZ Perl '%s': Script exited with an error, aborting",
dlzname);
goto CLEAN_UP_PERL_AND_FAIL;
}
#ifdef MULTIPLICITY
if (missing_method_name = missing_perl_method(perl_class_name, my_perl))
#else
if (missing_method_name = missing_perl_method(perl_class_name))
#endif
{
cd->log(ISC_LOG_ERROR,
"DLZ Perl '%s': Missing required function '%s', "
"aborting", dlzname, missing_method_name);
goto CLEAN_UP_PERL_AND_FAIL;
}
dSP;
ENTER;
SAVETMPS;
PUSHMARK(SP);
XPUSHs(sv_2mortal(newSVpv(perl_class_name, 0)));
/* Build flattened hash of config info. */
XPUSHs(sv_2mortal(newSVpv("log_context", 0)));
XPUSHs(sv_2mortal(newSViv((IV)cd->log)));
/* Argument to pass to new? */
if (argc == 4) {
XPUSHs(sv_2mortal(newSVpv("argv", 0)));
XPUSHs(sv_2mortal(newSVpv(argv[3], 0)));
}
PUTBACK;
r = call_method("new", G_EVAL|G_SCALAR);
SPAGAIN;
if (r) cd->perl_class = SvREFCNT_inc(POPs);
PUTBACK;
FREETMPS;
LEAVE;
if (SvTRUE(ERRSV)) {
POPs;
cd->log(ISC_LOG_ERROR,
"DLZ Perl '%s': new died in eval: %s",
dlzname, SvPV_nolen(ERRSV));
goto CLEAN_UP_PERL_AND_FAIL;
}
if (!r || !sv_isobject(cd->perl_class)) {
cd->log(ISC_LOG_ERROR,
"DLZ Perl '%s': new failed to return a blessed object",
dlzname);
goto CLEAN_UP_PERL_AND_FAIL;
}
*dbdata = cd;
#ifndef MULTIPLICITY
global_perl = cd->perl;
#endif
return (ISC_R_SUCCESS);
CLEAN_UP_PERL_AND_FAIL:
PL_perl_destruct_level = 1;
perl_destruct(cd->perl);
perl_free(cd->perl);
free(cd->perl_source);
free(cd);
return (ISC_R_FAILURE);
}
template<typename T> value_t call(value_t obj, T&& name)
{
return call_argv(obj, symbol_cast(std::forward<T>(name)), value_nil, 0, 0);
}
template<typename T> value_t call_argv(value_t obj, T&& name, size_t argc, value_t argv[])
{
return call_argv(obj, symbol_cast(std::forward<T>(name)), value_nil, argc, argv);
}