C++ perl_parse函数代码示例

static perl_parse_and_execute(PerlInterpreter * my_perl, char *input_code, char *setup_code)
{
	int error = 0;

	if (*input_code == '~') {
		char *buff = input_code + 1;
		perl_parse(my_perl, xs_init, 3, embedding, NULL);
		if (setup_code)
			Perl_safe_eval(my_perl, setup_code);
		Perl_safe_eval(my_perl, buff);
	} else {
		int argc = 0;
		char *argv[128] = { 0 };
		char *err;
		argv[0] = "FreeSWITCH";
		argc++;

		argc += switch_separate_string(input_code, ' ', &argv[1], (sizeof(argv) / sizeof(argv[0])) - 1);
		if (!perl_parse(my_perl, xs_init, argc, argv, (char **) NULL)) {
			if (setup_code) {
				if (!Perl_safe_eval(my_perl, setup_code)) {
					perl_run(my_perl);
				}
			}
		}

		if ((err = SvPV(get_sv("@", TRUE), n_a)) && !zstr(err)) {
			switch_log_printf(SWITCH_CHANNEL_LOG, SWITCH_LOG_ERROR, "%s\n", err);
		}


	}
}

	bool OnLoad(const CString& sArgsi, CString& sMessage) {
		CString sModPath, sTmp;
		if (!CModules::FindModPath("modperl/startup.pl", sModPath, sTmp)) {
			sMessage = "startup.pl not found.";
			return false;
		}
		sTmp = CDir::ChangeDir(sModPath, "..");
		int argc = 6;
		char *pArgv[] = {"", "-T", "-w",
			"-I", const_cast<char*>(sTmp.c_str()),
			const_cast<char*>(sModPath.c_str()), NULL};
		char **argv = pArgv;
		PERL_SYS_INIT3(&argc, &argv, &environ);
		m_pPerl = perl_alloc();
		perl_construct(m_pPerl);
		if (perl_parse(m_pPerl, xs_init, argc, argv, environ)) {
			perl_free(m_pPerl);
			PERL_SYS_TERM();
			m_pPerl = NULL;
			sMessage = "Can't initialize perl.";
			DEBUG(__PRETTY_FUNCTION__ << " can't init perl");
			return false;
		}
		PL_exit_flags |= PERL_EXIT_DESTRUCT_END;
		PSTART;
		PCALL("ZNC::Core::Init");
		PEND;
		return true;
	}

int load_perl__( void ) 
{
  char *embedding[] = {"","-e","0"};  /* perl interpreter config params */
  int i;

#ifdef MULTI_THREAD
  if( NULL == th)
	th = xsb_get_main_thread();
#endif

  /* check if the perl interpreter is loaded already*/
  if ( perlObjectStatus == LOADED ) return SUCCESS;

  /*------------------------------------------------------------------------
    initial the global variables
    ----------------------------------------------------------------------*/
  for ( i=0; i<MAX_TOTAL_MATCH; i++ ) 
    matchResults[i] = NULL;  
  preBulkMatchNumber = 0;
  bulkMatchList = NULL;
  matchPattern = NULL;
  substituteString = NULL;
  build_sub_match_spec();    /*build the submatch arguments string constant*/  

  my_perl = perl_alloc();
  perl_construct( my_perl );
  perl_parse( my_perl, NULL, 3, embedding, (char **)NULL );
  perl_run(my_perl);

  perlObjectStatus = LOADED;

  return (SUCCESS); 
}

/* Initialize perl interpreter */
void perl_scripts_init(void)
{
	char *code, *use_code;

	perl_scripts = NULL;
        perl_sources_start();
	perl_signals_start();

	my_perl = perl_alloc();
	perl_construct(my_perl);

	perl_parse(my_perl, xs_init, G_N_ELEMENTS(perl_args), perl_args, NULL);
#if PERL_STATIC_LIBS == 1
	perl_eval_pv("Irssi::Core::->boot_Irssi_Core(0.9);", TRUE);
#endif

        perl_common_start();

	use_code = perl_get_use_list();
        code = g_strdup_printf(irssi_core_code, PERL_STATIC_LIBS, use_code);
	perl_eval_pv(code, TRUE);

	g_free(code);
        g_free(use_code);
}

main (int argc, char **argv, char **env)
{
	STRLEN n_a;
	char *embedding[] = { "", "-e", "0" };
   
	my_perl = perl_alloc();
	perl_construct( my_perl );
   
	perl_parse(my_perl, NULL, 3, embedding, NULL);
	perl_run(my_perl);
   
	/** Treat $a as an integer **/
	perl_eval_pv("$a = 3; $a **= 2", TRUE);
	printf("a = %d\n", SvIV(perl_get_sv("a", FALSE)));
   
	/** Treat $a as a float **/
	perl_eval_pv("$a = 3.14; $a **= 2", TRUE);
	printf("a = %f\n", SvNV(perl_get_sv("a", FALSE)));
   
	/** Treat $a as a string **/
	perl_eval_pv("$a = 'rekcaH lreP rehtonA tsuJ'; $a = reverse($a);", TRUE);
	printf("a = %s\n", SvPV(perl_get_sv("a", FALSE), n_a));
   
	perl_destruct(my_perl);
	perl_free(my_perl);
}

/* ---- special pearl parser ----- */
int perl_parse_buf (char *inBuf) {
	
	STRLEN n_a;
	char *embedding[] = { "", "-e", "" };

	
	if (!my_perl) {
		my_perl = perl_alloc();
		perl_construct( my_perl );
		perl_parse(my_perl, xs_init, 3, embedding, NULL);
		/* PL_exit_flags |= PERL_EXIT_DESTRUCT_END; */
		perl_run(my_perl);
	}

/* 	sv_setpv(text,inBuf); */
/* 	eval_sv(text,G_SCALAR); */

	perlBuf = eval_pv(inBuf, TRUE);
	
	if (0) {
		perl_destruct(my_perl);
		perl_free(my_perl);
	}

	return 0;
	
}

static void irssi_perl_start(void)
{
	/* stolen from xchat, thanks :) */
	char *args[] = {"", "-e", "0"};
	char load_file[] =
		"sub load_file()\n"
		"{\n"
		"  (my $file_name) = @_;\n"
		"  open FH, $file_name or return \"File not found: $file_name\";\n"
		"  local($/) = undef;\n"
		"  $file = <FH>;\n"
		"  close FH;\n"
		"  eval $file;\n"
		"  eval $file if [email protected];\n"
		"  return [email protected] if [email protected];\n"
		"}";

	first_signals = g_hash_table_new((GHashFunc) g_direct_hash, (GCompareFunc) g_direct_equal);
	last_signals = g_hash_table_new((GHashFunc) g_direct_hash, (GCompareFunc) g_direct_equal);
	perl_timeouts = NULL;

	irssi_perl_interp = perl_alloc();
	perl_construct(irssi_perl_interp);

	perl_parse(irssi_perl_interp, xs_init, 3, args, NULL);
	perl_eval_pv(load_file, TRUE);
}

void init_embedded_perl(void) {
	char *embedding[] = { "", "p1.pl" };
										/* embedding takes the place of argv[] ($argv[0] is the program name. 
										 * - which is not given to Perl).
										 * Note that the number of args (ie the number of elements in embedding
										 * [argc] is the third argument of perl_parse().
										 */
	int exitstatus;
	char buffer[132];

	if((my_perl=perl_alloc())==NULL){
		snprintf(buffer,sizeof(buffer),"Error: Could not allocate memory for embedded Perl interpreter!\n");
		buffer[sizeof(buffer)-1]='\x0';
		printf("%s\n", buffer);
		exit(1);
	}

	perl_construct(my_perl);
	exitstatus=perl_parse(my_perl,xs_init,2,embedding,NULL);
	PL_exit_flags |= PERL_EXIT_DESTRUCT_END;
										/* Why is perl_run() necessary ?
										 * It is needed if the code parsed by perl_parse() has
										 * any runtime semantics (eg code that gets eval'd, 
										 * behaviour that depends on constants etc).
										 */
	exitstatus=perl_run(my_perl);

	if (exitstatus) {
		printf("%s\n", "perl_run() failed.");
		exit(1);
	}
}

// Get everything going...
int __declspec( dllexport ) __stdcall LoadDll( LOADINFO * limIRC ) {
    mWnd = limIRC->mHwnd;
    limIRC->mKeep = TRUE; // TODO: Set to FALSE if the inline perl fails

    if ( my_perl == NULL ) {
        /* Get things set for mIRC<=>perl IO */
        hMapFile = CreateFileMapping( INVALID_HANDLE_VALUE, 0, PAGE_READWRITE, 0, 4096, NAMESPACE );
        mData = ( LPSTR )MapViewOfFile( hMapFile, FILE_MAP_ALL_ACCESS, 0, 0, 0 );
        /* Create our persistant interpreter */
        char * perl_args[] = { "", "-e", "", "0" };
        PERL_SYS_INIT3( NULL, NULL, NULL );
        if ( ( my_perl = perl_alloc() ) == NULL ) {
            mIRC_execute( "/echo Failed to load DLL: No memory" ); /* TODO: make this an error message */
            limIRC->mKeep = FALSE;
            return 0;
        }
        perl_construct( my_perl );
        PL_origalen = 1; /* Don't let $0 assignment update the proctitle or perl_args[0] */
        perl_parse( my_perl, xs_init, 6, perl_args, NULL );
        PL_exit_flags |= PERL_EXIT_DESTRUCT_END;
        perl_run( my_perl );
        {
#ifdef PERLIO_LAYERS /* Layers available */
            PerlIO_define_layer( aTHX_ PERLIO_FUNCS_CAST( &PerlIO_mIRC ) );
            PerlIO_apply_layers( aTHX_ PerlIO_stderr( ), NULL, ":mIRC" );
            PerlIO_apply_layers( aTHX_ PerlIO_stdout( ), NULL, ":mIRC" );
#endif /* PERLIO_LAYERS */
        }
        SV * result = eval_pv( form(
                                   "use FindBin;"                    /* CORE */
                                   "use lib qq[$FindBin::Bin/lib];"  /* Search %mIRC%/lib for modules */
                                   "use lib qq[$FindBin::Bin/perl];" /* Look for modules in %mIRC%/perl */
                                   "my $mIRC = bless \{ }, 'mIRC';"

int main(int argc, char **argv, char **env)
{
  //if (argc < 2) {
  //  fprintf(stderr, "you must specify at least one argument\n");
  //  exit(0);
  //}
  pthread_t threads[NUM_THREADS];
  pthread_mutex_init(&mutex_perl, NULL);
  PERL_SYS_INIT3(&argc,&argv,&env);
  char *my_argv[] = { "", PERL_SCRIPT };
  my_perl = perl_alloc();
  PERL_SET_CONTEXT(my_perl);
  perl_construct(my_perl);
  perl_parse(my_perl, NULL, 2, my_argv, (char **)NULL);
  PL_exit_flags |= PERL_EXIT_DESTRUCT_END;
  perl_run(my_perl);
  int t;
  for (t=0; t<NUM_THREADS; t++) {
    printf("creating thread %d\n", t);
    (void)pthread_create(&threads[t], NULL, thread_context, (void *)t);
  }
  for (t=0;t<NUM_THREADS;t++) {
    (void)pthread_join(threads[t], NULL);
    printf("joined thread %d\n", t);
  }
  perl_destruct(my_perl);
  perl_free(my_perl);
  pthread_exit(NULL);
  pthread_mutex_destroy(&mutex_perl);
  PERL_SYS_TERM();
}

/* ---------------------------------------------------------- parse_score --- */
int
parse_score(int argc, char *argv[])
{
   int   i, status, xargc;
   char  *xargv[MAXARGS + 2];

   assert(argc <= MAXARGS);

   /* Insert in arg list the lib dir containing our Perl extension. */
   xargv[0] = argv[0];
   xargv[1] = extra_lib_dir;
   for (i = 1; i < argc; i++)
      xargv[i + 1] = argv[i];
   xargv[i + 1] = NULL;
   xargc = argc + 1;

   perl_interp = perl_alloc();
   if (perl_interp) {
      perl_construct(perl_interp);
      status = perl_parse(perl_interp, xs_init, xargc, xargv, (char **)NULL);
      if (status == 0)
         perl_run(perl_interp);
   }
   else {
      fprintf(stderr, "Can't create Perl interpreter.\n");
      status = -1;
   }

   return status;
}

void h3(void *arg) {
    int argc = 3;
    char *argv[] = { "", "-e", "use Data::Dumper;"
        "sub dump_perl { print STDERR Data::Dumper::Dumper([shift]); }", 
            NULL };
    char *env[] = { NULL };
    void *original_context = PERL_GET_CONTEXT;
    SV *sv;

    PERL_SYS_INIT3(&argc,&argv,&env);
    my_perl = perl_alloc();

    sv = newRV_inc(newSViv(5));

    PERL_SET_CONTEXT(my_perl);
    perl_construct(my_perl);
    
    perl_parse(my_perl, mine_xs_init, argc, argv, NULL);

    call_dump_perl(sv);
    
    perl_destruct(my_perl);
    perl_free(my_perl);

    PERL_SET_CONTEXT(original_context);
}

/* Stopping has one big memory leak right now, so it's not used. */
void	perlstartstop (int startnotstop) 
{
	if (startnotstop && !isperlrunning) {
		char *embedding[3];
		embedding[0] = malloc_strdup(empty_string);
		embedding[1] = malloc_strdup("-e");
		embedding[2] = malloc_strdup("$SIG{__DIE__}=$SIG{__WARN__}=\\&EPIC::yell;");

		++isperlrunning;
		my_perl = perl_alloc();
		perl_construct( my_perl );
		perl_parse(my_perl, xs_init, 3, embedding, NULL);
		if (SvTRUE(ERRSV)) 
			yell("perl_parse: %s", SvPV_nolen(ERRSV));
		perl_run(my_perl);
		if (SvTRUE(ERRSV)) 
			yell("perl_run: %s", SvPV_nolen(ERRSV));
	} else if (!startnotstop && isperlrunning && !perlcalldepth) {
		perl_destruct(my_perl);
		if (SvTRUE(ERRSV)) 
			yell("perl_destruct: %s", SvPV_nolen(ERRSV));
		perl_free(my_perl);
		if (SvTRUE(ERRSV)) 
			yell("perl_free: %s", SvPV_nolen(ERRSV));
		isperlrunning=0;
	}
}

static void
gplp_load_base (GOPluginLoader *loader, GOErrorInfo **ret_error)
{
	char *argv[] = { (char*)"", NULL, NULL, NULL };
	char const *arg;
	int argc;

	arg = go_plugin_get_dir_name (go_plugin_loader_get_plugin (loader));
	argv[1] = g_strconcat ("-I", arg, NULL);
	argv[2] = g_build_filename (arg, "perl_func.pl", NULL);
	argc = 2;

	if (g_file_test (argv[2], G_FILE_TEST_EXISTS)) {
		PERL_SYS_INIT3 (&argc, (char ***)&argv, NULL);
		gnm_perl_interp = perl_alloc ();
		perl_construct (gnm_perl_interp);
		perl_parse (gnm_perl_interp, xs_init, 3, argv, NULL);
		my_perl = gnm_perl_interp;
		init_help_consts ();
#ifdef PERL_EXIT_DESTRUCT_END
		PL_exit_flags |= PERL_EXIT_DESTRUCT_END;
#endif
	} else {
		*ret_error = go_error_info_new_printf (
			     _("perl_func.pl doesn't exist."));
	}

	g_free (argv[1]);
	g_free (argv[2]);
}

void perl_interpreter_init_()
{
  char *embedding[] = { "", "-e", "0" };
  my_perl = perl_alloc();
  perl_construct(my_perl);
  perl_parse(my_perl, xs_init, 3, embedding, (char **)NULL);
  perl_run(my_perl);
}