* Copyright (C) 2003 Christian Hammond <chipx86@gnupdate.org> * This program is free software; you can redistribute it and/or modify * it under the terms of the GNU General Public License as published by * the Free Software Foundation; either version 2 of the License, or * (at your option) any later version. * This program is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU General Public License for more details. * You should have received a copy of the GNU General Public License * along with this program; if not, write to the Free Software * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02111-1301 USA # define NAME_MAX _POSIX_NAME_MAX /* This took me an age to figure out.. without this __declspec(dllimport) #ifndef _SEM_SEMUN_UNDEFINED /* We're using perl's win32 port of this */ /* perl module support */ EXTERN_C void boot_Win32CORE (pTHX_ CV* cv); extern void boot_DynaLoader _((CV * cv)); extern void boot_DynaLoader _((pTHX_ CV * cv)); /* perl is so wacky */ #include "perl-handlers.h" #define PERL_PLUGIN_ID "core-perl" PerlInterpreter *my_perl = NULL; static PurplePluginUiInfo ui_info = purple_perl_get_plugin_frame, 0, /* page_num (Reserved) */ NULL, /* frame (Reserved) */ static PurpleGtkPluginUiInfo gtk_ui_info = purple_perl_gtk_get_plugin_frame, 0 /* page_num (Reserved) */ GList *search_paths = purple_plugins_get_search_paths(); /* This one allows dynamic loading of perl modules in perl scripts by * the 'use perlmod;' construction */ newXS("DynaLoader::boot_DynaLoader", boot_DynaLoader, file); newXS("Win32CORE::bootstrap", boot_Win32CORE, file); while (search_paths != NULL) { const gchar *search_path = search_paths->data; search_paths = g_list_next(search_paths); uselib = g_strdup_printf("unshift @INC, q(%s%sperl);", search_path, G_DIR_SEPARATOR_S); /* changed the name of the variable from load_file to perl_definitions * since now it does much more than defining the load_file sub. * Moreover, deplaced the initialisation to the xs_init function. char *perl_args[] = { "", "-e", "0", "-w" }; char perl_definitions[] = /* We use to function one to load a file the other to execute * the string obtained from the first and holding the file * contents. This allows to have a really local $/ without * introducing temp variables to hold the old value. Just a "package Purple::PerlLoader;" "open FH,$f_name or return \"__FAILED__\";" "eval { $_[0]->UNLOAD() if $_[0]->can('UNLOAD'); };" "Symbol::delete_package($_[0]);" "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;};" /*" #something went wrong\n"*/ "die(\"Errors loading file $f_name: $@\");" PERL_SET_CONTEXT(my_perl); PL_perl_destruct_level = 1; perl_parse(my_perl, xs_init, 4, perl_args, NULL); perl_parse(my_perl, xs_init, 3, perl_args, NULL); eval_pv(perl_definitions, TRUE); perl_eval_pv(perl_definitions, TRUE); /* deprecated */ PL_perl_destruct_level = 1; PERL_SET_CONTEXT(my_perl); "foreach my $lib (@DynaLoader::dl_modules) {" "if ($lib =~ /^Purple\\b/) {" PL_perl_destruct_level = 1; PERL_SET_CONTEXT(my_perl); purple_perl_callXS(void (*subaddr)(pTHX_ CV *cv), CV *cv, SV **mark) probe_perl_plugin(PurplePlugin *plugin) char *args[] = {"", plugin->path }; PERL_SYS_INIT(&argc, &argv); /* XXX This would be much faster if we didn't create a new * PerlInterpreter every time we probe a plugin */ PERL_SET_CONTEXT(prober); PL_perl_destruct_level = 1; /* Fix IO redirection to match where pidgin's is going. * Without this, we lose stdout/stderr unless we redirect to a file */ PerlIO* newprlIO = PerlIO_open("CONOUT$", "w"); int stdout_fd = PerlIO_fileno(PerlIO_stdout()); int stderr_fd = PerlIO_fileno(PerlIO_stderr()); PerlIO_close(PerlIO_stdout()); PerlIO_close(PerlIO_stderr()); PerlLIO_dup2(PerlIO_fileno(newprlIO), stdout_fd); PerlLIO_dup2(PerlIO_fileno(newprlIO), stderr_fd); ret = perl_parse(prober, xs_init, argc, argv, NULL); const char * errmsg = "Unknown error"; errmsg = SvPVutf8_nolen(ERRSV); purple_debug_error("perl", "Unable to parse plugin %s (%d:%s)\n", plugin->path, ret, errmsg); const char * errmsg = "Unknown error"; errmsg = SvPVutf8_nolen(ERRSV); purple_debug_error("perl", "Unable to run perl interpreter on plugin %s (%d:%s)\n", plugin->path, ret, errmsg); plugin_info = perl_get_hv("PLUGIN_INFO", 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. */ key = hv_fetch(plugin_info, "perl_api_version", strlen("perl_api_version"), 0); perl_api_ver = SvIV(*key); 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, basename = g_path_get_basename(plugin->path); purple_perl_normalize_script_name(basename); gps->package = g_strdup_printf("Purple::Script::%s", /* We know this one exists. */ key = hv_fetch(plugin_info, "name", strlen("name"), 0); info->name = g_strdup(SvPVutf8_nolen(*key)); /* Set id here in case we don't find one later. */ info->id = g_strdup(info->name); if ((key = hv_fetch(plugin_info, "GTK_UI", info->ui_requirement = PURPLE_GTK_PLUGIN_TYPE; if ((key = hv_fetch(plugin_info, "url", info->homepage = g_strdup(SvPVutf8_nolen(*key)); if ((key = hv_fetch(plugin_info, "author", info->author = g_strdup(SvPVutf8_nolen(*key)); if ((key = hv_fetch(plugin_info, "summary", info->summary = g_strdup(SvPVutf8_nolen(*key)); if ((key = hv_fetch(plugin_info, "description", strlen("description"), 0))) info->description = g_strdup(SvPVutf8_nolen(*key)); if ((key = hv_fetch(plugin_info, "version", info->version = g_strdup(SvPVutf8_nolen(*key)); /* We know this one exists. */ key = hv_fetch(plugin_info, "load", strlen("load"), 0); gps->load_sub = g_strdup_printf("%s::%s", gps->package, if ((key = hv_fetch(plugin_info, "unload", gps->unload_sub = g_strdup_printf("%s::%s", if ((key = hv_fetch(plugin_info, "id", info->id = g_strdup_printf("perl-%s", /********************************************************/ /* 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", info->prefs_info = &ui_info; 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", info->ui_info = >k_ui_info; if ((key = hv_fetch(plugin_info, "plugin_action_sub", strlen("plugin_action_sub"), 0))) { gps->plugin_action_sub = g_strdup_printf("%s::%s", info->actions = purple_perl_plugin_actions; status = purple_plugin_register(plugin); PL_perl_destruct_level = 1; PERL_SET_CONTEXT(prober); load_perl_plugin(PurplePlugin *plugin) PurplePerlScript *gps = (PurplePerlScript *)plugin->info->extra_info; char *atmp[3] = { plugin->path, NULL, NULL }; if (gps == NULL || gps->load_sub == NULL) purple_debug(PURPLE_DEBUG_INFO, "perl", "Loading perl script\n"); PERL_SET_CONTEXT(my_perl); execute_perl("Purple::PerlLoader::load_n_eval", 2, atmp); PERL_SET_CONTEXT(my_perl); XPUSHs(sv_2mortal(purple_perl_bless_object(plugin, perl_call_pv(gps->load_sub, G_EVAL | G_SCALAR); purple_debug(PURPLE_DEBUG_ERROR, "perl", "Perl function %s exited abnormally: %s\n", gps->load_sub, SvPVutf8_nolen(ERRSV)); destroy_package(const char *package) PERL_SET_CONTEXT(my_perl); XPUSHs(sv_2mortal(newSVpv(package, 0))); perl_call_pv("Purple::PerlLoader::destroy_package", G_VOID | G_EVAL | G_DISCARD); unload_perl_plugin(PurplePlugin *plugin) PurplePerlScript *gps = (PurplePerlScript *)plugin->info->extra_info; purple_debug(PURPLE_DEBUG_INFO, "perl", "Unloading perl script\n"); if (gps->unload_sub != NULL) { PERL_SET_CONTEXT(my_perl); XPUSHs(sv_2mortal(purple_perl_bless_object(plugin, perl_call_pv(gps->unload_sub, G_EVAL | G_SCALAR); purple_debug(PURPLE_DEBUG_ERROR, "perl", "Perl function %s exited abnormally: %s\n", gps->unload_sub, SvPVutf8_nolen(ERRSV)); purple_perl_cmd_clear_for_plugin(plugin); purple_perl_signal_clear_for_plugin(plugin); purple_perl_timeout_clear_for_plugin(plugin); purple_perl_pref_cb_clear_for_plugin(plugin); destroy_package(gps->package); destroy_perl_plugin(PurplePlugin *plugin) if (plugin->info != NULL) { g_free(plugin->info->name); g_free(plugin->info->id); g_free(plugin->info->homepage); g_free(plugin->info->author); g_free(plugin->info->summary); g_free(plugin->info->description); g_free(plugin->info->version); gps = (PurplePerlScript *)plugin->info->extra_info; g_free(gps->gtk_prefs_sub); g_free(gps->plugin_action_sub); plugin->info->extra_info = NULL; plugin_load(PurplePlugin *plugin) plugin_unload(PurplePlugin *plugin) static PurplePluginLoaderInfo loader_info = probe_perl_plugin, /**< probe */ load_perl_plugin, /**< load */ unload_perl_plugin, /**< unload */ destroy_perl_plugin, /**< destroy */ static PurplePluginInfo info = PURPLE_PLUGIN_LOADER, /**< type */ NULL, /**< ui_requirement */ NULL, /**< dependencies */ PURPLE_PRIORITY_DEFAULT, /**< priority */ PERL_PLUGIN_ID, /**< id */ N_("Perl Plugin Loader"), /**< name */ DISPLAY_VERSION, /**< version */ N_("Provides support for loading perl plugins."), /**< summary */ N_("Provides support for loading perl plugins."), /**< description */ "Christian Hammond <chipx86@gnupdate.org>", /**< author */ PURPLE_WEBSITE, /**< homepage */ plugin_load, /**< load */ plugin_unload, /**< unload */ &loader_info, /**< extra_info */ init_plugin(PurplePlugin *plugin) loader_info.exts = g_list_append(loader_info.exts, "pl"); void __attribute__ ((constructor)) my_init(void); /* Mostly evil hack... puts perl.so's symbols in the global table but * does not create a circular dependency because g_module_open will * only open the library once. */ /* Do we need to keep track of the returned GModule here so that we * can g_module_close it when this plugin gets unloaded? * At the moment I don't think this plugin can ever get unloaded but * in case that becomes possible this wants to get noted. */ g_module_open("perl.so", 0); PURPLE_INIT_PLUGIN(perl, init_plugin, info)