void ntop_perl_loadHost() {
char buf[64];
/* traceEvent(CONST_TRACE_INFO, "[perl] loadHost(%p)", ntop_host); */
if(perl_host) {
hv_undef(perl_host);
perl_host = NULL;
}
if(ntop_host) {
perl_host = perl_get_hv ("main::host", TRUE);
ntop_perl_loadHost_values(perl_host, ntop_host);
}
}
int handlePerlHTTPRequest(char *url) {
int perl_argc = 2, idx, found = 0;
char perl_path[256];
char * perl_argv[] = { "", NULL };
struct stat statbuf;
char *question_mark = strchr(url, '?');
PerlInterpreter *my_perl; /*** The Perl interpreter ***/
traceEvent(CONST_TRACE_WARNING, "Calling perl... [%s]", url);
if(question_mark) question_mark[0] = '\0';
for(idx=0; (!found) && (myGlobals.dataFileDirs[idx] != NULL); idx++) {
safe_snprintf(__FILE__, __LINE__, perl_path, sizeof(perl_path),
"%s/perl/%s", myGlobals.dataFileDirs[idx], url);
revertSlashIfWIN32(perl_path, 0);
if(!stat(perl_path, &statbuf)) {
/* Found */
/* traceEvent(CONST_TRACE_INFO, "[perl] [%d] Found %s", idx, perl_path); */
found = 1;
break;
} else {
/* traceEvent(CONST_TRACE_INFO, "[perl] [%d] Not found %s", idx, perl_path); */
}
}
if(!found) {
returnHTTPpageNotFound(NULL);
return(1);
}
perl_argv[1] = perl_path;
PERL_SYS_INIT(&perl_argc, &perl_argv);
if((my_perl = perl_alloc()) == NULL) {
traceEvent(CONST_TRACE_WARNING, "[perl] Not enough memory");
return(0);
}
perl_construct(my_perl);
PL_exit_flags |= PERL_EXIT_DESTRUCT_END;
perl_parse(my_perl, xs_init, perl_argc, perl_argv, (char **)NULL);
SWIG_InitializeModule(0);
if(question_mark) {
PERL_STORE_STRING(perl_get_hv("main::ENV", TRUE), "QUERY_STRING_UNESCAPED", &question_mark[1]);
}
newXS("sendString", _wrap_ntop_perl_sendString, (char*)__FILE__);
newXS("sendFile", _wrap_ntop_perl_sendFile, (char*)__FILE__);
newXS("send_http_header", _wrap_ntop_perl_send_http_header, (char*)__FILE__);
newXS("send_html_footer", _wrap_ntop_perl_send_html_footer, (char*)__FILE__);
newXS("loadHost", _wrap_ntop_perl_loadHost, (char*)__FILE__);
newXS("getFirstHost", _wrap_ntop_perl_getFirstHost, (char*)__FILE__);
newXS("getNextHost", _wrap_ntop_perl_getNextHost, (char*)__FILE__);
perl_run(my_perl);
/* Unset variables */
perl_host = NULL;
// PL_perl_destruct_level = 1;
perl_destruct(my_perl);
perl_free(my_perl);
//PERL_SYS_TERM();
return(1);
}
static gboolean
probe_perl_plugin(PurplePlugin *plugin)
{
/* XXX This would be much faster if I didn't create a new
* PerlInterpreter every time I probed a plugin */
PerlInterpreter *prober = perl_alloc();
char *argv[] = {"", plugin->path };
gboolean status = TRUE;
HV *plugin_info;
PERL_SET_CONTEXT(prober);
PL_perl_destruct_level = 1;
perl_construct(prober);
perl_parse(prober, xs_init, 2, argv, NULL);
perl_run(prober);
plugin_info = perl_get_hv("PLUGIN_INFO", FALSE);
if (plugin_info == NULL)
status = FALSE;
else if (!hv_exists(plugin_info, "perl_api_version",
strlen("perl_api_version")) ||
!hv_exists(plugin_info, "name", strlen("name")) ||
!hv_exists(plugin_info, "load", strlen("load"))) {
/* Not a valid plugin. */
status = FALSE;
} else {
SV **key;
int perl_api_ver;
key = hv_fetch(plugin_info, "perl_api_version",
strlen("perl_api_version"), 0);
perl_api_ver = SvIV(*key);
if (perl_api_ver != 2)
status = FALSE;
else {
PurplePluginInfo *info;
PurplePerlScript *gps;
char *basename;
STRLEN len;
info = g_new0(PurplePluginInfo, 1);
gps = g_new0(PurplePerlScript, 1);
info->magic = PURPLE_PLUGIN_MAGIC;
info->major_version = PURPLE_MAJOR_VERSION;
info->minor_version = PURPLE_MINOR_VERSION;
info->type = PURPLE_PLUGIN_STANDARD;
info->dependencies = g_list_append(info->dependencies,
PERL_PLUGIN_ID);
gps->plugin = plugin;
basename = g_path_get_basename(plugin->path);
purple_perl_normalize_script_name(basename);
gps->package = g_strdup_printf("Purple::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));
/* Set id here in case we don't find one later. */
info->id = g_strdup(SvPV(*key, len));
#ifdef PURPLE_GTKPERL
if ((key = hv_fetch(plugin_info, "GTK_UI",
strlen("GTK_UI"), 0)))
info->ui_requirement = PURPLE_GTK_PLUGIN_TYPE;
#endif
if ((key = hv_fetch(plugin_info, "url",
strlen("url"), 0)))
info->homepage = g_strdup(SvPV(*key, len));
if ((key = hv_fetch(plugin_info, "author",
strlen("author"), 0)))
info->author = g_strdup(SvPV(*key, len));
if ((key = hv_fetch(plugin_info, "summary",
strlen("summary"), 0)))
info->summary = g_strdup(SvPV(*key, len));
if ((key = hv_fetch(plugin_info, "description",
strlen("description"), 0)))
info->description = g_strdup(SvPV(*key, len));
if ((key = hv_fetch(plugin_info, "version",
strlen("version"), 0)))
info->version = g_strdup(SvPV(*key, len));
/* We know this one exists. */
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));
if ((key = hv_fetch(plugin_info, "id",
strlen("id"), 0))) {
g_free(info->id);
info->id = g_strdup_printf("perl-%s",
SvPV(*key, len));
}
/********************************************************/
/* Only one of the next two options should be present */
/* */
/* prefs_info - Uses non-GUI (read GTK) purple API calls */
/* and creates a PurplePluginPrefInfo type. */
/* */
/* gtk_prefs_info - Requires gtk2-perl be installed by */
/* the user and he must create a */
/* GtkWidget the user and he must */
/* create a GtkWidget representing the */
/* plugin preferences page. */
/********************************************************/
if ((key = hv_fetch(plugin_info, "prefs_info",
strlen("prefs_info"), 0))) {
/* key now is the name of the Perl sub that
* will create a frame for us */
gps->prefs_sub = g_strdup_printf("%s::%s",
gps->package,
SvPV(*key, len));
info->prefs_info = &ui_info;
}
#ifdef PURPLE_GTKPERL
if ((key = hv_fetch(plugin_info, "gtk_prefs_info",
strlen("gtk_prefs_info"), 0))) {
/* key now is the name of the Perl sub that
* will create a frame for us */
gps->gtk_prefs_sub = g_strdup_printf("%s::%s",
gps->package,
SvPV(*key, len));
info->ui_info = >k_ui_info;
}
#endif
if ((key = hv_fetch(plugin_info, "plugin_action_sub",
strlen("plugin_action_sub"), 0))) {
gps->plugin_action_sub = g_strdup_printf("%s::%s",
gps->package,
SvPV(*key, len));
info->actions = purple_perl_plugin_actions;
}
plugin->info = info;
info->extra_info = gps;
status = purple_plugin_register(plugin);
}
}
PL_perl_destruct_level = 1;
PERL_SET_CONTEXT(prober);
perl_destruct(prober);
perl_free(prober);
return status;
}