diff -r 498763742ea4 -r 1fb661b5f206 libpurple/plugins/tcl/tcl.c --- a/libpurple/plugins/tcl/tcl.c Tue Mar 08 20:31:03 2016 -0600 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,503 +0,0 @@ -/** - * @file tcl.c Purple Tcl plugin bindings - * - * purple - * - * Copyright (C) 2003 Ethan Blanton - * - * 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 - */ - -#include "config.h" - -#include - -#ifdef HAVE_TK -#include -#endif - -#include -#include -#include -#include - -#include "tcl_glib.h" -#include "tcl_purple.h" - -#include "internal.h" -#include "connection.h" -#include "plugins.h" -#include "signals.h" -#include "debug.h" -#include "util.h" -#include "version.h" - -struct tcl_plugin_data { - PurplePlugin *plugin; - Tcl_Interp *interp; -}; - -typedef struct { - char *id; - char *name; - char *version; - char *summary; - char *description; - char *author; - char *homepage; -} tcl_plugin_info_strings; - -PurpleStringref *PurpleTclRefAccount; -PurpleStringref *PurpleTclRefConnection; -PurpleStringref *PurpleTclRefConversation; -PurpleStringref *PurpleTclRefPointer; -PurpleStringref *PurpleTclRefPlugin; -PurpleStringref *PurpleTclRefPresence; -PurpleStringref *PurpleTclRefStatus; -PurpleStringref *PurpleTclRefStatusAttr; -PurpleStringref *PurpleTclRefStatusType; -PurpleStringref *PurpleTclRefXfer; -PurpleStringref *PurpleTclRefHandle; - -static GHashTable *tcl_plugins = NULL; - -PurplePlugin *_tcl_plugin; - -static gboolean tcl_loaded = FALSE; - -static void tcl_plugin_info_strings_free(tcl_plugin_info_strings *strings) -{ - if (strings == NULL) - return; - - g_free(strings->id); - g_free(strings->name); - g_free(strings->version); - g_free(strings->summary); - g_free(strings->description); - g_free(strings->author); - g_free(strings->homepage); - g_free(strings); -} - -PurplePlugin *tcl_interp_get_plugin(Tcl_Interp *interp) -{ - struct tcl_plugin_data *data; - - if (tcl_plugins == NULL) - return NULL; - - data = g_hash_table_lookup(tcl_plugins, (gpointer)interp); - return data != NULL ? data->plugin : NULL; -} - -static int tcl_init_interp(Tcl_Interp *interp) -{ - char *rcfile; - char init[] = - "namespace eval ::purple {\n" - " namespace export account buddy connection conversation\n" - " namespace export core debug notify prefs send_im\n" - " namespace export signal unload\n" - " namespace eval _callback { }\n" - "\n" - " proc conv_send { account who text } {\n" - " set gc [purple::account connection $account]\n" - " set convo [purple::conversation new $account $who]\n" - " set myalias [purple::account alias $account]\n" - "\n" - " if {![string length $myalias]} {\n" - " set myalias [purple::account username $account]\n" - " }\n" - "\n" - " purple::send_im $gc $who $text\n" - " purple::conversation write $convo send $myalias $text\n" - " }\n" - "}\n" - "\n" - "proc bgerror { message } {\n" - " global errorInfo\n" - " purple::notify -error \"Tcl Error\" \"Tcl Error: $message\" \"$errorInfo\"\n" - "}\n"; - - if (Tcl_EvalEx(interp, init, -1, TCL_EVAL_GLOBAL) != TCL_OK) { - return 1; - } - - Tcl_SetVar(interp, "argc", "0", TCL_GLOBAL_ONLY); - Tcl_SetVar(interp, "argv0", "purple", TCL_GLOBAL_ONLY); - Tcl_SetVar(interp, "tcl_interactive", "0", TCL_GLOBAL_ONLY); - rcfile = g_strdup_printf("%s" G_DIR_SEPARATOR_S "tclrc", purple_user_dir()); - Tcl_SetVar(interp, "tcl_rcFileName", rcfile, TCL_GLOBAL_ONLY); - g_free(rcfile); - - Tcl_SetVar(interp, "::purple::version", VERSION, TCL_GLOBAL_ONLY); - Tcl_SetVar(interp, "::purple::user_dir", purple_user_dir(), TCL_GLOBAL_ONLY); -#ifdef HAVE_TK - Tcl_SetVar(interp, "::purple::tk_available", "1", TCL_GLOBAL_ONLY); -#else - Tcl_SetVar(interp, "::purple::tk_available", "0", TCL_GLOBAL_ONLY); -#endif /* HAVE_TK */ - - Tcl_CreateObjCommand(interp, "::purple::account", tcl_cmd_account, (ClientData)NULL, NULL); - Tcl_CreateObjCommand(interp, "::purple::buddy", tcl_cmd_buddy, (ClientData)NULL, NULL); - Tcl_CreateObjCommand(interp, "::purple::cmd", tcl_cmd_cmd, (ClientData)NULL, NULL); - Tcl_CreateObjCommand(interp, "::purple::connection", tcl_cmd_connection, (ClientData)NULL, NULL); - Tcl_CreateObjCommand(interp, "::purple::conversation", tcl_cmd_conversation, (ClientData)NULL, NULL); - Tcl_CreateObjCommand(interp, "::purple::core", tcl_cmd_core, (ClientData)NULL, NULL); - Tcl_CreateObjCommand(interp, "::purple::debug", tcl_cmd_debug, (ClientData)NULL, NULL); - Tcl_CreateObjCommand(interp, "::purple::notify", tcl_cmd_notify, (ClientData)NULL, NULL); - Tcl_CreateObjCommand(interp, "::purple::plugins", tcl_cmd_plugins, (ClientData)NULL, NULL); - Tcl_CreateObjCommand(interp, "::purple::prefs", tcl_cmd_prefs, (ClientData)NULL, NULL); - Tcl_CreateObjCommand(interp, "::purple::presence", tcl_cmd_presence, (ClientData)NULL, NULL); - Tcl_CreateObjCommand(interp, "::purple::send_im", tcl_cmd_send_im, (ClientData)NULL, NULL); - Tcl_CreateObjCommand(interp, "::purple::savedstatus", tcl_cmd_savedstatus, (ClientData)NULL, NULL); - Tcl_CreateObjCommand(interp, "::purple::signal", tcl_cmd_signal, (ClientData)NULL, NULL); - Tcl_CreateObjCommand(interp, "::purple::status", tcl_cmd_status, (ClientData)NULL, NULL); - Tcl_CreateObjCommand(interp, "::purple::status_attr", tcl_cmd_status_attr, (ClientData)NULL, NULL); - Tcl_CreateObjCommand(interp, "::purple::status_type", tcl_cmd_status_type, (ClientData)NULL, NULL); - Tcl_CreateObjCommand(interp, "::purple::unload", tcl_cmd_unload, (ClientData)NULL, NULL); - - return 0; -} - -static Tcl_Interp *tcl_create_interp(void) -{ - Tcl_Interp *interp; - - interp = Tcl_CreateInterp(); - if (Tcl_Init(interp) == TCL_ERROR) { - Tcl_DeleteInterp(interp); - return NULL; - } - - if (tcl_init_interp(interp)) { - Tcl_DeleteInterp(interp); - return NULL; - } - Tcl_StaticPackage(interp, "purple", tcl_init_interp, NULL); - - return interp; -} - -static gboolean tcl_probe_plugin(PurplePlugin *plugin) -{ - PurplePluginInfo *info; - Tcl_Interp *interp; - Tcl_Parse parse; - Tcl_Obj *result, **listitems; - char *buf; - const char *next; - int found = 0, err = 0, nelems; - gsize len; - gboolean status = FALSE; - - if (!g_file_get_contents(plugin->path, &buf, &len, NULL)) { - purple_debug(PURPLE_DEBUG_INFO, "tcl", "Error opening plugin %s\n", - plugin->path); - return FALSE; - } - - if ((interp = tcl_create_interp()) == NULL) { - return FALSE; - } - - next = buf; - do { - if (Tcl_ParseCommand(interp, next, len, 0, &parse) == TCL_ERROR) { - purple_debug(PURPLE_DEBUG_ERROR, "tcl", "parse error in %s: %s\n", plugin->path, - Tcl_GetString(Tcl_GetObjResult(interp))); - err = 1; - break; - } - if (parse.tokenPtr[0].type == TCL_TOKEN_SIMPLE_WORD - && !strncmp(parse.tokenPtr[0].start, "proc", parse.tokenPtr[0].size)) { - if (!strncmp(parse.tokenPtr[2].start, "plugin_init", parse.tokenPtr[2].size)) { - if (Tcl_EvalEx(interp, parse.commandStart, parse.commandSize, TCL_EVAL_GLOBAL) != TCL_OK) { - Tcl_FreeParse(&parse); - break; - } - found = 1; - /* We'll continue parsing the file, just in case */ - } - } - len -= (parse.commandStart + parse.commandSize) - next; - next = parse.commandStart + parse.commandSize; - Tcl_FreeParse(&parse); - } while (len); - - if (found && !err) { - if (Tcl_EvalEx(interp, "plugin_init", -1, TCL_EVAL_GLOBAL) == TCL_OK) { - result = Tcl_GetObjResult(interp); - if (Tcl_ListObjGetElements(interp, result, &nelems, &listitems) == TCL_OK) { - if ((nelems == 6) || (nelems == 7)) { - tcl_plugin_info_strings *strings = g_new0(tcl_plugin_info_strings, 1); - info = g_new0(PurplePluginInfo, 1); - info->extra_info = strings; - - 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, "core-tcl"); - - info->name = strings->name = g_strdup(Tcl_GetString(listitems[0])); - info->version = strings->version = g_strdup(Tcl_GetString(listitems[1])); - info->summary = strings->summary = g_strdup(Tcl_GetString(listitems[2])); - info->description = strings->description = g_strdup(Tcl_GetString(listitems[3])); - info->author = strings->author = g_strdup(Tcl_GetString(listitems[4])); - info->homepage = strings->homepage = g_strdup(Tcl_GetString(listitems[5])); - - if (nelems == 6) - info->id = strings->id = g_strdup_printf("tcl-%s", Tcl_GetString(listitems[0])); - else if (nelems == 7) - info->id = strings->id = g_strdup_printf("tcl-%s", Tcl_GetString(listitems[6])); - - plugin->info = info; - - if (purple_plugin_register(plugin)) - status = TRUE; - } - } - } - } - - Tcl_DeleteInterp(interp); - g_free(buf); - return status; -} - -static gboolean tcl_load_plugin(PurplePlugin *plugin) -{ - struct tcl_plugin_data *data; - Tcl_Interp *interp; - Tcl_Obj *result; - - plugin->extra = NULL; - - if ((interp = tcl_create_interp()) == NULL) { - purple_debug(PURPLE_DEBUG_ERROR, "tcl", "Could not initialize Tcl interpreter\n"); - return FALSE; - } - - Tcl_SourceRCFile(interp); - - if (Tcl_EvalFile(interp, plugin->path) != TCL_OK) { - result = Tcl_GetObjResult(interp); - purple_debug(PURPLE_DEBUG_ERROR, "tcl", - "Error evaluating %s: %s\n", plugin->path, - Tcl_GetString(result)); - Tcl_DeleteInterp(interp); - return FALSE; - } - - Tcl_Preserve((ClientData)interp); - - data = g_new0(struct tcl_plugin_data, 1); - data->plugin = plugin; - data->interp = interp; - plugin->extra = data; - - g_hash_table_insert(tcl_plugins, (gpointer)interp, (gpointer)data); - - return TRUE; -} - -static gboolean tcl_unload_plugin(PurplePlugin *plugin) -{ - struct tcl_plugin_data *data; - - if (plugin == NULL) - return TRUE; - - data = plugin->extra; - - if (data != NULL) { - g_hash_table_remove(tcl_plugins, (gpointer)(data->interp)); - purple_signals_disconnect_by_handle(data->interp); - tcl_cmd_cleanup(data->interp); - tcl_signal_cleanup(data->interp); - Tcl_Release((ClientData)data->interp); - Tcl_DeleteInterp(data->interp); - g_free(data); - } - - return TRUE; -} - -static void tcl_destroy_plugin(PurplePlugin *plugin) -{ - if (plugin->info != NULL) { - tcl_plugin_info_strings *info_strings = plugin->info->extra_info; - tcl_plugin_info_strings_free(info_strings); - plugin->info->extra_info = NULL; - } - - return; -} - -static PurplePluginLoaderInfo tcl_loader_info = -{ - tcl_probe_plugin, - tcl_load_plugin, - tcl_unload_plugin, - tcl_destroy_plugin, -}; - -static GPluginPluginInfo * -tcl_query(GError **error) -{ - const gchar * const authors[] = { - "Ethan Blanton ", - NULL - }; - - return gplugin_plugin_info_new( - "id", "core-tcl", - "name", N_("Tcl Plugin Loader"), - "version", DISPLAY_VERSION, - "category", N_("Loader"), - "summary", N_("Provides support for loading Tcl plugins"), - "description", N_("Provides support for loading Tcl plugins"), - "authors", authors, - "website", PURPLE_WEBSITE, - "abi-version", PURPLE_ABI_VERSION, - "internal", TRUE, - "load-on-query", TRUE, - NULL - ); -} - -static gboolean tcl_load(PurplePlugin *plugin, GError **error) -{ - if(!tcl_loaded) - return FALSE; - tcl_glib_init(); - tcl_cmd_init(); - tcl_signal_init(); - purple_tcl_ref_init(); - - PurpleTclRefAccount = purple_stringref_new("Account"); - PurpleTclRefConnection = purple_stringref_new("Connection"); - PurpleTclRefConversation = purple_stringref_new("Conversation"); - PurpleTclRefPointer = purple_stringref_new("Pointer"); - PurpleTclRefPlugin = purple_stringref_new("Plugin"); - PurpleTclRefPresence = purple_stringref_new("Presence"); - PurpleTclRefStatus = purple_stringref_new("Status"); - PurpleTclRefStatusAttr = purple_stringref_new("StatusAttr"); - PurpleTclRefStatusType = purple_stringref_new("StatusType"); - PurpleTclRefXfer = purple_stringref_new("Xfer"); - PurpleTclRefHandle = purple_stringref_new("Handle"); - - tcl_plugins = g_hash_table_new(g_direct_hash, g_direct_equal); - -#ifdef HAVE_TK - Tcl_StaticPackage(NULL, "Tk", Tk_Init, Tk_SafeInit); -#endif /* HAVE_TK */ - - return TRUE; -} - -static gboolean tcl_unload(PurplePlugin *plugin, GError **error) -{ - g_hash_table_destroy(tcl_plugins); - tcl_plugins = NULL; - - purple_stringref_unref(PurpleTclRefAccount); - purple_stringref_unref(PurpleTclRefConnection); - purple_stringref_unref(PurpleTclRefConversation); - purple_stringref_unref(PurpleTclRefPointer); - purple_stringref_unref(PurpleTclRefPlugin); - purple_stringref_unref(PurpleTclRefPresence); - purple_stringref_unref(PurpleTclRefStatus); - purple_stringref_unref(PurpleTclRefStatusAttr); - purple_stringref_unref(PurpleTclRefStatusType); - purple_stringref_unref(PurpleTclRefXfer); - - return TRUE; -} - -#ifdef _WIN32 -typedef Tcl_Interp* (__cdecl* LPFNTCLCREATEINTERP)(void); -typedef void (__cdecl* LPFNTKINIT)(Tcl_Interp*); - -LPFNTCLCREATEINTERP wtcl_CreateInterp = NULL; -LPFNTKINIT wtk_Init = NULL; -#undef Tcl_CreateInterp -#define Tcl_CreateInterp wtcl_CreateInterp -#undef Tk_Init -#define Tk_Init wtk_Init - -static gboolean tcl_win32_init() { - gboolean retval = FALSE; - - if(!(wtcl_CreateInterp = (LPFNTCLCREATEINTERP) wpurple_find_and_loadproc("tcl85.dll", "Tcl_CreateInterp"))) { - purple_debug(PURPLE_DEBUG_INFO, "tcl", "tcl_win32_init error loading Tcl_CreateInterp\n"); - } else { - if(!(wtk_Init = (LPFNTKINIT) wpurple_find_and_loadproc("tk85.dll", "Tk_Init"))) { - HMODULE mod; - purple_debug(PURPLE_DEBUG_INFO, "tcl", "tcl_win32_init error loading Tk_Init\n"); - if((mod = GetModuleHandle("tcl85.dll"))) - FreeLibrary(mod); - } else { - retval = TRUE; - } - } - - return retval; -} - -#endif /* _WIN32 */ - -static void tcl_init_plugin(PurplePlugin *plugin) -{ -#ifdef USE_TCL_STUBS - Tcl_Interp *interp = NULL; -#endif - _tcl_plugin = plugin; - -#ifdef USE_TCL_STUBS -#ifdef _WIN32 - if(!tcl_win32_init()) - return; -#endif - if(!(interp = Tcl_CreateInterp())) - return; - - if(!Tcl_InitStubs(interp, TCL_VERSION, 0)) { - purple_debug(PURPLE_DEBUG_ERROR, "tcl", "Tcl_InitStubs: %s\n", interp->result); - return; - } -#endif - - Tcl_FindExecutable("purple"); - -#if defined(USE_TK_STUBS) && defined(HAVE_TK) - Tk_Init(interp); - - if(!Tk_InitStubs(interp, TK_VERSION, 0)) { - purple_debug(PURPLE_DEBUG_ERROR, "tcl", "Error Tk_InitStubs: %s\n", interp->result); - Tcl_DeleteInterp(interp); - return; - } -#endif - tcl_loaded = TRUE; -#ifdef USE_TCL_STUBS - Tcl_DeleteInterp(interp); -#endif - tcl_loader_info.exts = g_list_append(tcl_loader_info.exts, "tcl"); -} - -PURPLE_PLUGIN_INIT(tcl, tcl_query, tcl_load, tcl_unload);