C++ perl_alloc函数代码示例

PerlInterpreter *p5_init_perl() {
    char *embedding[] = { "", "-e", "0" };
    int argc = 0;
    char **argv;
    if (!inited++)
        PERL_SYS_INIT(&argc, &argv);
    PerlInterpreter *my_perl = perl_alloc();
    PERL_SET_CONTEXT(my_perl);
    PL_perl_destruct_level = 1;
    perl_construct( my_perl );
    perl_parse(my_perl, xs_init, 3, embedding, NULL);
    PL_exit_flags |= PERL_EXIT_DESTRUCT_END;
    perl_run(my_perl);
    return my_perl;
}

void *my_Perl_get_context(void) {
    PerlInterpreter *my_perl=Perl_get_context();
    if (!my_perl) {
	my_perl=perl_alloc();
	PERL_SET_CONTEXT(my_perl);
	perl_construct(my_perl);
	perl_parse(my_perl, xs_init, 3, pargs, NULL);
	PL_exit_flags |= PERL_EXIT_DESTRUCT_END;
	perl_run(my_perl);
	PL_thread_at_exit(clear_perl, NULL, 0);
	/* warn ("new perl interpreter created %x (thread=%i)",
	      my_perl,
	      PL_thread_self()); */
    }
    return my_perl;
}

void
script_init (int argc, char **argv)
{
#ifdef USE_PERL
    char *filename;

    perl_env = perl_alloc ();
    perl_construct (perl_env);
    filename = gethome_conf_file ("script.pl");
    script_load (filename, SCRIPT_PERL);
#endif

#ifdef USE_GUILE
    gh_enter (argc, argv, fake_main);
#endif
}

int
perl_main(int argc, char **argv, char **env)
{
	int	r;

	iperl = perl_alloc();
	perl_construct(iperl);
	perl_parse(iperl, xs_init, argc, argv, (char **)NULL);
	r = perl_run(iperl);

PerlIO_flush(PerlIO_stdout());
PerlIO_flush(PerlIO_stderr());

	perl_destruct(iperl);
	perl_free(iperl);
	return (r);
}

static void
plperl_init_interp(void)
{
	static char *embedding[3] = {
		"", "-e", PERLBOOT
	};

	plperl_interp = perl_alloc();
	if (!plperl_interp)
		elog(ERROR, "could not allocate Perl interpreter");

	perl_construct(plperl_interp);
	perl_parse(plperl_interp, plperl_init_shared_libs, 3, embedding, NULL);
	perl_run(plperl_interp);

	plperl_proc_hash = newHV();
}

static PerlInterpreter *
start_perl_interpreter (char *err, int max_len)
{
  PerlInterpreter *intrp;
  char *embedding[3];
#ifdef MY_ENV
  char *envp[] = {
    NULL
  };
#else
  char **envp = NULL;
#endif

  embedding[0] = "CGI";
  embedding[1] = "-e";
  embedding[2] = virt_handler;
  log_debug ("start_perl_interpreter");
  if (NULL == (intrp = perl_alloc()))
    {
      SET_ERR ("Unable to allocate perl interpreter");
      return NULL;
    }
    {
      dTHX;
      perl_construct(intrp);
      PERL_SET_CONTEXT(intrp);

      if (0 == perl_parse(intrp, xs_init, 3, embedding, envp))
	{
	  PERL_SET_CONTEXT(intrp);
	  if (0 == perl_run(intrp))
	    return intrp;
	  else
	    SET_ERR ("Unable to run the perl interpreter");
	}
      else
	SET_ERR ("Unable to parse virt_handler.pl");
#ifdef PERL_EXIT_DESTRUCT_END
      PL_exit_flags |= PERL_EXIT_DESTRUCT_END;
#endif
      perl_destruct (intrp);
      perl_free (intrp);
    }
  return NULL;
}

/*
 * Initialize the perl interpreter.
 * This might later be used to reinit the module.
 */
PerlInterpreter *parser_init(void) {
	int argc = 0;
	char *argv[9];
	PerlInterpreter *new_perl = NULL;
	int modpathset = 0;

	new_perl = perl_alloc();

	if (!new_perl) {
		LM_ERR("could not allocate perl.\n");
		return NULL;
	}

	perl_construct(new_perl);

	argv[0] = ""; argc++; /* First param _needs_ to be empty */

	 /* Possible Include path extension by modparam */
	if (modpath && (strlen(modpath) > 0)) {
		modpathset = argc;
		LM_INFO("setting lib path: '%s'\n", modpath);
		argv[argc] = pkg_malloc(strlen(modpath)+20);
		sprintf(argv[argc], "-I%s", modpath);
		argc++;
	}

	argv[argc] = "-M"DEFAULTMODULE; argc++; /* Always "use" Opensips.pm */

	argv[argc] = filename; /* The script itself */
	argc++;

	if (perl_parse(new_perl, xs_init, argc, argv, NULL)) {
		LM_ERR("failed to load perl file \"%s\".\n", argv[argc-1]);
		if (modpathset) pkg_free(argv[modpathset]);
		return NULL;
	} else {
		LM_INFO("successfully loaded perl file \"%s\"\n", argv[argc-1]);
	}

	if (modpathset) pkg_free(argv[modpathset]);
	perl_run(new_perl);

	return new_perl;

}

PerlInterpreter *uwsgi_perl_new_interpreter(void) {

	PerlInterpreter *pi = perl_alloc();
        if (!pi) {
                uwsgi_log("unable to allocate perl interpreter\n");
                return NULL;
        }

	PERL_SET_CONTEXT(pi);

        PL_perl_destruct_level = 2;
        PL_origalen = 1;
        perl_construct(pi);
	// over-engeneering
        PL_origalen = 1;

	return pi;
}

static void
PurlInit()
{
  PL_origalen = 1;

  dummy_argv = malloc(sizeof(char*) * 3);
  dummy_argv[0] = "purl";
  dummy_argv[1] = "-e";
  dummy_argv[2] = "0";

  PERL_SYS_INIT3(&dummy_argc,&dummy_argv,&dummy_env);

  my_perl = perl_alloc();
  perl_construct(my_perl);
  PL_exit_flags |= PERL_EXIT_DESTRUCT_END;
  perl_parse(my_perl, xs_init, dummy_argc, dummy_argv, (char **)NULL);
  //perl_run(my_perl);
}

main (int argc, char **argv, char **env)
{
  char *embedding[] = { "", "-e", "0" };
  char *text, **match_list;
  int num_matches, i;
  int j;
  my_perl = perl_alloc();
  perl_construct( my_perl );
  perl_parse(my_perl, NULL, 3, embedding, NULL);
  text = (char *) malloc(sizeof(char) * 486); /** A long string follows! **/
  sprintf(text, "%s", "When he is at a convenience store and the bill comes to some amount like 76 cents, Maynard is aware that there is something he *should* do, something that will enable him to get back a quarter, but he has no idea *what*.  He fumbles through his red squeezey changepurse and gives the boy three extra pennies with his dollar, hoping that he might luck into the correct amount.  The boy gives him back two of his own pennies and then the big shiny quarter that is his prize. -RICHH");
  if (match(text, "m/quarter/")) /** Does text contain 'quarter'? **/
    printf("match: Text contains the word 'quarter'.\n\n");
  else
    printf("match: Text doesn't contain the word 'quarter'.\n\n");
  if (match(text, "m/eighth/")) /** Does text contain 'eighth'? **/
    printf("match: Text contains the word 'eighth'.\n\n");
  else
    printf("match: Text doesn't contain the word 'eighth'.\n\n");
  /** Match all occurrences of /wi../ **/
  num_matches = matches(text, "m/(wi..)/g", &match_list);
  printf("matches: m/(wi..)/g found %d matches...\n", num_matches);
  for (i = 0; i < num_matches; i++)
    printf("match: %s\n", match_list[i]);
  printf("\n");
  for (i = 0; i < num_matches; i++) {
    free(match_list[i]);
  }
  free(match_list);
  /** Remove all vowels from text **/
  num_matches = substitute(&text, "s/[aeiou]//gi");
  if (num_matches) {
    printf("substitute: s/[aeiou]//gi...%d substitutions made.\n",
	   num_matches);
    printf("Now text is: %s\n\n", text);
  }
  /** Attempt a substitution **/
  if (!substitute(&text, "s/Perl/C/")) {
    printf("substitute: s/Perl/C...No substitution made.\n\n");
  }
  free(text);
  perl_destruct(my_perl);
  perl_free(my_perl);
}

bool KviPerlInterpreter::init()
{
	if(m_pInterpreter)done();
	const char * daArgs[] = { "yo", "-e", "0", "-w" };
	m_pInterpreter = perl_alloc();
	if(!m_pInterpreter)return false;
	PERL_SET_CONTEXT(m_pInterpreter);
	PL_perl_destruct_level = 1;
	perl_construct(m_pInterpreter);
	perl_parse(m_pInterpreter,xs_init,4,(char **)daArgs,NULL);
	QString szInitCode;

	// this part of the code seems to be unnecessary
	// even if it is created by the perl make process...
	//	"our %EXPORT_TAGS = ('all' => [qw(echo)]);\n"
	//	"our @EXPORT_OK = (qw(echo));\n"
	//	"our @EXPORT = qw();\n"
	// This is probably needed only if perl has to load
	// the XS through XSLoader ?
	// Maybe also the remaining part of the package
	// declaration could be dropped as well...
	// I just haven't tried :D

	szInitCode = QString(
		"{\n" \
			"package KVIrc;\n" \
			"require Exporter;\n" \
			"our @ISA = qw(Exporter);\n" \
			"1;\n" \
		"}\n" \
		"$g_szContext = \"%1\";\n" \
		"$g_bExecuteQuiet = 0;\n" \
		"$SIG{__WARN__} = sub\n" \
		"{\n" \
		"	my($p,$f,$l,$x);\n" \
		"	($p,$f,$l) = caller;\n" \
		"	KVIrc::internalWarning(\"At line \".$l.\" of perl code: \");\n" \
		"	KVIrc::internalWarning(join(' ',@_));\n" \
		"}\n").arg(m_szContextName);

	eval_pv(szInitCode.toUtf8().data(),false);
	return true;
}

int proxenet_perl_initialize_vm(plugin_t* plugin)
{
	interpreter_t *interpreter;
        char *perl_args[] = { "", "/dev/null", NULL };
        int   perl_args_count = 2;

#ifdef PERL_SYS_INIT3
        int a;
        char **perl_args_local;
        char *perl_env[] = {};
        a = perl_args_count;
        perl_args_local = perl_args;
        (void) perl_env;
        PERL_SYS_INIT3 (&a, (char ***)&perl_args_local, (char ***)&perl_env);
#endif

	interpreter = plugin->interpreter;

	/* checks */
	if (interpreter->ready)
                return 0;

#ifdef DEBUG
        xlog_perl(LOG_DEBUG, "%s\n", "Initializing VM");
#endif

        /* vm init */
        my_perl = perl_alloc();
        perl_construct(my_perl);
        PL_exit_flags |= PERL_EXIT_DESTRUCT_END;

        if (!my_perl) {
                xlog_perl(LOG_ERROR, "%s\n", "failed init-ing vm");
                return -1;
        }

        perl_parse(my_perl, NULL, perl_args_count, perl_args, (char **)NULL);

        interpreter->vm = (void*) my_perl;
        interpreter->ready = true;

	return 0;
}

void
maybe_source_perl_startup(void)
{
    const char     *embedargs[] = { "", "" };
    const char     *perl_init_file = netsnmp_ds_get_string(NETSNMP_DS_APPLICATION_ID,
							   NETSNMP_DS_AGENT_PERL_INIT_FILE);
    char            init_file[SNMP_MAXBUF];

    static int      have_done_init = 0;

    if (have_done_init)
        return;
    have_done_init = 1;

    if (!perl_init_file) {
        snprintf(init_file, sizeof(init_file) - 1,
                 "%s/%s", SNMPSHAREPATH, "snmp_perl.pl");
        perl_init_file = init_file;
    }
    embedargs[1] = perl_init_file;

    DEBUGMSGTL(("perl", "initializing perl (%s)\n", embedargs[1]));
    my_perl = perl_alloc();
    if (!my_perl)
        goto bail_out;

    perl_construct(my_perl);
    if (perl_parse(my_perl, xs_init, 2, (char **) embedargs, NULL))
        goto bail_out;

    if (perl_run(my_perl))
        goto bail_out;

    DEBUGMSGTL(("perl", "done initializing perl\n"));

    return;

  bail_out:
    snmp_log(LOG_ERR, "embedded perl support failed to initalize\n");
    netsnmp_ds_set_boolean(NETSNMP_DS_APPLICATION_ID, 
			   NETSNMP_DS_AGENT_DISABLE_PERL, 1);
    return;
}

int perl_init(){
	int myargc=0;
	char **myenv = NULL;
	char **myargv = NULL;
	char *embedding[]={"","-e","0"};

	PERL_SYS_INIT3(&myargc, &myargv, &myenv);

	my_perl=perl_alloc();
        sv=NEWSV(1099,0);
        perl_construct(my_perl);

	PL_exit_flags |= PERL_EXIT_DESTRUCT_END;
    
	perl_parse(my_perl, NULL, 3, embedding, NULL);
        perl_run(my_perl);
	
	return 1;
}	

PerlInterpreter *
new_perl(void)
{
    PerlInterpreter *p;
    char *embedding[] = { "", "-mPython::Object", "-e", "$| = 1;", NULL };

    p = perl_alloc();
#if 0
    fprintf(stderr, "creating new perl %p\n", p); fflush(stderr);
#endif
    perl_construct(p);
#ifdef BOOT_FROM_PERL
    perl_parse(p, 0, 4, embedding, NULL);
#else
    perl_parse(p, xs_init, 4, embedding, NULL);
#endif
    perl_run(p);

    return p;
}