예제 #1
0
파일: mod_psgi.c 프로젝트: mattn/mod_psgi
static void init_perl_variables()
{
    dTHX;
    GV *exit_gv = gv_fetchpv("CORE::GLOBAL::exit", TRUE, SVt_PVCV);
    GvCV(exit_gv) = get_cv("ModPSGI::exit", TRUE);
    GvIMPORTED_CV_on(exit_gv);
    (void) hv_store(GvHV(PL_envgv), "MOD_PSGI", 8, newSVpv(MOD_PSGI_VERSION, 0), 0);
}
예제 #2
0
void Embperl::DoInit() {
	const char *argv_eqemu[] = { "",
#ifdef EMBPERL_IO_CAPTURE
		"-w", "-W",
#endif
		"-e", "0;", NULL };

	int argc = 3;
#ifdef EMBPERL_IO_CAPTURE
	argc = 5;
#endif

	char **argv = (char **)argv_eqemu;
	char **env = { NULL };

	PL_perl_destruct_level = 1;

	perl_construct(my_perl);

	PERL_SYS_INIT3(&argc, &argv, &env);

	perl_parse(my_perl, xs_init, argc, argv, env);

	perl_run(my_perl);

	//a little routine we use a lot.
	eval_pv("sub my_eval {eval $_[0];}", TRUE);	//dies on error

	//ruin the perl exit and command:
	eval_pv("sub my_exit {}",TRUE);
	eval_pv("sub my_sleep {}",TRUE);
	if(gv_stashpv("CORE::GLOBAL", FALSE)) {
		GV *exitgp = gv_fetchpv("CORE::GLOBAL::exit", TRUE, SVt_PVCV);
		//#if _MSC_VER >= 1600
		//GvCV_set(exitgp, perl_get_cv("my_exit", TRUE));	//dies on error
		//#else
		GvCV(exitgp) = perl_get_cv("my_exit", TRUE);	//dies on error
		//#endif	//dies on error
		GvIMPORTED_CV_on(exitgp);
		GV *sleepgp = gv_fetchpv("CORE::GLOBAL::sleep", TRUE, SVt_PVCV);
		//#if _MSC_VER >= 1600 
		//GvCV_set(sleepgp, perl_get_cv("my_sleep", TRUE));	//dies on error
		//#else
		GvCV(sleepgp) = perl_get_cv("my_sleep", TRUE);	//dies on error
		//#endif
		GvIMPORTED_CV_on(sleepgp);
	}

	//declare our file eval routine.
	try {
		init_eval_file();
	}
	catch(const char *err)
	{
		//remember... lasterr() is no good if we crap out here, in construction
		EQC::Common::Log(EQCLog::Error,CP_QUESTS, "perl error: %s", err);
		throw "failed to install eval_file hook";
	}

#ifdef EMBPERL_IO_CAPTURE
EQC::Common::Log(EQCLog::Debug,CP_QUESTS, "Tying perl output to eqemu logs");
	//make a tieable class to capture IO and pass it into EQEMuLog
	eval_pv(
		"package EQEmuIO; "
//			"&boot_EQEmuIO;"
 			"sub TIEHANDLE { my $me = bless {}, $_[0]; $me->PRINT('Creating '.$me); return($me); } "
  			"sub WRITE {  } "
  			//dunno why I need to shift off fmt here, but it dosent like without it
  			"sub PRINTF { my $me = shift; my $fmt = shift; $me->PRINT(sprintf($fmt, @_)); } "
  			"sub CLOSE { my $me = shift; $me->PRINT('Closing '.$me); } "
  			"sub DESTROY { my $me = shift; $me->PRINT('Destroying '.$me); } "
//this ties us for all packages, just do it in quest since thats kinda 'our' package
  		"package quest;"
  		"	if(tied *STDOUT) { untie(*STDOUT); }"
  		"	if(tied *STDERR) { untie(*STDERR); }"
  		"	tie *STDOUT, 'EQEmuIO';"
  		"	tie *STDERR, 'EQEmuIO';"
  		,FALSE);
#endif //EMBPERL_IO_CAPTURE

#ifdef EMBPERL_PLUGIN
	eval_pv(
		"package plugin; "
		,FALSE
	);
#ifdef EMBPERL_EVAL_COMMANDS
	try {
		eval_pv(
			"use IO::Scalar;"
			"$plugin::printbuff='';"
			"tie *PLUGIN,'IO::Scalar',\\$plugin::printbuff;"
		,FALSE);
	}
	catch(const char *err) {
		throw "failed to install plugin printhook, do you lack IO::Scalar?";
	}
#endif

	EQC::Common::Log(EQCLog::Status,CP_QUESTS, "Loading perlemb plugins.");
	try
	{
		eval_pv("main::eval_file('plugin', 'plugin.pl');", FALSE);
	}
	catch(const char *err)
	{
		EQC::Common::Log(EQCLog::Status,CP_QUESTS, "Warning - plugin.pl: %s", err);
	}

	// Harakiri, this reads all the plugins in \plugins like 
	// check_handin.pl
	// check_hasitem.pl
	try
	{
		//should probably read the directory in c, instead, so that
		//I can echo filenames as I do it, but c'mon... I'm lazy and this 1 line reads in all the plugins
		eval_pv(
			"if(opendir(D,'plugins')) { "
			"	my @d = readdir(D);"
			"	closedir(D);"
			"	foreach(@d){ "
			"		main::eval_file('plugin','plugins/'.$_)if/\\.pl$/;"
			"	}"
			"}"
		,FALSE);
	}
	catch(const char *err)
	{
		EQC::Common::Log(EQCLog::Status,CP_QUESTS,  "Perl warning while loading plugins : %s", err);
	}

	// Harakiri, this reads all the plugins in quest\plugins like 
	try
	{
		//should probably read the directory in c, instead, so that
		//I can echo filenames as I do it, but c'mon... I'm lazy and this 1 line reads in all the plugins
		eval_pv(
			"if(opendir(D,'quests/plugins/')) { "
			"	my @d = readdir(D);"
			"	closedir(D);"
			"	foreach(@d){ "
			"		main::eval_file('plugin','quests/plugins/'.$_)if/\\.pl$/;"
			"	}"
			"}"
		,FALSE);
	}
	catch(const char *err)
	{
		EQC::Common::Log(EQCLog::Status,CP_QUESTS,  "Perl warning while loading plugins : %s", err);
	}
#endif //EMBPERL_PLUGIN

	//Harakiri these are used to create perl bases #commands
#ifdef EMBPERL_COMMANDS
	EQC::Common::Log(EQCLog::Normal,CP_QUESTS, "Loading perl commands...");
	try
	{
		eval_pv(
			"package commands;"
			"main::eval_file('commands', 'commands.pl');"
			"&commands::commands_init();"
		, FALSE);
	}
	catch(const char *err)
	{
		EQC::Common::Log(EQCLog::Error,CP_ZONESERVER, "Warning - commands.pl: %s", err);
	}
	EQC::Common::Log(EQCLog::Normal,CP_QUESTS, "Perl commands loaded....");
#endif //EMBPERL_COMMANDS

	in_use = false;
}
예제 #3
0
void EQWParser::DoInit() {
	const char *argv_eqemu[] = { "",
		"-w", "-W",
		"-e", "0;", nullptr };

	int argc = 5;

	char **argv = (char **)argv_eqemu;
	char **env = { nullptr };

	PL_perl_destruct_level = 1;

	perl_construct(my_perl);

	PERL_SYS_INIT3(&argc, &argv, &env);

	perl_parse(my_perl, xs_init, argc, argv, env);

	perl_run(my_perl);

	//a little routine we use a lot.
	eval_pv("sub my_eval {eval $_[0];}", TRUE);	//dies on error

	//ruin the perl exit and command:
	eval_pv("sub my_exit {}",TRUE);
	eval_pv("sub my_sleep {}",TRUE);
	if(gv_stashpv("CORE::GLOBAL", FALSE)) {
		GV *exitgp = gv_fetchpv("CORE::GLOBAL::exit", TRUE, SVt_PVCV);
		GvCV_set(exitgp, perl_get_cv("my_exit", TRUE));	//dies on error
		GvIMPORTED_CV_on(exitgp);
		GV *sleepgp = gv_fetchpv("CORE::GLOBAL::sleep", TRUE, SVt_PVCV);
		GvCV_set(sleepgp, perl_get_cv("my_sleep", TRUE));	//dies on error
		GvIMPORTED_CV_on(sleepgp);
	}

	//setup eval_file
	eval_pv(
	"our %Cache;"
	"use Symbol qw(delete_package);"
	"sub eval_file {"
		"my($package, $filename) = @_;"
		"$filename=~s/\'//g;"
		"if(! -r $filename) { print \"Unable to read perl file '$filename'\\n\"; return; }"
		"my $mtime = -M $filename;"
		"if(defined $Cache{$package}{mtime}&&$Cache{$package}{mtime} <= $mtime && !($package eq 'plugin')){"
		"	return;"
		"} else {"
		//we 'my' $filename,$mtime,$package,$sub to prevent them from changing our state up here.
		"	eval(\"package $package; my(\\$filename,\\$mtime,\\$package,\\$sub); \\$isloaded = 1; require '$filename'; \");"
		"}"
	"}"
	,FALSE);

	//make a tie-able class to capture IO and get it where it needs to go
	eval_pv(
		"package EQWIO; "
//			"&boot_EQEmuIO;"
			"sub TIEHANDLE { my $me = bless {}, $_[0]; $me->PRINT('Creating '.$me); return($me); } "
			"sub WRITE { } "
			"sub PRINTF { my $me = shift; my $fmt = shift; $me->PRINT(sprintf($fmt, @_)); } "
			"sub CLOSE { my $me = shift; $me->PRINT('Closing '.$me); } "
			"sub DESTROY { my $me = shift; $me->PRINT('Destroying '.$me); } "
//this ties us for all packages
		"package MAIN;"
		"	if(tied *STDOUT) { untie(*STDOUT); }"
		"	if(tied *STDERR) { untie(*STDERR); }"
		"	tie *STDOUT, 'EQWIO';"
		"	tie *STDERR, 'EQWIO';"
		,FALSE);

	eval_pv(
		"package world; "
		,FALSE
	);

	//make sure the EQW pointer is set up in this package
	EQW *curc = EQW::Singleton();
	SV *l = get_sv("world::EQW", true);
	if(curc != nullptr) {
		sv_setref_pv(l, "EQW", curc);
	} else {
		//clear out the value, mainly to get rid of blessedness
		sv_setsv(l, _empty_sv);
	}

	//make sure the EQDB pointer is set up in this package
	EQDB::SetMySQL(database.getMySQL());
	EQDB *curc_db = EQDB::Singleton();
	SV *l_db = get_sv("world::EQDB", true);
	if(curc_db != nullptr) {
		sv_setref_pv(l_db, "EQDB", curc_db);
	} else {
		//clear out the value, mainly to get rid of blessedness
		sv_setsv(l_db, _empty_sv);
	}

	//load up EQW
	eval_pv(
		"package EQW;"
		"&boot_EQW;"			//load our EQW XS
		"package EQDB;"
		"&boot_EQDB;"			//load our EQW XS
		"package EQDBRes;"
		"&boot_EQDBRes;"			//load our EQW XS
		"package HTTPRequest;"
		"&boot_HTTPRequest;"			//load our HTTPRequest XS
		"package EQLConfig;"
		"&boot_EQLConfig;"			//load our EQLConfig XS
	, FALSE );


#ifdef EMBPERL_PLUGIN
	Log.Out(Logs::Detail, Logs::World_Server, "Loading worldui perl plugins.");
	std::string err;
	if(!eval_file("world", "worldui.pl", err)) {
		Log.Out(Logs::Detail, Logs::World_Server, "Warning - world.pl: %s", err.c_str());
	}

	eval_pv(
		"package world; "
		"if(opendir(D,'worldui')) { "
		"	my @d = readdir(D);"
		"	closedir(D);"
		"	foreach(@d){ "
		"		next unless(/\\.pl$); "
		"		require 'templates/'.$_;"
		"	}"
		"}"
	,FALSE);
#endif //EMBPERL_PLUGIN
}
예제 #4
0
void Embperl::DoInit() {
	char **argv = (char **)argv_eqemu;
	char **env = { nullptr };
	my_perl = perl_alloc();
	//setup perl...
	if(!my_perl)
		throw "Failed to init Perl (perl_alloc)";
	PERL_SET_CONTEXT(my_perl);
	PERL_SET_INTERP(my_perl);
	PL_perl_destruct_level = 1;
	perl_construct(my_perl);
	perl_parse(my_perl, xs_init, argc, argv, nullptr);
	perl_run(my_perl);

	//a little routine we use a lot.
	eval_pv("sub my_eval {eval $_[0];}", TRUE);	//dies on error

	//ruin the perl exit and command:
	eval_pv("sub my_exit {}",TRUE);
	eval_pv("sub my_sleep {}",TRUE);
	if(gv_stashpv("CORE::GLOBAL", FALSE)) {
		GV *exitgp = gv_fetchpv("CORE::GLOBAL::exit", TRUE, SVt_PVCV);
		GvCV_set(exitgp, perl_get_cv("my_exit", TRUE));	//dies on error
		GvIMPORTED_CV_on(exitgp);
		GV *sleepgp = gv_fetchpv("CORE::GLOBAL::sleep", TRUE, SVt_PVCV);
		GvCV_set(sleepgp, perl_get_cv("my_sleep", TRUE));	//dies on error
		GvIMPORTED_CV_on(sleepgp);
	}

	//declare our file eval routine.
	try {
		init_eval_file();
	}
	catch(const char *err)
	{
		//remember... lasterr() is no good if we crap out here, in construction
		Log.Out(Logs::General, Logs::Quests, "perl error: %s", err);
		throw "failed to install eval_file hook";
	}

#ifdef EMBPERL_IO_CAPTURE
	Log.Out(Logs::General, Logs::Quests, "Tying perl output to eqemu logs");
	//make a tieable class to capture IO and pass it into EQEMuLog
	eval_pv(
		"package EQEmuIO; "
 			"sub TIEHANDLE { my $me = bless {}, $_[0]; $me->PRINT('Creating '.$me); return($me); } "
  			"sub WRITE {  } "
  			//dunno why I need to shift off fmt here, but it dosent like without it
  			"sub PRINTF { my $me = shift; my $fmt = shift; $me->PRINT(sprintf($fmt, @_)); } "
  			"sub CLOSE { my $me = shift; $me->PRINT('Closing '.$me); } "
  			"sub DESTROY { my $me = shift; $me->PRINT('Destroying '.$me); } "
		//this ties us for all packages, just do it in quest since thats kinda 'our' package
  		"package quest;"
  		"	if(tied *STDOUT) { untie(*STDOUT); }"
  		"	if(tied *STDERR) { untie(*STDERR); }"
  		"	tie *STDOUT, 'EQEmuIO';"
  		"	tie *STDERR, 'EQEmuIO';"
  		,FALSE);
#endif //EMBPERL_IO_CAPTURE

#ifdef EMBPERL_PLUGIN
	eval_pv(
		"package plugin; "
		,FALSE
	);

	Log.Out(Logs::General, Logs::Quests, "Loading perlemb plugins.");
	try
	{
		eval_pv("main::eval_file('plugin', 'plugin.pl');", FALSE);
	}
	catch(const char *err)
	{
		Log.Out(Logs::General, Logs::Quests, "Warning - plugin.pl: %s", err);
	}
	try
	{
		//should probably read the directory in c, instead, so that
		//I can echo filenames as I do it, but c'mon... I'm lazy and this 1 line reads in all the plugins
		eval_pv(
			"if(opendir(D,'plugins')) { "
			"	my @d = readdir(D);"
			"	closedir(D);"
			"	foreach(@d){ "
			"		main::eval_file('plugin','plugins/'.$_)if/\\.pl$/;"
			"	}"
			"}"
		,FALSE);
	}
	catch(const char *err)
	{
		Log.Out(Logs::General, Logs::Quests, "Perl warning: %s", err);
	}
#endif //EMBPERL_PLUGIN
	in_use = false;
}