Ejemplo n.º 1
0
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);
}
Ejemplo n.º 2
0
/**
 * 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;
}
Ejemplo n.º 3
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;
}
Ejemplo n.º 4
0
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);
}
Ejemplo n.º 5
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;
}
Ejemplo n.º 6
0
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;
}
Ejemplo n.º 7
0
/**
   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;

}
Ejemplo n.º 8
0
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);
}
Ejemplo n.º 9
0
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);
}
Ejemplo n.º 10
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);
}