comparison plugins/perl/perl.c @ 6636:452c62a92963

[gaim-migrate @ 7161] Say goodbye to perl namespace collision issues. committer: Tailor Script <[e-mail]>

6635:96c5630f8d1d

#define PERL_PLUGIN_ID "core-perl"

typedef struct
{
	GaimPlugin *plugin;
	char *load_sub;
	char *unload_sub;

} GaimPerlScript;

{
	char *file = __FILE__;

	/* This one allows dynamic loading of perl modules in perl
           scripts by the 'use perlmod;' construction*/
	newXS ("DynaLoader::boot_DynaLoader", boot_DynaLoader, file);
}


static void
perl_init(void)

		/* We use to function one to load a file the other to
		   execute the string obtained from the first and holding
		   the file conents. This allows to have a realy local $/
		   without introducing temp variables to hold the old
		   value. Just a question of style:) */
		"sub load_file{"
		  "my $f_name=shift;"
		  "local $/=undef;"
		  "open FH,$f_name or return \"__FAILED__\";"
		  "$_=<FH>;"
		  "close FH;"
		  "return $_;"
		"}"
		"sub load_n_eval{"
		  "my $f_name=shift;"
		  "my $strin=load_file($f_name);"
		  "return 2 if($strin eq \"__FAILED__\");"
		  "eval $strin;"
		  "if($@){"
		    /*"  #something went wrong\n"*/
		    "Gaim::debug(\"perl\", \"Errors loading file $f_name:\\n$@\");"
		    "return 1;"
		  "}"
		  "return 0;"
		"}"
	};

	my_perl = perl_alloc();

	(*subaddr)(aTHX_ cv);

	PUTBACK;
}

static gboolean
probe_perl_plugin(GaimPlugin *plugin)
{
	/* XXX This would be much faster if I didn't create a new
	 *     PerlInterpreter every time I probed a plugin */

			status = FALSE;
		else
		{
			GaimPluginInfo *info;
			GaimPerlScript *gps;
			int len;

			gaim_debug(GAIM_DEBUG_INFO, "perl", "Found plugin info\n");

			info = g_new0(GaimPluginInfo, 1);

			info->dependencies = g_list_append(info->dependencies,
											   PERL_PLUGIN_ID);

			gps->plugin = plugin;

			/* We know this one exists. */
			key = hv_fetch(plugin_info, "name", strlen("name"), 0);
			info->name = g_strdup(SvPV(*key, len));

			if ((key = hv_fetch(plugin_info, "version", strlen("version"), 0)))
				info->version = g_strdup(SvPV(*key, len));

			if ((key = hv_fetch(plugin_info, "load", strlen("load"), 0)))
				gps->load_sub = g_strdup(SvPV(*key, len));

			if ((key = hv_fetch(plugin_info, "unload", strlen("unload"), 0)))
				gps->unload_sub = g_strdup(SvPV(*key, len));

			plugin->info = info;
			info->extra_info = gps;

			status = gaim_plugin_register(plugin);

static gboolean
load_perl_plugin(GaimPlugin *plugin)
{
	GaimPerlScript *gps = (GaimPerlScript *)plugin->info->extra_info;
	char *atmp[2] = { plugin->path, NULL };

	if (gps == NULL || gps->load_sub == NULL)
		return FALSE;

	gaim_debug(GAIM_DEBUG_INFO, "perl", "Loading perl script\n");

	if (my_perl == NULL)
		perl_init();

	plugin->handle = plugin->path;

	execute_perl("load_n_eval", 1, atmp);

	{
		dSP;
		ENTER;
		SAVETMPS;

	}

	return TRUE;
}

static gboolean
unload_perl_plugin(GaimPlugin *plugin)
{
	GaimPerlScript *gps = (GaimPerlScript *)plugin->info->extra_info;

			gaim_debug(GAIM_DEBUG_ERROR, "perl",
					   "Perl function %s exited abnormally: %s\n",
					   gps->load_sub, SvPV(ERRSV, len));
		}


		PUTBACK;
		FREETMPS;
		LEAVE;
	}

	gaim_perl_signal_clear_for_plugin(plugin);
	gaim_perl_timeout_clear_for_plugin(plugin);

	return TRUE;
}

static void
destroy_perl_plugin(GaimPlugin *plugin)

			if (gps->load_sub != NULL)
				g_free(gps->load_sub);

			if (gps->unload_sub != NULL)
				g_free(gps->unload_sub);

			g_free(gps);
			plugin->info->extra_info = NULL;
		}
	}

6636:452c62a92963

#define PERL_PLUGIN_ID "core-perl"

typedef struct
{
	GaimPlugin *plugin;
	char *package;
	char *load_sub;
	char *unload_sub;

} GaimPerlScript;

{
	char *file = __FILE__;

	/* This one allows dynamic loading of perl modules in perl
           scripts by the 'use perlmod;' construction*/
	newXS("DynaLoader::boot_DynaLoader", boot_DynaLoader, file);
}


static void
perl_init(void)

		/* We use to function one to load a file the other to
		   execute the string obtained from the first and holding
		   the file conents. This allows to have a realy local $/
		   without introducing temp variables to hold the old
		   value. Just a question of style:) */
		"package Gaim::PerlLoader;"
		"use Symbol;"

		"sub load_file {"
		  "my $f_name=shift;"
		  "local $/=undef;"
		  "open FH,$f_name or return \"__FAILED__\";"
		  "$_=<FH>;"
		  "close FH;"
		  "return $_;"
		"}"

		"sub destroy_package {"
		  "eval { $_[0]->UNLOAD() if $_[0]->can('UNLOAD'); };"
		  "Symbol::delete_package($_[0]);"
		"}"

		"sub load_n_eval {"
		  "my ($f_name, $package) = @_;"
		  "destroy_package($package);"
		  "my $strin=load_file($f_name);"
		  "return 2 if($strin eq \"__FAILED__\");"
		  "my $eval = qq{package $package; $strin;};"

		  "{"
		  "  eval $eval;"
		  "}"

		  "if($@) {"
		    /*"  #something went wrong\n"*/
		    "die(\"Errors loading file $f_name: $@\");"
		  "}"

		  "return 0;"
		"}"
	};

	my_perl = perl_alloc();

	(*subaddr)(aTHX_ cv);

	PUTBACK;
}

static void
normalize_script_name(char *name)
{
	char *c;

	c = strrchr(name, '.');

	if (c != NULL)
		*c = '\0';

	for (c = name; *c != '\0'; c++)
	{
		if (*c == '_' && !g_ascii_isalnum(*c))
			*c = '_';
	}
}

static gboolean
probe_perl_plugin(GaimPlugin *plugin)
{
	/* XXX This would be much faster if I didn't create a new
	 *     PerlInterpreter every time I probed a plugin */

			status = FALSE;
		else
		{
			GaimPluginInfo *info;
			GaimPerlScript *gps;
			char *basename;
			int len;

			gaim_debug(GAIM_DEBUG_INFO, "perl", "Found plugin info\n");

			info = g_new0(GaimPluginInfo, 1);

			info->dependencies = g_list_append(info->dependencies,
											   PERL_PLUGIN_ID);

			gps->plugin = plugin;

			basename = g_path_get_basename(plugin->path);
			normalize_script_name(basename);
			gps->package = g_strdup_printf("Gaim::Script::%s", basename);
			g_free(basename);

			/* We know this one exists. */
			key = hv_fetch(plugin_info, "name", strlen("name"), 0);
			info->name = g_strdup(SvPV(*key, len));

			if ((key = hv_fetch(plugin_info, "version", strlen("version"), 0)))
				info->version = g_strdup(SvPV(*key, len));

			if ((key = hv_fetch(plugin_info, "load", strlen("load"), 0)))
				gps->load_sub = g_strdup_printf("%s::%s", gps->package,
												SvPV(*key, len));

			if ((key = hv_fetch(plugin_info, "unload", strlen("unload"), 0)))
				gps->unload_sub = g_strdup_printf("%s::%s", gps->package,
												  SvPV(*key, len));

			plugin->info = info;
			info->extra_info = gps;

			status = gaim_plugin_register(plugin);

static gboolean
load_perl_plugin(GaimPlugin *plugin)
{
	GaimPerlScript *gps = (GaimPerlScript *)plugin->info->extra_info;
	char *atmp[3] = { plugin->path, NULL, NULL };

	if (gps == NULL || gps->load_sub == NULL)
		return FALSE;

	gaim_debug(GAIM_DEBUG_INFO, "perl", "Loading perl script\n");

	if (my_perl == NULL)
		perl_init();

	plugin->handle = gps;

	atmp[1] = gps->package;

	execute_perl("Gaim::PerlLoader::load_n_eval", 2, atmp);

	{
		dSP;
		ENTER;
		SAVETMPS;

	}

	return TRUE;
}

static void
destroy_package(const char *package)
{
	dSP;

	ENTER;
	SAVETMPS;

	PUSHMARK(SP);
	XPUSHs(sv_2mortal(newSVpv(package, strlen(package))));
	PUTBACK;

	perl_call_pv("Gaim::PerlLoader::destroy_package",
				 G_VOID | G_EVAL | G_DISCARD);

	SPAGAIN;

	PUTBACK;
	FREETMPS;
	LEAVE;
}

static gboolean
unload_perl_plugin(GaimPlugin *plugin)
{
	GaimPerlScript *gps = (GaimPerlScript *)plugin->info->extra_info;

			gaim_debug(GAIM_DEBUG_ERROR, "perl",
					   "Perl function %s exited abnormally: %s\n",
					   gps->load_sub, SvPV(ERRSV, len));
		}

		PUTBACK;
		FREETMPS;
		LEAVE;
	}

	gaim_perl_signal_clear_for_plugin(plugin);
	gaim_perl_timeout_clear_for_plugin(plugin);

	destroy_package(gps->package);

	return TRUE;
}

static void
destroy_perl_plugin(GaimPlugin *plugin)

			if (gps->load_sub != NULL)
				g_free(gps->load_sub);

			if (gps->unload_sub != NULL)
				g_free(gps->unload_sub);

			if (gps->package != NULL)
				g_free(gps->package);

			g_free(gps);
			plugin->info->extra_info = NULL;
		}
	}