コード例 #1
0
ファイル: perl.c プロジェクト: GabrielDiniz/FluxNetControl
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);
  }
}
コード例 #2
0
ファイル: perl.c プロジェクト: GabrielDiniz/FluxNetControl
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);
}
コード例 #3
0
ファイル: perl.c プロジェクト: arminius2/apolloim
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 = &gtk_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;
}