--- a/libpurple/plugins/tcl/Makefile.am Tue Mar 08 20:31:03 2016 -0600
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,23 +0,0 @@
-plugindir = @PURPLE_PLUGINDIR@-tcl_la_LDFLAGS = -module @PLUGIN_LDFLAGS@-plugin_LTLIBRARIES = tcl.la-tcl_la_SOURCES = tcl.c tcl_glib.c tcl_glib.h tcl_cmds.c tcl_signals.c tcl_purple.h \-tcl_la_LIBADD = @PURPLE_LIBS@ $(GPLUGIN_LIBS) $(TCL_LIBS) $(TK_LIBS)-EXTRA_DIST = signal-test.tcl Makefile.mingw- -I$(top_srcdir)/libpurple \- -I$(top_builddir)/libpurple \--- a/libpurple/plugins/tcl/Makefile.mingw Tue Mar 08 20:31:03 2016 -0600
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,78 +0,0 @@
-# Description: Makefile for tcl plugin loader plugin.-PIDGIN_TREE_TOP := ../../..-include $(PIDGIN_TREE_TOP)/libpurple/win32/global.mak-TCL_INC_DIR := $(TCL_LIB_TOP)/include-DEFINES += -DHAVE_TK -DUSE_TCL_STUBS -DUSE_TK_STUBS- -I$(PURPLE_TOP)/win32 \- -I$(GTK_TOP)/include/glib-2.0 \- -I$(GTK_TOP)/lib/glib-2.0/include \-LIB_PATHS += -L$(GTK_TOP)/lib \-OBJECTS = $(C_SRC:%.c=%.o)-include $(PIDGIN_COMMON_RULES)-.PHONY: all install clean-install: all $(PURPLE_INSTALL_PLUGINS_DIR)- cp $(TARGET).dll $(PURPLE_INSTALL_PLUGINS_DIR)-$(OBJECTS): $(PURPLE_CONFIG_H)-$(TARGET).dll: $(PURPLE_DLL).a $(OBJECTS)- $(CC) -shared $(OBJECTS) $(LIB_PATHS) $(LIBS) $(DLL_LD_FLAGS) -o $(TARGET).dll-include $(PIDGIN_COMMON_TARGETS)--- a/libpurple/plugins/tcl/signal-test.tcl Tue Mar 08 20:31:03 2016 -0600
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,123 +0,0 @@
-purple::signal connect [purple::account handle] account-away { account state message } {- purple::debug -info "tcl signal" "account-away [purple::account username $account] \"$state\" \"$message\""-purple::signal connect [purple::account handle] account-connecting { account } {- purple::debug -info "tcl signal" "account-connecting [purple::account username $account]"-purple::signal connect [purple::account handle] account-set-info { account info } {- purple::debug -info "tcl signal" "account-set-info [purple::account username $account] $info"-purple::signal connect [purple::account handle] account-setting-info { account info } {- purple::debug -info "tcl signal" "account-set-info [purple::account username $account] $info"-purple::signal connect [purple::buddy handle] buddy-away { buddy } {- purple::debug -info "tcl signal" "buddy-away [purple::account username [lindex $buddy 2]] [lindex $buddy 1]"-purple::signal connect [purple::buddy handle] buddy-back { buddy } {- purple::debug -info "tcl signal" "buddy-back [purple::account username [lindex $buddy 2]] [lindex $buddy 1]"-purple::signal connect [purple::buddy handle] buddy-idle { buddy } {- purple::debug -info "tcl signal" "buddy-idle [purple::account username [lindex $buddy 2]] [lindex $buddy 1]"-purple::signal connect [purple::buddy handle] buddy-unidle { buddy } {- purple::debug -info "tcl signal" "buddy-unidle [purple::account username [lindex $buddy 2]] [lindex $buddy 1]"-purple::signal connect [purple::buddy handle] buddy-signed-on { buddy } {- purple::debug -info "tcl signal" "buddy-signed-on [purple::account username [lindex $buddy 2]] [lindex $buddy 1]"-purple::signal connect [purple::buddy handle] buddy-signed-off { buddy } {- purple::debug -info "tcl signal" "buddy-signed-off [purple::account username [lindex $buddy 2]] [lindex $buddy 1]"-purple::signal connect [purple::core handle] quitting {} {- purple::debug -info "tcl signal" "quitting"-purple::signal connect [purple::conversation handle] receiving-chat-msg { account who what id flags } {- purple::debug -info "tcl signal" "receiving-chat-msg [purple::account username $account] $id $flags $who \"$what\""-purple::signal connect [purple::conversation handle] receiving-im-msg { account who what id flags } {- purple::debug -info "tcl signal" "receiving-im-msg [purple::account username $account] $id $flags $who \"$what\""-purple::signal connect [purple::conversation handle] received-chat-msg { account who what id flags } {- purple::debug -info "tcl signal" "received-chat-msg [purple::account username $account] $id $flags $who \"$what\""-purple::signal connect [purple::conversation handle] received-im-msg { account who what id flags } {- purple::debug -info "tcl signal" "received-im-msg [purple::account username $account] $id $flags $who \"$what\""-purple::signal connect [purple::conversation handle] sending-chat-msg { account what id } {- purple::debug -info "tcl signal" "sending-chat-msg [purple::account username $account] $id \"$what\""-purple::signal connect [purple::conversation handle] sending-im-msg { account who what } {- purple::debug -info "tcl signal" "sending-im-msg [purple::account username $account] $who \"$what\""-purple::signal connect [purple::conversation handle] sent-chat-msg { account id what } {- purple::debug -info "tcl signal" "sent-chat-msg [purple::account username $account] $id \"$what\""-purple::signal connect [purple::conversation handle] sent-im-msg { account who what } {- purple::debug -info "tcl signal" "sent-im-msg [purple::account username $account] $who \"$what\""-purple::signal connect [purple::connection handle] signed-on { gc } {- purple::debug -info "tcl signal" "signed-on [purple::account username [purple::connection account $gc]]"-purple::signal connect [purple::connection handle] signed-off { gc } {- purple::debug -info "tcl signal" "signed-off [purple::account username [purple::connection account $gc]]"-purple::signal connect [purple::connection handle] signing-on { gc } {- purple::debug -info "tcl signal" "signing-on [purple::account username [purple::connection account $gc]]"-purple::signal connect signing-off {- purple::debug -info "tcl signal" "signing-off [purple::account username [purple::connection account $event::gc]]"-purple::signal connect update-idle {- purple::debug -info "tcl signal" "update-idle"-purple::signal connect [purple::plugins handle] plugin-load args {- purple::debug -info "tcl signal" "plugin-load [list $args]"-purple::signal connect [purple::plugins handle] plugin-unload args {- purple::debug -info "tcl signal" "plugin-unload [list $args]"-purple::signal connect [purple::savedstatus handle] savedstatus-changed args {- purple::debug -info "tcl signal" "savedstatus-changed [list $args]"- purple::debug -info "tcl signal" "purple::savedstatus current = [purple::savedstatus current]"- list "Tcl Signal Test" \- "Tests Tcl signal handlers" \- "Debugs a ridiculous amount of signal information." \- "Ethan Blanton <elb@pidgin.im>" \--- 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- * Copyright (C) 2003 Ethan Blanton <eblanton@cs.purdue.edu>- * 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-struct tcl_plugin_data {-} 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)- g_free(strings->version);- g_free(strings->summary);- g_free(strings->description);- g_free(strings->author);- g_free(strings->homepage);-PurplePlugin *tcl_interp_get_plugin(Tcl_Interp *interp)- struct tcl_plugin_data *data;- if (tcl_plugins == NULL)- data = g_hash_table_lookup(tcl_plugins, (gpointer)interp);- return data != NULL ? data->plugin : NULL;-static int tcl_init_interp(Tcl_Interp *interp)- "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"- " 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"- " if {![string length $myalias]} {\n"- " set myalias [purple::account username $account]\n"- " purple::send_im $gc $who $text\n"- " purple::conversation write $convo send $myalias $text\n"- "proc bgerror { message } {\n"- " purple::notify -error \"Tcl Error\" \"Tcl Error: $message\" \"$errorInfo\"\n"- if (Tcl_EvalEx(interp, init, -1, TCL_EVAL_GLOBAL) != TCL_OK) {- 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);- Tcl_SetVar(interp, "::purple::version", VERSION, TCL_GLOBAL_ONLY);- Tcl_SetVar(interp, "::purple::user_dir", purple_user_dir(), TCL_GLOBAL_ONLY);- Tcl_SetVar(interp, "::purple::tk_available", "1", TCL_GLOBAL_ONLY);- Tcl_SetVar(interp, "::purple::tk_available", "0", TCL_GLOBAL_ONLY);- 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);-static Tcl_Interp *tcl_create_interp(void)- interp = Tcl_CreateInterp();- if (Tcl_Init(interp) == TCL_ERROR) {- Tcl_DeleteInterp(interp);- if (tcl_init_interp(interp)) {- Tcl_DeleteInterp(interp);- Tcl_StaticPackage(interp, "purple", tcl_init_interp, NULL);-static gboolean tcl_probe_plugin(PurplePlugin *plugin)- PurplePluginInfo *info;- Tcl_Obj *result, **listitems;- int found = 0, err = 0, nelems;- gboolean status = FALSE;- if (!g_file_get_contents(plugin->path, &buf, &len, NULL)) {- purple_debug(PURPLE_DEBUG_INFO, "tcl", "Error opening plugin %s\n",- if ((interp = tcl_create_interp()) == NULL) {- 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)));- 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) {- /* We'll continue parsing the file, just in case */- len -= (parse.commandStart + parse.commandSize) - next;- next = parse.commandStart + parse.commandSize;- 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]));- info->id = strings->id = g_strdup_printf("tcl-%s", Tcl_GetString(listitems[0]));- info->id = strings->id = g_strdup_printf("tcl-%s", Tcl_GetString(listitems[6]));- if (purple_plugin_register(plugin))- Tcl_DeleteInterp(interp);-static gboolean tcl_load_plugin(PurplePlugin *plugin)- struct tcl_plugin_data *data;- if ((interp = tcl_create_interp()) == NULL) {- purple_debug(PURPLE_DEBUG_ERROR, "tcl", "Could not initialize Tcl interpreter\n");- 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);- Tcl_Preserve((ClientData)interp);- data = g_new0(struct tcl_plugin_data, 1);- g_hash_table_insert(tcl_plugins, (gpointer)interp, (gpointer)data);-static gboolean tcl_unload_plugin(PurplePlugin *plugin)- struct tcl_plugin_data *data;- 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);-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;-static PurplePluginLoaderInfo tcl_loader_info =-static GPluginPluginInfo *-tcl_query(GError **error)- const gchar * const authors[] = {- "Ethan Blanton <eblanton@cs.purdue.edu>",- return gplugin_plugin_info_new(- "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"),- "website", PURPLE_WEBSITE,- "abi-version", PURPLE_ABI_VERSION,-static gboolean tcl_load(PurplePlugin *plugin, GError **error)- 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);- Tcl_StaticPackage(NULL, "Tk", Tk_Init, Tk_SafeInit);-static gboolean tcl_unload(PurplePlugin *plugin, GError **error)- g_hash_table_destroy(tcl_plugins);- 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);-typedef Tcl_Interp* (__cdecl* LPFNTCLCREATEINTERP)(void);-typedef void (__cdecl* LPFNTKINIT)(Tcl_Interp*);-LPFNTCLCREATEINTERP wtcl_CreateInterp = NULL;-LPFNTKINIT wtk_Init = NULL;-#define Tcl_CreateInterp wtcl_CreateInterp-#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");- if(!(wtk_Init = (LPFNTKINIT) wpurple_find_and_loadproc("tk85.dll", "Tk_Init"))) {- purple_debug(PURPLE_DEBUG_INFO, "tcl", "tcl_win32_init error loading Tk_Init\n");- if((mod = GetModuleHandle("tcl85.dll")))-static void tcl_init_plugin(PurplePlugin *plugin)- Tcl_Interp *interp = NULL;- if(!(interp = Tcl_CreateInterp()))- if(!Tcl_InitStubs(interp, TCL_VERSION, 0)) {- purple_debug(PURPLE_DEBUG_ERROR, "tcl", "Tcl_InitStubs: %s\n", interp->result);- Tcl_FindExecutable("purple");-#if defined(USE_TK_STUBS) && defined(HAVE_TK)- if(!Tk_InitStubs(interp, TK_VERSION, 0)) {- purple_debug(PURPLE_DEBUG_ERROR, "tcl", "Error Tk_InitStubs: %s\n", interp->result);- Tcl_DeleteInterp(interp);- Tcl_DeleteInterp(interp);- tcl_loader_info.exts = g_list_append(tcl_loader_info.exts, "tcl");-PURPLE_PLUGIN_INIT(tcl, tcl_query, tcl_load, tcl_unload);--- a/libpurple/plugins/tcl/tcl_cmd.c Tue Mar 08 20:31:03 2016 -0600
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,189 +0,0 @@
- * @file tcl_cmd.c Purple Tcl cmd API- * Copyright (C) 2006 Etan Reisner <deryni@gmail.com>- * 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-static GList *tcl_cmd_callbacks;-static PurpleCmdRet tcl_cmd_callback(PurpleConversation *conv, const gchar *cmd,- gchar **args, gchar **errors,- struct tcl_cmd_handler *handler);-static Tcl_Obj *new_cmd_cb_namespace(void);- tcl_cmd_callbacks = NULL;-void tcl_cmd_handler_free(struct tcl_cmd_handler *handler)- Tcl_DecrRefCount(handler->namespace);-void tcl_cmd_cleanup(Tcl_Interp *interp)- struct tcl_cmd_handler *handler;- for (cur = tcl_cmd_callbacks; cur != NULL; cur = g_list_next(cur)) {- if (handler->interp == interp) {- purple_cmd_unregister(handler->id);- tcl_cmd_handler_free(handler);- tcl_cmd_callbacks = g_list_remove_all(tcl_cmd_callbacks, NULL);-PurpleCmdId tcl_cmd_register(struct tcl_cmd_handler *handler)- if ((id = purple_cmd_register(Tcl_GetString(handler->cmd),- handler->args, handler->priority,- handler->flags, handler->protocol_id,- PURPLE_CMD_FUNC(tcl_cmd_callback),- handler->helpstr, (void *)handler)) == 0)- handler->namespace = new_cmd_cb_namespace ();- Tcl_IncrRefCount(handler->namespace);- proc = g_string_new("");- g_string_append_printf(proc, "namespace eval %s { proc cb { conv cmd arglist } { %s } }",- Tcl_GetString(handler->namespace),- Tcl_GetString(handler->proc));- if (Tcl_Eval(handler->interp, proc->str) != TCL_OK) {- Tcl_DecrRefCount(handler->namespace);- g_string_free(proc, TRUE);- g_string_free(proc, TRUE);- tcl_cmd_callbacks = g_list_append(tcl_cmd_callbacks, (gpointer)handler);-void tcl_cmd_unregister(PurpleCmdId id, Tcl_Interp *interp)- gboolean found = FALSE;- struct tcl_cmd_handler *handler;- for (cur = tcl_cmd_callbacks; cur != NULL; cur = g_list_next(cur)) {- if (handler->interp == interp && handler->id == id) {- purple_cmd_unregister(id);- cmd = g_string_sized_new(64);- g_string_printf(cmd, "namespace delete %s",- Tcl_GetString(handler->namespace));- Tcl_EvalEx(interp, cmd->str, -1, TCL_EVAL_GLOBAL);- tcl_cmd_handler_free(handler);- g_string_free(cmd, TRUE);- tcl_cmd_callbacks = g_list_remove_all(tcl_cmd_callbacks, NULL);-static PurpleCmdRet tcl_cmd_callback(PurpleConversation *conv, const gchar *cmd,- gchar **args, gchar **errors,- struct tcl_cmd_handler *handler)- Tcl_Obj *command, *arg, *tclargs, *result;- command = Tcl_NewListObj(0, NULL);- Tcl_IncrRefCount(command);- arg = Tcl_DuplicateObj(handler->namespace);- Tcl_AppendStringsToObj(arg, "::cb", NULL);- Tcl_ListObjAppendElement(handler->interp, command, arg);- arg = purple_tcl_ref_new(PurpleTclRefConversation, conv);- Tcl_ListObjAppendElement(handler->interp, command, arg);- arg = Tcl_NewStringObj(cmd, -1);- Tcl_ListObjAppendElement(handler->interp, command, arg);- tclargs = Tcl_NewListObj(0, NULL);- for (i = 0; i < handler->nargs; i++) {- arg = Tcl_NewStringObj(args[i], -1);- Tcl_ListObjAppendElement(handler->interp, tclargs, arg);- Tcl_ListObjAppendElement(handler->interp, command, tclargs);- if (Tcl_EvalObjEx(handler->interp, command, TCL_EVAL_GLOBAL) != TCL_OK) {- errorstr = g_strdup_printf("error evaluating callback: %s\n",- Tcl_GetString(Tcl_GetObjResult(handler->interp)));- purple_debug(PURPLE_DEBUG_ERROR, "tcl", "%s", errorstr);- retval = PURPLE_CMD_RET_FAILED;- result = Tcl_GetObjResult(handler->interp);- if (Tcl_GetIntFromObj(handler->interp, result,- errorstr = g_strdup_printf("Error retreiving procedure result: %s\n",- Tcl_GetString(Tcl_GetObjResult(handler->interp)));- purple_debug(PURPLE_DEBUG_ERROR, "tcl", "%s", errorstr);- retval = PURPLE_CMD_RET_FAILED;-static Tcl_Obj *new_cmd_cb_namespace()- g_snprintf(name, sizeof(name), "::purple::_cmd_callback::cb_%d",- return Tcl_NewStringObj(name, -1);--- a/libpurple/plugins/tcl/tcl_cmds.c Tue Mar 08 20:31:03 2016 -0600
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,1769 +0,0 @@
- * @file tcl_cmds.c Commands for the Purple Tcl plugin bindings- * Copyright (C) 2003 Ethan Blanton <eblanton@cs.purdue.edu>- * 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 "conversation.h"-#include "savedstatuses.h"-static PurpleAccount *tcl_validate_account(Tcl_Obj *obj, Tcl_Interp *interp);-static PurpleConversation *tcl_validate_conversation(Tcl_Obj *obj, Tcl_Interp *interp);-static PurpleConnection *tcl_validate_gc(Tcl_Obj *obj, Tcl_Interp *interp);-static PurpleAccount *tcl_validate_account(Tcl_Obj *obj, Tcl_Interp *interp)- PurpleAccount *account;- account = purple_tcl_ref_get(interp, obj, PurpleTclRefAccount);- for (cur = purple_accounts_get_all(); cur != NULL; cur = g_list_next(cur)) {- if (account == cur->data)- Tcl_SetObjResult(interp, Tcl_NewStringObj("invalid account", -1));-static PurpleConversation *tcl_validate_conversation(Tcl_Obj *obj, Tcl_Interp *interp)- PurpleConversation *convo;- convo = purple_tcl_ref_get(interp, obj, PurpleTclRefConversation);- for (cur = purple_conversations_get_all(); cur != NULL; cur = g_list_next(cur)) {- if (convo == cur->data)- Tcl_SetObjResult(interp, Tcl_NewStringObj("invalid conversation", -1));-static PurpleConnection *tcl_validate_gc(Tcl_Obj *obj, Tcl_Interp *interp)- gc = purple_tcl_ref_get(interp, obj, PurpleTclRefConnection);- for (cur = purple_connections_get_all(); cur != NULL; cur = g_list_next(cur)) {-int tcl_cmd_account(ClientData unused, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])- Tcl_Obj *result, *list, *elem;- const char *cmds[] = { "alias", "connect", "connection", "disconnect",- "enabled", "find", "handle", "isconnected",- "list", "presence", "protocol", "status",- "status_type", "status_types", "username",- enum { CMD_ACCOUNT_ALIAS,- CMD_ACCOUNT_CONNECT, CMD_ACCOUNT_CONNECTION,- CMD_ACCOUNT_DISCONNECT, CMD_ACCOUNT_ENABLED, CMD_ACCOUNT_FIND,- CMD_ACCOUNT_HANDLE, CMD_ACCOUNT_ISCONNECTED, CMD_ACCOUNT_LIST,- CMD_ACCOUNT_PRESENCE, CMD_ACCOUNT_PROTOCOL, CMD_ACCOUNT_STATUS,- CMD_ACCOUNT_STATUS_TYPE, CMD_ACCOUNT_STATUS_TYPES,- CMD_ACCOUNT_USERNAME } cmd;- const char *listopts[] = { "-all", "-online", NULL };- enum { CMD_ACCOUNTLIST_ALL, CMD_ACCOUNTLIST_ONLINE } listopt;- PurpleAccount *account;- PurpleStatusType *status_type;- Tcl_WrongNumArgs(interp, 1, objv, "subcommand ?args?");- if ((error = Tcl_GetIndexFromObj(interp, objv[1], cmds, "subcommand", 0, (int *)&cmd)) != TCL_OK)- case CMD_ACCOUNT_ALIAS:- Tcl_WrongNumArgs(interp, 2, objv, "account");- if ((account = tcl_validate_account(objv[2], interp)) == NULL)- alias = purple_account_get_private_alias(account);- Tcl_SetObjResult(interp, Tcl_NewStringObj(alias ? (char *)alias : "", -1));- case CMD_ACCOUNT_CONNECT:- Tcl_WrongNumArgs(interp, 2, objv, "account");- if ((account = tcl_validate_account(objv[2], interp)) == NULL)- if (!purple_account_is_connected(account))- purple_account_connect(account);- Tcl_SetObjResult(interp,- purple_tcl_ref_new(PurpleTclRefConnection,- purple_account_get_connection(account)));- case CMD_ACCOUNT_CONNECTION:- Tcl_WrongNumArgs(interp, 2, objv, "account");- if ((account = tcl_validate_account(objv[2], interp)) == NULL)- Tcl_SetObjResult(interp,- purple_tcl_ref_new(PurpleTclRefConnection,- purple_account_get_connection(account)));- case CMD_ACCOUNT_DISCONNECT:- Tcl_WrongNumArgs(interp, 2, objv, "account");- if ((account = tcl_validate_account(objv[2], interp)) == NULL)- purple_account_disconnect(account);- case CMD_ACCOUNT_ENABLED:- if (objc != 3 && objc != 4) {- Tcl_WrongNumArgs(interp, 2, objv, "account ?enabled?");- if ((account = tcl_validate_account(objv[2], interp)) == NULL)- Tcl_SetObjResult(interp,- purple_account_get_enabled(account,- purple_core_get_ui())));- if ((error = Tcl_GetBooleanFromObj(interp, objv[3], &b)) != TCL_OK)- purple_account_set_enabled(account, purple_core_get_ui(), b);- Tcl_WrongNumArgs(interp, 2, objv, "username protocol");- account = purple_accounts_find(Tcl_GetString(objv[2]),- Tcl_GetString(objv[3]));- Tcl_SetObjResult(interp,- purple_tcl_ref_new(PurpleTclRefAccount, account));- case CMD_ACCOUNT_HANDLE:- Tcl_WrongNumArgs(interp, 2, objv, "");- Tcl_SetObjResult(interp,- purple_tcl_ref_new(PurpleTclRefHandle,- purple_accounts_get_handle()));- case CMD_ACCOUNT_ISCONNECTED:- Tcl_WrongNumArgs(interp, 2, objv, "account");- if ((account = tcl_validate_account(objv[2], interp)) == NULL)- Tcl_SetObjResult(interp,- purple_account_is_connected(account)));- listopt = CMD_ACCOUNTLIST_ALL;- Tcl_WrongNumArgs(interp, 2, objv, "?option?");- if ((error = Tcl_GetIndexFromObj(interp, objv[2], listopts, "option", 0, (int *)&listopt)) != TCL_OK)- list = Tcl_NewListObj(0, NULL);- for (cur = purple_accounts_get_all(); cur != NULL; cur = g_list_next(cur)) {- if (listopt == CMD_ACCOUNTLIST_ONLINE && !purple_account_is_connected(account))- elem = purple_tcl_ref_new(PurpleTclRefAccount, account);- Tcl_ListObjAppendElement(interp, list, elem);- Tcl_SetObjResult(interp, list);- case CMD_ACCOUNT_PRESENCE:- Tcl_WrongNumArgs(interp, 2, objv, "account");- if ((account = tcl_validate_account(objv[2], interp)) == NULL)- Tcl_SetObjResult(interp, purple_tcl_ref_new(PurpleTclRefPresence,- purple_account_get_presence(account)));- case CMD_ACCOUNT_PROTOCOL:- Tcl_WrongNumArgs(interp, 2, objv, "account");- if ((account = tcl_validate_account(objv[2], interp)) == NULL)- Tcl_SetObjResult(interp, Tcl_NewStringObj((char *)purple_account_get_protocol_id(account), -1));- case CMD_ACCOUNT_STATUS:- Tcl_WrongNumArgs(interp, 2, objv, "account ?status_id name value ...?");- if ((account = tcl_validate_account(objv[2], interp)) == NULL)- Tcl_SetObjResult(interp,- purple_tcl_ref_new(PurpleTclRefStatus,- purple_account_get_active_status(account)));- Tcl_SetObjResult(interp, Tcl_NewStringObj("name without value setting status", -1));- status = purple_account_get_status(account, Tcl_GetString(objv[3]));- Tcl_SetObjResult(interp, Tcl_NewStringObj("invalid status for account", -1));- for (i = 4; i < objc; i += 2) {- attr_id = Tcl_GetString(objv[i]);- value = purple_status_get_attr_value(status, attr_id);- Tcl_SetObjResult(interp, Tcl_NewStringObj("invalid attribute for account", -1));- switch (G_VALUE_TYPE(value)) {- error = Tcl_GetBooleanFromObj(interp, objv[i + 1], &b);- l = g_list_append(l, attr_id);- l = g_list_append(l, GINT_TO_POINTER(b));- error = Tcl_GetIntFromObj(interp, objv[i + 1], &b);- l = g_list_append(l, attr_id);- l = g_list_append(l, GINT_TO_POINTER(b));- l = g_list_append(l, attr_id);- l = g_list_append(l, Tcl_GetString(objv[i + 1]));- Tcl_SetObjResult(interp, Tcl_NewStringObj("unknown GValue type", -1));- purple_account_set_status_list(account, Tcl_GetString(objv[3]), TRUE, l);- case CMD_ACCOUNT_STATUS_TYPE:- if (objc != 4 && objc != 5) {- Tcl_WrongNumArgs(interp, 2, objv, "account ?statustype? ?-primitive primitive?");- if ((account = tcl_validate_account(objv[2], interp)) == NULL)- status_type = purple_account_get_status_type(account,- Tcl_GetString(objv[3]));- PurpleStatusPrimitive primitive;- if (strcmp(Tcl_GetString(objv[3]), "-primitive")) {- result = Tcl_NewStringObj("bad option \"", -1);- Tcl_AppendObjToObj(result, objv[3]);- Tcl_AppendToObj(result, "\": should be -primitive", -1);- Tcl_SetObjResult(interp,result);- primitive = purple_primitive_get_type_from_id(Tcl_GetString(objv[4]));- status_type = purple_account_get_status_type_with_primitive(account,- if (status_type == NULL) {- Tcl_SetObjResult(interp, Tcl_NewStringObj("status type not found", -1));- Tcl_SetObjResult(interp,- purple_tcl_ref_new(PurpleTclRefStatusType,- case CMD_ACCOUNT_STATUS_TYPES:- Tcl_WrongNumArgs(interp, 2, objv, "account");- if ((account = tcl_validate_account(objv[2], interp)) == NULL)- list = Tcl_NewListObj(0, NULL);- for (cur = purple_account_get_status_types(account); cur != NULL;- cur = g_list_next(cur)) {- Tcl_ListObjAppendElement(interp, list,- purple_tcl_ref_new(PurpleTclRefStatusType,- Tcl_SetObjResult(interp, list);- case CMD_ACCOUNT_USERNAME:- Tcl_WrongNumArgs(interp, 2, objv, "account");- if ((account = tcl_validate_account(objv[2], interp)) == NULL)- Tcl_SetObjResult(interp,- Tcl_NewStringObj((char *)purple_account_get_username(account), -1));-static PurpleBlistNode *tcl_list_to_buddy(Tcl_Interp *interp, int count, Tcl_Obj **elems)- PurpleBlistNode *node = NULL;- PurpleAccount *account;- Tcl_SetObjResult(interp,- Tcl_NewStringObj("list too short", -1));- type = Tcl_GetString(elems[0]);- name = Tcl_GetString(elems[1]);- if ((account = tcl_validate_account(elems[2], interp)) == NULL)- if (!strcmp(type, "buddy")) {- node = PURPLE_BLIST_NODE(purple_blist_find_buddy(account, name));- } else if (!strcmp(type, "group")) {- node = PURPLE_BLIST_NODE(purple_blist_find_chat(account, name));-int tcl_cmd_buddy(ClientData unused, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])- Tcl_Obj *list, *tclgroup, *tclgrouplist, *tclcontact, *tclcontactlist, *tclbud, **elems, *result;- const char *cmds[] = { "alias", "handle", "info", "list", NULL };- enum { CMD_BUDDY_ALIAS, CMD_BUDDY_HANDLE, CMD_BUDDY_INFO, CMD_BUDDY_LIST } cmd;- PurpleBlistNode *node, *gnode, *bnode;- PurpleAccount *account;- int error, all = 0, count;- Tcl_WrongNumArgs(interp, 1, objv, "subcommand ?args?");- if ((error = Tcl_GetIndexFromObj(interp, objv[1], cmds, "subcommand", 0, (int *)&cmd)) != TCL_OK)- Tcl_WrongNumArgs(interp, 2, objv, "buddy");- if ((error = Tcl_ListObjGetElements(interp, objv[2], &count, &elems)) != TCL_OK)- if ((node = tcl_list_to_buddy(interp, count, elems)) == NULL)- if (PURPLE_IS_CHAT(node))- Tcl_SetObjResult(interp,- Tcl_NewStringObj(purple_chat_get_name(PURPLE_CHAT(node)), -1));- else if (PURPLE_IS_BUDDY(node))- Tcl_SetObjResult(interp,- Tcl_NewStringObj((char *)purple_buddy_get_alias(PURPLE_BUDDY(node)), -1));- Tcl_WrongNumArgs(interp, 2, objv, "");- Tcl_SetObjResult(interp,- purple_tcl_ref_new(PurpleTclRefHandle,- purple_blist_get_handle()));- if (objc != 3 && objc != 4) {- Tcl_WrongNumArgs(interp, 2, objv, "( buddy | account username )");- if ((error = Tcl_ListObjGetElements(interp, objv[2], &count, &elems)) != TCL_OK)- Tcl_SetObjResult(interp,- Tcl_NewStringObj("buddy too short", -1));- if (strcmp("buddy", Tcl_GetString(elems[0]))) {- Tcl_SetObjResult(interp,- Tcl_NewStringObj("invalid buddy", -1));- if ((account = tcl_validate_account(elems[2], interp)) == NULL)- purple_serv_get_info(purple_account_get_connection(account), Tcl_GetString(elems[1]));- if ((account = tcl_validate_account(objv[2], interp)) == NULL)- purple_serv_get_info(purple_account_get_connection(account), Tcl_GetString(objv[3]));- if (!strcmp("-all", Tcl_GetString(objv[2]))) {- result = Tcl_NewStringObj("",-1);- Tcl_AppendStringsToObj(result, "unknown option: ", Tcl_GetString(objv[2]), NULL);- Tcl_SetObjResult(interp,result);- list = Tcl_NewListObj(0, NULL);- for (gnode = purple_blist_get_root(); gnode != NULL; gnode = purple_blist_node_get_sibling_next(gnode)) {- tclgroup = Tcl_NewListObj(0, NULL);- Tcl_ListObjAppendElement(interp, tclgroup, Tcl_NewStringObj("group", -1));- Tcl_ListObjAppendElement(interp, tclgroup,- Tcl_NewStringObj(purple_group_get_name(PURPLE_GROUP(gnode)), -1));- tclgrouplist = Tcl_NewListObj(0, NULL);- for (node = purple_blist_node_get_first_child(gnode); node != NULL; node = purple_blist_node_get_sibling_next(node)) {- PurpleAccount *account;- if (PURPLE_IS_CONTACT(node)) {- tclcontact = Tcl_NewListObj(0, NULL);- Tcl_IncrRefCount(tclcontact);- Tcl_ListObjAppendElement(interp, tclcontact, Tcl_NewStringObj("contact", -1));- tclcontactlist = Tcl_NewListObj(0, NULL);- Tcl_IncrRefCount(tclcontactlist);- for (bnode = purple_blist_node_get_first_child(node); bnode != NULL; bnode = purple_blist_node_get_sibling_next(bnode)) {- if (!PURPLE_IS_BUDDY(bnode))- bud = PURPLE_BUDDY(bnode);- account = purple_buddy_get_account(bud);- if (!all && !purple_account_is_connected(account))- tclbud = Tcl_NewListObj(0, NULL);- Tcl_ListObjAppendElement(interp, tclbud, Tcl_NewStringObj("buddy", -1));- Tcl_ListObjAppendElement(interp, tclbud, Tcl_NewStringObj(purple_buddy_get_name(bud), -1));- Tcl_ListObjAppendElement(interp, tclbud, purple_tcl_ref_new(PurpleTclRefAccount, account));- Tcl_ListObjAppendElement(interp, tclcontactlist, tclbud);- Tcl_ListObjAppendElement(interp, tclcontact, tclcontactlist);- Tcl_ListObjAppendElement(interp, tclgrouplist, tclcontact);- Tcl_DecrRefCount(tclcontact);- Tcl_DecrRefCount(tclcontactlist);- } else if (PURPLE_IS_CHAT(node)) {- cnode = PURPLE_CHAT(node);- account = purple_chat_get_account(cnode);- if (!all && !purple_account_is_connected(account))- tclbud = Tcl_NewListObj(0, NULL);- Tcl_ListObjAppendElement(interp, tclbud, Tcl_NewStringObj("chat", -1));- Tcl_ListObjAppendElement(interp, tclbud, Tcl_NewStringObj(purple_chat_get_name(cnode), -1));- Tcl_ListObjAppendElement(interp, tclbud, purple_tcl_ref_new(PurpleTclRefAccount, account));- Tcl_ListObjAppendElement(interp, tclgrouplist, tclbud);- purple_debug(PURPLE_DEBUG_WARNING, "tcl", "Unexpected buddy type %s", G_OBJECT_TYPE_NAME(node));- Tcl_ListObjAppendElement(interp, tclgroup, tclgrouplist);- Tcl_ListObjAppendElement(interp, list, tclgroup);- Tcl_SetObjResult(interp, list);-int tcl_cmd_cmd(ClientData unused, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])- const char *cmds[] = { "do", "help", "list", "register", "unregister", NULL };- enum { CMD_CMD_DO, CMD_CMD_HELP, CMD_CMD_LIST, CMD_CMD_REGISTER, CMD_CMD_UNREGISTER } cmd;- struct tcl_cmd_handler *handler;- PurpleConversation *convo;- PurpleCmdStatus status;- gchar *escaped, *errstr = NULL;- Tcl_WrongNumArgs(interp, 1, objv, "subcommand ?args?");- if ((error = Tcl_GetIndexFromObj(interp, objv[1], cmds, "subcommand", 0, (int *)&cmd)) != TCL_OK)- Tcl_WrongNumArgs(interp, 2, objv, "conversation command");- if ((convo = tcl_validate_conversation(objv[2], interp)) == NULL)- escaped = g_markup_escape_text(Tcl_GetString(objv[3]), -1);- status = purple_cmd_do_command(convo, Tcl_GetString(objv[3]),- Tcl_SetObjResult(interp,- Tcl_NewStringObj(errstr ? (char *)errstr : "", -1));- if (status != PURPLE_CMD_STATUS_OK) {- Tcl_WrongNumArgs(interp, 2, objv, "conversation name");- if ((convo = tcl_validate_conversation(objv[2], interp)) == NULL)- l = cur = purple_cmd_help(convo, Tcl_GetString(objv[3]));- list = Tcl_NewListObj(0, NULL);- elem = Tcl_NewStringObj((char *)cur->data, -1);- Tcl_ListObjAppendElement(interp, list, elem);- cur = g_list_next(cur);- Tcl_SetObjResult(interp, list);- Tcl_WrongNumArgs(interp, 2, objv, "conversation");- if ((convo = tcl_validate_conversation(objv[2], interp)) == NULL)- l = cur = purple_cmd_list(convo);- list = Tcl_NewListObj(0, NULL);- elem = Tcl_NewStringObj((char *)cur->data, -1);- Tcl_ListObjAppendElement(interp, list, elem);- cur = g_list_next(cur);- Tcl_SetObjResult(interp, list);- Tcl_WrongNumArgs(interp, 2, objv, "cmd arglist priority flags protocol_id proc helpstr");- handler = g_new0(struct tcl_cmd_handler, 1);- handler->cmd = objv[2];- handler->args = Tcl_GetString(objv[3]);- handler->nargs = strlen(handler->args);- if ((error = Tcl_GetIntFromObj(interp, objv[4],- &handler->priority)) != TCL_OK) {- if ((error = Tcl_GetIntFromObj(interp, objv[5],- &handler->flags)) != TCL_OK) {- handler->protocol_id = Tcl_GetString(objv[6]);- handler->proc = objv[7];- handler->helpstr = Tcl_GetString(objv[8]);- handler->interp = interp;- if ((id = tcl_cmd_register(handler)) == 0) {- tcl_cmd_handler_free(handler);- Tcl_SetObjResult(interp, Tcl_NewIntObj(0));- Tcl_SetObjResult(interp, Tcl_NewIntObj(id));- case CMD_CMD_UNREGISTER:- Tcl_WrongNumArgs(interp, 2, objv, "id");- if ((error = Tcl_GetIntFromObj(interp, objv[2],- (int *)&id)) != TCL_OK)- tcl_cmd_unregister(id, interp);-int tcl_cmd_connection(ClientData unused, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])- const char *cmds[] = { "account", "displayname", "handle", "list", "state", NULL };- enum { CMD_CONN_ACCOUNT, CMD_CONN_DISPLAYNAME, CMD_CONN_HANDLE,- CMD_CONN_LIST, CMD_CONN_STATE } cmd;- Tcl_WrongNumArgs(interp, 1, objv, "subcommand ?args?");- if ((error = Tcl_GetIndexFromObj(interp, objv[1], cmds, "subcommand", 0, (int *)&cmd)) != TCL_OK)- Tcl_WrongNumArgs(interp, 2, objv, "gc");- if ((gc = tcl_validate_gc(objv[2], interp)) == NULL)- Tcl_SetObjResult(interp,- purple_tcl_ref_new(PurpleTclRefAccount,- purple_connection_get_account(gc)));- case CMD_CONN_DISPLAYNAME:- Tcl_WrongNumArgs(interp, 2, objv, "gc");- if ((gc = tcl_validate_gc(objv[2], interp)) == NULL)- Tcl_SetObjResult(interp,- Tcl_NewStringObj(purple_connection_get_display_name(gc), -1));- Tcl_WrongNumArgs(interp, 2, objv, "");- Tcl_SetObjResult(interp, purple_tcl_ref_new(PurpleTclRefHandle,- purple_connections_get_handle()));- Tcl_WrongNumArgs(interp, 2, objv, "");- list = Tcl_NewListObj(0, NULL);- for (cur = purple_connections_get_all(); cur != NULL; cur = g_list_next(cur)) {- elem = purple_tcl_ref_new(PurpleTclRefConnection, cur->data);- Tcl_ListObjAppendElement(interp, list, elem);- Tcl_SetObjResult(interp, list);- Tcl_WrongNumArgs(interp, 2, objv, "gc");- if ((gc = tcl_validate_gc(objv[2], interp)) == NULL)- switch (purple_connection_get_state(gc)) {- case PURPLE_CONNECTION_DISCONNECTED:- Tcl_SetObjResult(interp, Tcl_NewStringObj("disconnected", -1));- case PURPLE_CONNECTION_CONNECTED:- Tcl_SetObjResult(interp, Tcl_NewStringObj("connected", -1));- case PURPLE_CONNECTION_CONNECTING:- Tcl_SetObjResult(interp, Tcl_NewStringObj("connecting", -1));-int tcl_cmd_conversation(ClientData unused, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])- const char *cmds[] = { "find", "handle", "list", "new", "write", "name", "title", "send", NULL };- enum { CMD_CONV_FIND, CMD_CONV_HANDLE, CMD_CONV_LIST, CMD_CONV_NEW, CMD_CONV_WRITE , CMD_CONV_NAME, CMD_CONV_TITLE, CMD_CONV_SEND } cmd;- const char *styles[] = { "send", "recv", "system", NULL };- enum { CMD_CONV_WRITE_SEND, CMD_CONV_WRITE_RECV, CMD_CONV_WRITE_SYSTEM } style;- const char *newopts[] = { "-chat", "-im" };- enum { CMD_CONV_NEW_CHAT, CMD_CONV_NEW_IM } newopt;- PurpleConversation *convo;- PurpleAccount *account;- gboolean is_chat = FALSE;- char *opt, *from, *what;- Tcl_WrongNumArgs(interp, 1, objv, "subcommand ?args?");- if ((error = Tcl_GetIndexFromObj(interp, objv[1], cmds, "subcommand", 0, (int *)&cmd)) != TCL_OK)- Tcl_WrongNumArgs(interp, 2, objv, "account name");- if ((account = tcl_validate_account(objv[2], interp)) == NULL)- convo = purple_conversations_find_with_account(Tcl_GetString(objv[3]),- Tcl_SetObjResult(interp, purple_tcl_ref_new(PurpleTclRefConversation, convo));- Tcl_WrongNumArgs(interp, 2, objv, "");- Tcl_SetObjResult(interp,- purple_tcl_ref_new(PurpleTclRefHandle,- purple_conversations_get_handle()));- list = Tcl_NewListObj(0, NULL);- for (cur = purple_conversations_get_all(); cur != NULL; cur = g_list_next(cur)) {- elem = purple_tcl_ref_new(PurpleTclRefConversation, cur->data);- Tcl_ListObjAppendElement(interp, list, elem);- Tcl_SetObjResult(interp, list);- Tcl_WrongNumArgs(interp, 2, objv, "?options? account name");- while (argsused < objc) {- opt = Tcl_GetString(objv[argsused]);- if ((error = Tcl_GetIndexFromObj(interp, objv[argsused], newopts,- "option", 0, (int *)&newopt)) != TCL_OK)- case CMD_CONV_NEW_CHAT:- if (objc - argsused != 2) {- Tcl_WrongNumArgs(interp, 2, objv, "?options? account name");- if ((account = tcl_validate_account(objv[argsused++], interp)) == NULL)- convo = PURPLE_CONVERSATION(purple_chat_conversation_new(account, Tcl_GetString(objv[argsused])));- convo = PURPLE_CONVERSATION(purple_im_conversation_new(account, Tcl_GetString(objv[argsused])));- Tcl_SetObjResult(interp, purple_tcl_ref_new(PurpleTclRefConversation, convo));- Tcl_WrongNumArgs(interp, 2, objv, "conversation style from what");- if ((convo = tcl_validate_conversation(objv[2], interp)) == NULL)- if ((error = Tcl_GetIndexFromObj(interp, objv[3], styles, "style", 0, (int *)&style)) != TCL_OK)- from = Tcl_GetString(objv[4]);- what = Tcl_GetString(objv[5]);- case CMD_CONV_WRITE_SEND:- pmsg = purple_message_new_outgoing(from, what, 0);- case CMD_CONV_WRITE_RECV:- pmsg = purple_message_new_incoming(from, what, 0, 0);- case CMD_CONV_WRITE_SYSTEM:- pmsg = purple_message_new_system(what, 0);- purple_conversation_write_message(convo, pmsg);- Tcl_WrongNumArgs(interp, 2, objv, "conversation");- if ((convo = tcl_validate_conversation(objv[2], interp)) == NULL)- Tcl_SetObjResult(interp,- Tcl_NewStringObj((char *)purple_conversation_get_name(convo), -1));- Tcl_WrongNumArgs(interp, 2, objv, "conversation");- if ((convo = tcl_validate_conversation(objv[2], interp)) == NULL)- Tcl_SetObjResult(interp,- Tcl_NewStringObj((char *)purple_conversation_get_title(convo), -1));- Tcl_WrongNumArgs(interp, 2, objv, "conversation message");- if ((convo = tcl_validate_conversation(objv[2], interp)) == NULL)- what = Tcl_GetString(objv[3]);- purple_conversation_send(convo, what);-int tcl_cmd_core(ClientData unused, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])- const char *cmds[] = { "handle", "quit", NULL };- enum { CMD_CORE_HANDLE, CMD_CORE_QUIT } cmd;- Tcl_WrongNumArgs(interp, 1, objv, "subcommand ?args?");- if ((error = Tcl_GetIndexFromObj(interp, objv[1], cmds, "subcommand", 0, (int *)&cmd)) != TCL_OK)- Tcl_WrongNumArgs(interp, 2, objv, "");- Tcl_SetObjResult(interp,- purple_tcl_ref_new(PurpleTclRefHandle,- Tcl_WrongNumArgs(interp, 2, objv, "");-int tcl_cmd_debug(ClientData unused, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])- char *category, *message;- const char *levels[] = { "-misc", "-info", "-warning", "-error", NULL };- PurpleDebugLevel levelind[] = { PURPLE_DEBUG_MISC, PURPLE_DEBUG_INFO, PURPLE_DEBUG_WARNING, PURPLE_DEBUG_ERROR };- Tcl_WrongNumArgs(interp, 1, objv, "level category message");- error = Tcl_GetIndexFromObj(interp, objv[1], levels, "debug level", 0, &lev);- category = Tcl_GetString(objv[2]);- message = Tcl_GetString(objv[3]);- purple_debug(levelind[lev], category, "%s\n", message);-int tcl_cmd_notify(ClientData unused, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])- const char *opts[] = { "-error", "-warning", "-info", NULL };- PurpleNotifyMsgType optind[] = { PURPLE_NOTIFY_MSG_ERROR, PURPLE_NOTIFY_MSG_WARNING, PURPLE_NOTIFY_MSG_INFO };- char *title, *msg1, *msg2;- if (objc < 4 || objc > 5) {- Tcl_WrongNumArgs(interp, 1, objv, "?type? title primary secondary");- type = 1; /* Default to warning */- title = Tcl_GetString(objv[1]);- msg1 = Tcl_GetString(objv[2]);- msg2 = Tcl_GetString(objv[3]);- error = Tcl_GetIndexFromObj(interp, objv[1], opts, "message type", 0, &type);- title = Tcl_GetString(objv[2]);- msg1 = Tcl_GetString(objv[3]);- msg2 = Tcl_GetString(objv[4]);- purple_notify_message(_tcl_plugin, optind[type], title, msg1, msg2, NULL, NULL, NULL);-int tcl_cmd_plugins(ClientData unused, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])- const char *cmds[] = { "handle", NULL };- enum { CMD_PLUGINS_HANDLE } cmd;- Tcl_WrongNumArgs(interp, 1, objv, "subcommand ?args?");- if ((error = Tcl_GetIndexFromObj(interp, objv[1], cmds, "subcommand", 0, (int *)&cmd)) != TCL_OK)- case CMD_PLUGINS_HANDLE:- Tcl_WrongNumArgs(interp, 2, objv, "");- Tcl_SetObjResult(interp,- purple_tcl_ref_new(PurpleTclRefHandle,- purple_plugins_get_handle()));-int tcl_cmd_prefs(ClientData unused, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])- Tcl_Obj *list, *elem, **elems;- const char *cmds[] = { "get", "set", "type", NULL };- enum { CMD_PREFS_GET, CMD_PREFS_SET, CMD_PREFS_TYPE } cmd;- /* char *types[] = { "none", "boolean", "int", "string", "stringlist", NULL }; */- /* enum { TCL_PREFS_NONE, TCL_PREFS_BOOL, TCL_PREFS_INT, TCL_PREFS_STRING, TCL_PREFS_STRINGLIST } type; */- PurplePrefType preftype;- int error, intval, nelem, i;- Tcl_WrongNumArgs(interp, 1, objv, "subcommand ?args?");- if ((error = Tcl_GetIndexFromObj(interp, objv[1], cmds, "subcommand", 0, (int *)&cmd)) != TCL_OK)- Tcl_WrongNumArgs(interp, 1, objv, "path");- preftype = purple_prefs_get_pref_type(Tcl_GetString(objv[2]));- Tcl_SetObjResult(interp,- Tcl_NewStringObj("pref type none", -1));- case PURPLE_PREF_BOOLEAN:- Tcl_SetObjResult(interp,- purple_prefs_get_bool(Tcl_GetString(objv[2]))));- Tcl_SetObjResult(interp, Tcl_NewIntObj(purple_prefs_get_int(Tcl_GetString(objv[2]))));- case PURPLE_PREF_STRING:- Tcl_SetObjResult(interp,- Tcl_NewStringObj((char *)purple_prefs_get_string(Tcl_GetString(objv[2])), -1));- case PURPLE_PREF_STRING_LIST:- cur = purple_prefs_get_string_list(Tcl_GetString(objv[2]));- list = Tcl_NewListObj(0, NULL);- elem = Tcl_NewStringObj((char *)cur->data, -1);- Tcl_ListObjAppendElement(interp, list, elem);- cur = g_list_next(cur);- Tcl_SetObjResult(interp, list);- purple_debug(PURPLE_DEBUG_ERROR, "tcl", "tcl does not know about pref type %d\n", preftype);- Tcl_SetObjResult(interp,- Tcl_NewStringObj("unknown pref type", -1));- Tcl_WrongNumArgs(interp, 1, objv, "path value");- preftype = purple_prefs_get_pref_type(Tcl_GetString(objv[2]));- Tcl_SetObjResult(interp,- Tcl_NewStringObj("bad path or pref type none", -1));- case PURPLE_PREF_BOOLEAN:- if ((error = Tcl_GetBooleanFromObj(interp, objv[3], &intval)) != TCL_OK)- purple_prefs_set_bool(Tcl_GetString(objv[2]), intval);- if ((error = Tcl_GetIntFromObj(interp, objv[3], &intval)) != TCL_OK)- purple_prefs_set_int(Tcl_GetString(objv[2]), intval);- case PURPLE_PREF_STRING:- purple_prefs_set_string(Tcl_GetString(objv[2]), Tcl_GetString(objv[3]));- case PURPLE_PREF_STRING_LIST:- if ((error = Tcl_ListObjGetElements(interp, objv[3], &nelem, &elems)) != TCL_OK)- for (i = 0; i < nelem; i++) {- cur = g_list_append(cur, (gpointer)Tcl_GetString(elems[i]));- purple_prefs_set_string_list(Tcl_GetString(objv[2]), cur);- purple_debug(PURPLE_DEBUG_ERROR, "tcl", "tcl does not know about pref type %d\n", preftype);- Tcl_WrongNumArgs(interp, 1, objv, "path");- preftype = purple_prefs_get_pref_type(Tcl_GetString(objv[2]));- Tcl_SetObjResult(interp, Tcl_NewStringObj("none", -1));- case PURPLE_PREF_BOOLEAN:- Tcl_SetObjResult(interp, Tcl_NewStringObj("boolean", -1));- Tcl_SetObjResult(interp, Tcl_NewStringObj("int", -1));- case PURPLE_PREF_STRING:- Tcl_SetObjResult(interp, Tcl_NewStringObj("string", -1));- case PURPLE_PREF_STRING_LIST:- Tcl_SetObjResult(interp, Tcl_NewStringObj("stringlist", -1));- purple_debug(PURPLE_DEBUG_ERROR, "tcl", "tcl does not know about pref type %d\n", preftype);- Tcl_SetObjResult(interp, Tcl_NewStringObj("unknown", -1));-int tcl_cmd_presence(ClientData unused, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])- const char *cmds[] = { "account", "active_status", "available",- "idle", "type", "login", "online", "status",- enum { CMD_PRESENCE_ACCOUNT, CMD_PRESENCE_ACTIVE_STATUS,- CMD_PRESENCE_AVAILABLE, CMD_PRESENCE_IDLE, CMD_PRESENCE_TYPE,- CMD_PRESENCE_LOGIN, CMD_PRESENCE_ONLINE,- CMD_PRESENCE_STATUS, CMD_PRESENCE_STATUSES } cmd;- PurplePresence *presence;- int error, idle, idle_time, login_time;- Tcl_WrongNumArgs(interp, 1, objv, "subcommand ?args?");- if ((error = Tcl_GetIndexFromObj(interp, objv[1], cmds, "subcommand", 0, (int *)&cmd)) != TCL_OK)- case CMD_PRESENCE_ACCOUNT:- Tcl_WrongNumArgs(interp, 2, objv, "presence");- if ((presence = purple_tcl_ref_get(interp, objv[2], PurpleTclRefPresence)) == NULL)- Tcl_SetObjResult(interp, purple_tcl_ref_new(PurpleTclRefAccount,- purple_account_presence_get_account(PURPLE_ACCOUNT_PRESENCE(presence))));- case CMD_PRESENCE_ACTIVE_STATUS:- if (objc != 3 && objc != 4 && objc != 5) {- Tcl_WrongNumArgs(interp, 2, objv, "presence [?status_id? | ?-primitive primitive?]");- if ((presence = purple_tcl_ref_get(interp, objv[2], PurpleTclRefPresence)) == NULL)- Tcl_SetObjResult(interp,- purple_tcl_ref_new(PurpleTclRefStatus,- purple_presence_get_active_status(presence)));- } else if (objc == 4) {- Tcl_SetObjResult(interp,- purple_presence_is_status_active(presence,- Tcl_GetString(objv[3]))));- PurpleStatusPrimitive primitive;- if (strcmp(Tcl_GetString(objv[3]), "-primitive")) {- result = Tcl_NewStringObj("bad option \"", -1);- Tcl_AppendObjToObj(result, objv[3]);- Tcl_AppendToObj(result,- "\": should be -primitive", -1);- Tcl_SetObjResult(interp,result);- primitive = purple_primitive_get_type_from_id(Tcl_GetString(objv[4]));- if (primitive == PURPLE_STATUS_UNSET) {- result = Tcl_NewStringObj("invalid primitive ", -1);- Tcl_AppendObjToObj(result, objv[4]);- Tcl_SetObjResult(interp,result);- Tcl_SetObjResult(interp,- purple_presence_is_status_primitive_active(presence, primitive)));- case CMD_PRESENCE_AVAILABLE:- Tcl_WrongNumArgs(interp, 2, objv, "presence");- if ((presence = purple_tcl_ref_get(interp, objv[2], PurpleTclRefPresence)) == NULL)- Tcl_SetObjResult(interp,- Tcl_NewBooleanObj(purple_presence_is_available(presence)));- case CMD_PRESENCE_TYPE:- Tcl_WrongNumArgs(interp, 2, objv, "presence");- if ((presence = purple_tcl_ref_get(interp, objv[2], PurpleTclRefPresence)) == NULL)- if (PURPLE_IS_ACCOUNT_PRESENCE(presence))- Tcl_SetObjResult(interp, Tcl_NewStringObj("account", -1));- else if (PURPLE_IS_BUDDY_PRESENCE(presence))- Tcl_SetObjResult(interp, Tcl_NewStringObj("buddy", -1));- case CMD_PRESENCE_IDLE:- if (objc < 3 || objc > 5) {- Tcl_WrongNumArgs(interp, 2, objv, "presence ?idle? ?time?");- if ((presence = purple_tcl_ref_get(interp, objv[2], PurpleTclRefPresence)) == NULL)- if (purple_presence_is_idle(presence)) {- idle_time = purple_presence_get_idle_time (presence);- Tcl_SetObjResult(interp, Tcl_NewIntObj(idle_time));- result = Tcl_NewListObj(0, NULL);- Tcl_SetObjResult(interp, result);- if ((error = Tcl_GetBooleanFromObj(interp, objv[3], &idle)) != TCL_OK)- purple_presence_set_idle(presence, idle, time(NULL));- } else if (objc == 5) {- if ((error = Tcl_GetIntFromObj(interp,- &idle_time)) != TCL_OK)- purple_presence_set_idle(presence, idle, idle_time);- case CMD_PRESENCE_LOGIN:- if (objc != 3 && objc != 4) {- Tcl_WrongNumArgs(interp, 2, objv, "presence ?time?");- if ((presence = purple_tcl_ref_get(interp, objv[2], PurpleTclRefPresence)) == NULL)- Tcl_SetObjResult(interp, Tcl_NewIntObj(purple_presence_get_login_time(presence)));- if ((error == Tcl_GetIntFromObj(interp,- &login_time)) != TCL_OK)- purple_presence_set_login_time(presence, login_time);- case CMD_PRESENCE_ONLINE:- Tcl_WrongNumArgs(interp, 2, objv, "presence");- if ((presence = purple_tcl_ref_get(interp, objv[2], PurpleTclRefPresence)) == NULL)- Tcl_SetObjResult(interp,- purple_presence_is_online(presence)));- case CMD_PRESENCE_STATUS:- Tcl_WrongNumArgs(interp, 2, objv, "presence status_id");- if ((presence = purple_tcl_ref_get(interp, objv[2], PurpleTclRefPresence)) == NULL)- Tcl_SetObjResult(interp,- purple_tcl_ref_new(PurpleTclRefStatus,- purple_presence_get_status(presence,- Tcl_GetString(objv[3]))));- case CMD_PRESENCE_STATUSES:- Tcl_WrongNumArgs(interp, 2, objv, "presence");- if ((presence = purple_tcl_ref_get(interp, objv[2], PurpleTclRefPresence)) == NULL)- list = Tcl_NewListObj(0, NULL);- for (cur = purple_presence_get_statuses(presence); cur != NULL;- cur = g_list_next(cur)) {- elem = purple_tcl_ref_new(PurpleTclRefStatus, cur->data);- Tcl_ListObjAppendElement(interp, list, elem);- Tcl_SetObjResult(interp, list);-int tcl_cmd_savedstatus(ClientData unused, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])- const char *cmds[] = { "current", "handle", NULL };- enum { CMD_SAVEDSTATUS_CURRENT, CMD_SAVEDSTATUS_HANDLE } cmd;- PurpleSavedStatus *saved_status;- Tcl_WrongNumArgs(interp, 1, objv, "subcommand ?args?");- if ((error = Tcl_GetIndexFromObj(interp, objv[1], cmds, "subcommand", 0, (int *)&cmd)) != TCL_OK)- case CMD_SAVEDSTATUS_CURRENT:- Tcl_WrongNumArgs(interp, 2, objv, "");- if ((saved_status = purple_savedstatus_get_current()) == NULL)- result = Tcl_NewListObj(0, NULL);- Tcl_ListObjAppendElement(interp, result, Tcl_NewStringObj(purple_savedstatus_get_title(saved_status), -1));- Tcl_ListObjAppendElement(interp, result, Tcl_NewIntObj(purple_savedstatus_get_primitive_type(saved_status)));- Tcl_ListObjAppendElement(interp, result, Tcl_NewStringObj(purple_savedstatus_get_message(saved_status), -1));- Tcl_SetObjResult(interp,result);- case CMD_SAVEDSTATUS_HANDLE:- Tcl_WrongNumArgs(interp, 2, objv, "");- Tcl_SetObjResult(interp,- purple_tcl_ref_new(PurpleTclRefHandle,- purple_savedstatuses_get_handle()));-int tcl_cmd_send_im(ClientData unused, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])- Tcl_WrongNumArgs(interp, 1, objv, "gc who text");- if ((gc = tcl_validate_gc(objv[1], interp)) == NULL)- who = Tcl_GetString(objv[2]);- text = Tcl_GetString(objv[3]);- purple_serv_send_im(gc, purple_message_new_outgoing(who, text, 0));-int tcl_cmd_signal(ClientData unused, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])- const char *cmds[] = { "connect", "disconnect", NULL };- enum { CMD_SIGNAL_CONNECT, CMD_SIGNAL_DISCONNECT } cmd;- struct tcl_signal_handler *handler;- Tcl_WrongNumArgs(interp, 1, objv, "subcommand ?args?");- if ((error = Tcl_GetIndexFromObj(interp, objv[1], cmds, "subcommand", 0, (int *)&cmd)) != TCL_OK)- case CMD_SIGNAL_CONNECT:- Tcl_WrongNumArgs(interp, 2, objv, "instance signal args proc");- handler = g_new0(struct tcl_signal_handler, 1);- if ((handler->instance = purple_tcl_ref_get(interp, objv[2],PurpleTclRefHandle)) == NULL) {- handler->signal = objv[3];- Tcl_IncrRefCount(handler->signal);- handler->args = objv[4];- handler->proc = objv[5];- handler->interp = interp;- if (!tcl_signal_connect(handler)) {- tcl_signal_handler_free(handler);- Tcl_SetObjResult(interp, Tcl_NewIntObj(1));- Tcl_SetObjResult(interp, Tcl_NewIntObj(0));- case CMD_SIGNAL_DISCONNECT:- Tcl_WrongNumArgs(interp, 2, objv, "instance signal");- if ((instance = purple_tcl_ref_get(interp, objv[2],PurpleTclRefHandle)) == NULL)- tcl_signal_disconnect(instance, Tcl_GetString(objv[3]), interp);-int tcl_cmd_status(ClientData unused, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])- const char *cmds[] = { "attr", "type", NULL };- enum { CMD_STATUS_ATTRIBUTE, CMD_STATUS_TYPE } cmd;- PurpleStatusType *status_type;-/* #if !(defined PURPLE_DISABLE_DEPRECATED) */- Tcl_WrongNumArgs(interp, 1, objv, "subcommand ?args?");- if ((error = Tcl_GetIndexFromObj(interp, objv[1], cmds, "subcommand", 0, (int *)&cmd)) != TCL_OK)- case CMD_STATUS_ATTRIBUTE:-/* #if !(defined PURPLE_DISABLE_DEPRECATED) */- if (objc != 4 && objc != 5) {- Tcl_WrongNumArgs(interp, 2, objv, "status attr_id ?value?");- if ((status = purple_tcl_ref_get(interp, objv[2], PurpleTclRefStatus)) == NULL)- attr = Tcl_GetString(objv[3]);- value = purple_status_get_attr_value(status, attr);- Tcl_SetObjResult(interp,- Tcl_NewStringObj("no such attribute", -1));- switch (purple_value_get_type(value)) {- case PURPLE_TYPE_BOOLEAN:- Tcl_SetObjResult(interp,- Tcl_NewBooleanObj(purple_value_get_boolean(value)));- if ((error = Tcl_GetBooleanFromObj(interp, objv[4], &v)) != TCL_OK)- purple_status_set_attr_boolean(status, attr, v);- Tcl_SetObjResult(interp, Tcl_NewIntObj(purple_value_get_int(value)));- if ((error = Tcl_GetIntFromObj(interp, objv[4], &v)) != TCL_OK)- purple_status_set_attr_int(status, attr, v );- case PURPLE_TYPE_STRING:- Tcl_SetObjResult(interp,- Tcl_NewStringObj(purple_value_get_string(value), -1));- purple_status_set_attr_string(status, attr, Tcl_GetString(objv[4]));- Tcl_SetObjResult(interp,- Tcl_NewStringObj("attribute has unknown type", -1));- Tcl_WrongNumArgs(interp, 2, objv, "status");- if ((status = purple_tcl_ref_get(interp, objv[2], PurpleTclRefStatus)) == NULL)- status_type = purple_status_get_status_type(status);- Tcl_SetObjResult(interp, purple_tcl_ref_new(PurpleTclRefStatusType,-int tcl_cmd_status_attr(ClientData unused, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])- const char *cmds[] = { "id", "name", NULL };- enum { CMD_STATUS_ATTRIBUTE_ID, CMD_STATUS_ATTRIBUTE_NAME } cmd;- PurpleStatusAttribute *attr;- Tcl_WrongNumArgs(interp, 1, objv, "subcommand ?args?");- if ((error = Tcl_GetIndexFromObj(interp, objv[1], cmds, "subcommand", 0, (int *)&cmd)) != TCL_OK)- case CMD_STATUS_ATTRIBUTE_ID:- Tcl_WrongNumArgs(interp, 2, objv, "attr");- if ((attr = purple_tcl_ref_get(interp, objv[2], PurpleTclRefStatusAttr)) == NULL)- Tcl_SetObjResult(interp,- Tcl_NewStringObj(purple_status_attribute_get_id(attr), -1));- case CMD_STATUS_ATTRIBUTE_NAME:- Tcl_WrongNumArgs(interp, 2, objv, "attr");- if ((attr = purple_tcl_ref_get(interp, objv[2], PurpleTclRefStatusAttr)) == NULL)- Tcl_SetObjResult(interp,- Tcl_NewStringObj(purple_status_attribute_get_name(attr), -1));-int tcl_cmd_status_type(ClientData unused, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])- const char *cmds[] = { "attr", "attrs", "available", "exclusive", "id",- "primitive", "saveable", "user_settable",- enum { CMD_STATUS_TYPE_ATTR, CMD_STATUS_TYPE_ATTRS,- CMD_STATUS_TYPE_AVAILABLE, CMD_STATUS_TYPE_EXCLUSIVE,- CMD_STATUS_TYPE_ID, CMD_STATUS_TYPE_INDEPENDENT,- CMD_STATUS_TYPE_PRIMITIVE, CMD_STATUS_TYPE_SAVEABLE,- CMD_STATUS_TYPE_USER_SETTABLE } cmd;- PurpleStatusType *status_type;- Tcl_WrongNumArgs(interp, 1, objv, "subcommand ?args?");- if ((error = Tcl_GetIndexFromObj(interp, objv[1], cmds, "subcommand", 0, (int *)&cmd)) != TCL_OK)- case CMD_STATUS_TYPE_AVAILABLE:- Tcl_WrongNumArgs(interp, 2, objv, "statustype");- if ((status_type = purple_tcl_ref_get(interp, objv[2], PurpleTclRefStatusType)) == NULL)- Tcl_SetObjResult(interp,- Tcl_NewBooleanObj(purple_status_type_is_available(status_type)));- case CMD_STATUS_TYPE_ATTR:- Tcl_WrongNumArgs(interp, 2, objv, "statustype attr");- if ((status_type = purple_tcl_ref_get(interp, objv[2], PurpleTclRefStatusType)) == NULL)- Tcl_SetObjResult(interp,- purple_tcl_ref_new(PurpleTclRefStatusAttr,- purple_status_type_get_attr(status_type,- Tcl_GetStringFromObj(objv[3], NULL))));- case CMD_STATUS_TYPE_ATTRS:- Tcl_WrongNumArgs(interp, 2, objv, "statustype");- if ((status_type = purple_tcl_ref_get(interp, objv[2], PurpleTclRefStatusType)) == NULL)- list = Tcl_NewListObj(0, NULL);- for (cur = purple_status_type_get_attrs(status_type);- cur != NULL; cur = g_list_next(cur)) {- elem = purple_tcl_ref_new(PurpleTclRefStatusAttr, cur->data);- Tcl_ListObjAppendElement(interp, list, elem);- Tcl_SetObjResult(interp, list);- case CMD_STATUS_TYPE_EXCLUSIVE:- Tcl_WrongNumArgs(interp, 2, objv, "statustype");- if ((status_type = purple_tcl_ref_get(interp, objv[2], PurpleTclRefStatusType)) == NULL)- Tcl_SetObjResult(interp,- Tcl_NewBooleanObj(purple_status_type_is_exclusive(status_type)));- case CMD_STATUS_TYPE_ID:- Tcl_WrongNumArgs(interp, 2, objv, "statustype");- if ((status_type = purple_tcl_ref_get(interp, objv[2], PurpleTclRefStatusType)) == NULL)- Tcl_SetObjResult(interp,- Tcl_NewStringObj(purple_status_type_get_id(status_type), -1));- case CMD_STATUS_TYPE_INDEPENDENT:- Tcl_WrongNumArgs(interp, 2, objv, "statustype");- if ((status_type = purple_tcl_ref_get(interp, objv[2], PurpleTclRefStatusType)) == NULL)- Tcl_SetObjResult(interp,- Tcl_NewBooleanObj(purple_status_type_is_independent(status_type)));- case CMD_STATUS_TYPE_NAME:- Tcl_WrongNumArgs(interp, 2, objv, "statustype");- if ((status_type = purple_tcl_ref_get(interp, objv[2], PurpleTclRefStatusType)) == NULL)- Tcl_SetObjResult(interp,- Tcl_NewStringObj(purple_status_type_get_name(status_type), -1));- case CMD_STATUS_TYPE_PRIMITIVE:- Tcl_WrongNumArgs(interp, 2, objv, "statustype");- if ((status_type = purple_tcl_ref_get(interp, objv[2], PurpleTclRefStatusType)) == NULL)- Tcl_SetObjResult(interp,- Tcl_NewStringObj(purple_primitive_get_id_from_type- (purple_status_type_get_primitive(status_type)), -1));- case CMD_STATUS_TYPE_SAVEABLE:- Tcl_WrongNumArgs(interp, 2, objv, "statustype");- if ((status_type = purple_tcl_ref_get(interp, objv[2], PurpleTclRefStatusType)) == NULL)- Tcl_SetObjResult(interp,- purple_status_type_is_saveable(status_type)));- case CMD_STATUS_TYPE_USER_SETTABLE:- Tcl_WrongNumArgs(interp, 2, objv, "statustype");- if ((status_type = purple_tcl_ref_get(interp, objv[2], PurpleTclRefStatusType)) == NULL)- Tcl_SetObjResult(interp,- purple_status_type_is_user_settable(status_type)));-static gboolean unload_self(gpointer data)- PurplePlugin *plugin = data;- purple_plugin_unload(plugin);-int tcl_cmd_unload(ClientData unused, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])- Tcl_WrongNumArgs(interp, 1, objv, "");- if ((plugin = tcl_interp_get_plugin(interp)) == NULL) {- /* This isn't exactly OK, but heh. What do you do? */- /* We can't unload immediately, but we can unload at the first- * known safe opportunity. */- purple_timeout_add(0, unload_self, (gpointer)plugin);--- a/libpurple/plugins/tcl/tcl_glib.c Tue Mar 08 20:31:03 2016 -0600
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,259 +0,0 @@
- * Copyright (C) 2003, 2004, 2006 Ethan Blanton <eblanton@cs.purdue.edu>- * This file is dual-licensed under the two sets of terms below. You may- * use, redistribute, or modify it pursuant to either the set of conditions- * under "TERMS 1" or "TERMS 2", at your discretion. The DISCLAIMER- * applies to both sets of terms.- * 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.- * 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- * Redistribution and use in source and binary forms, with or without- * modification, are permitted provided that the following conditions- * 1. Redistributions of source code must contain the above copyright- * notice and this comment block in their entirety.- * 2. Redistributions in binary form must reproduce the above copyright- * notice and the text of this comment block in their entirety in- * the documentation and/or other materials provided with the- * 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.- * This file was developed for the Purple project. It inserts the Tcl- * event loop into the glib2 event loop for the purposes of providing- * Tcl bindings in a glib2 (e.g. Gtk2) program. To use it, simply- * link it into your executable, include tcl_glib.h, and call the- * function tcl_glib_init() before creating or using any Tcl- * interpreters. Then go ahead and use Tcl, Tk, whatever to your- * tcl_wait_for_event seems to have a bug that makes vwait not work so- * well... I'm not sure why, yet, but I haven't put much time into- * it. Hopefully I will figure it out soon. In the meantime, this- * means that Tk's bgerror function (which is called when there is an- * error in a callback function) causes some Bad Mojo -- you should- * override it with a function that does not use Tk-struct tcl_file_handler {-static gboolean tcl_timer_pending;-static GHashTable *tcl_file_handlers;-static void tcl_set_timer(CONST86 Tcl_Time *timePtr);-static int tcl_wait_for_event(CONST86 Tcl_Time *timePtr);-static void tcl_create_file_handler(int fd, int mask, Tcl_FileProc *proc, ClientData data);-static void tcl_delete_file_handler(int fd);-static gboolean tcl_kick(gpointer data);-static gboolean tcl_file_callback(GIOChannel *source, GIOCondition condition, gpointer data);-static int tcl_file_event_callback(Tcl_Event *event, int flags);-ClientData Tcl_InitNotifier()- Tcl_NotifierProcs notifier;- memset(¬ifier, 0, sizeof(notifier));- notifier.createFileHandlerProc = tcl_create_file_handler;- notifier.deleteFileHandlerProc = tcl_delete_file_handler;- notifier.setTimerProc = tcl_set_timer;- notifier.waitForEventProc = tcl_wait_for_event;- Tcl_SetNotifier(¬ifier);- Tcl_SetServiceMode(TCL_SERVICE_ALL);- tcl_timer_pending = FALSE;- tcl_file_handlers = g_hash_table_new(g_direct_hash, g_direct_equal);-static void tcl_set_timer(CONST86 Tcl_Time *timePtr)- g_source_remove(tcl_timer);- tcl_timer_pending = FALSE;- interval = timePtr->sec * 1000 + (timePtr->usec ? timePtr->usec / 1000 : 0);- tcl_timer = g_timeout_add(interval, tcl_kick, NULL);- tcl_timer_pending = TRUE;-static int tcl_wait_for_event(CONST86 Tcl_Time *timePtr)- if (!timePtr || (timePtr->sec == 0 && timePtr->usec == 0)) {- g_main_context_iteration(NULL, FALSE);- tcl_set_timer(timePtr);- g_main_context_iteration(NULL, TRUE);-static void tcl_create_file_handler(int fd, int mask, Tcl_FileProc *proc, ClientData data)- struct tcl_file_handler *tfh = g_new0(struct tcl_file_handler, 1);- if (g_hash_table_lookup(tcl_file_handlers, GINT_TO_POINTER(fd)))- tcl_delete_file_handler(fd);- if (mask & TCL_READABLE)- if (mask & TCL_WRITABLE)- if (mask & TCL_EXCEPTION)- cond |= G_IO_ERR|G_IO_HUP|G_IO_NVAL;- channel = g_io_channel_unix_new(fd);- tfh->source = g_io_add_watch_full(channel, G_PRIORITY_DEFAULT, cond, tcl_file_callback, tfh, g_free);- g_io_channel_unref(channel);- g_hash_table_insert(tcl_file_handlers, GINT_TO_POINTER(fd), tfh);-static void tcl_delete_file_handler(int fd)- struct tcl_file_handler *tfh = g_hash_table_lookup(tcl_file_handlers, GINT_TO_POINTER(fd));- g_source_remove(tfh->source);- g_hash_table_remove(tcl_file_handlers, GINT_TO_POINTER(fd));-static gboolean tcl_kick(gpointer data)- tcl_timer_pending = FALSE;-static gboolean tcl_file_callback(GIOChannel *source, GIOCondition condition, gpointer data)- struct tcl_file_handler *tfh = data;- struct tcl_file_event *fev;- if (condition & G_IO_IN)- if (condition & G_IO_OUT)- if (condition & (G_IO_ERR|G_IO_HUP|G_IO_NVAL))- if (!(tfh->mask & (mask & ~tfh->pending)))- /* ckalloc returns memory "suitably aligned for any use" */- fev = (gpointer)ckalloc(sizeof(struct tcl_file_event));- memset(fev, 0, sizeof(struct tcl_file_event));- fev->header.proc = tcl_file_event_callback;- Tcl_QueueEvent((Tcl_Event *)fev, TCL_QUEUE_TAIL);-int tcl_file_event_callback(Tcl_Event *event, int flags)- struct tcl_file_handler *tfh;- struct tcl_file_event *fev = (struct tcl_file_event *)event;- if (!(flags & TCL_FILE_EVENTS)) {- tfh = g_hash_table_lookup(tcl_file_handlers, GINT_TO_POINTER(fev->fd));- mask = tfh->mask & tfh->pending;- (*tfh->proc)(tfh->data, mask);--- a/libpurple/plugins/tcl/tcl_glib.h Tue Mar 08 20:31:03 2016 -0600
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,29 +0,0 @@
- * Copyright (C) 2003 Ethan Blanton <eblanton@cs.purdue.edu>- * 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-#ifndef _PURPLE_TCL_GLIB_H_-#define _PURPLE_TCL_GLIB_H_-void tcl_glib_init(void);-#endif /* _PURPLE_TCL_GLIB_H_ */--- a/libpurple/plugins/tcl/tcl_purple.h Tue Mar 08 20:31:03 2016 -0600
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,118 +0,0 @@
- * @file tcl_purple.h Purple Tcl definitions- * Copyright (C) 2003 Ethan Blanton <eblanton@cs.purdue.edu>- * 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-#ifndef _PURPLE_TCL_PURPLE_H_-#define _PURPLE_TCL_PURPLE_H_-struct tcl_signal_handler {- /* These following two are temporary during setup */-struct tcl_cmd_handler {- /* These are temporary during setup */- const char *protocol_id;-extern PurplePlugin *_tcl_plugin;-/* Capitalized this way because these are "types" */-extern PurpleStringref *PurpleTclRefAccount;-extern PurpleStringref *PurpleTclRefConnection;-extern PurpleStringref *PurpleTclRefConversation;-extern PurpleStringref *PurpleTclRefPointer;-extern PurpleStringref *PurpleTclRefPlugin;-extern PurpleStringref *PurpleTclRefPresence;-extern PurpleStringref *PurpleTclRefStatus;-extern PurpleStringref *PurpleTclRefStatusAttr;-extern PurpleStringref *PurpleTclRefStatusType;-extern PurpleStringref *PurpleTclRefXfer;-extern PurpleStringref *PurpleTclRefHandle;-PurplePlugin *tcl_interp_get_plugin(Tcl_Interp *interp);-void tcl_signal_init(void);-void tcl_signal_handler_free(struct tcl_signal_handler *handler);-void tcl_signal_cleanup(Tcl_Interp *interp);-gboolean tcl_signal_connect(struct tcl_signal_handler *handler);-void tcl_signal_disconnect(void *instance, const char *signal, Tcl_Interp *interp);-void tcl_cmd_init(void);-void tcl_cmd_handler_free(struct tcl_cmd_handler *handler);-void tcl_cmd_cleanup(Tcl_Interp *interp);-PurpleCmdId tcl_cmd_register(struct tcl_cmd_handler *handler);-void tcl_cmd_unregister(PurpleCmdId id, Tcl_Interp *interp);-void purple_tcl_ref_init(void);-void *purple_tcl_ref_get(Tcl_Interp *interp, Tcl_Obj *obj, PurpleStringref *type);-Tcl_Obj *purple_tcl_ref_new(PurpleStringref *type, void *value);-Tcl_ObjCmdProc tcl_cmd_account;-Tcl_ObjCmdProc tcl_cmd_signal_connect;-Tcl_ObjCmdProc tcl_cmd_buddy;-Tcl_ObjCmdProc tcl_cmd_cmd;-Tcl_ObjCmdProc tcl_cmd_connection;-Tcl_ObjCmdProc tcl_cmd_conversation;-Tcl_ObjCmdProc tcl_cmd_core;-Tcl_ObjCmdProc tcl_cmd_debug;-Tcl_ObjCmdProc tcl_cmd_notify;-Tcl_ObjCmdProc tcl_cmd_plugins;-Tcl_ObjCmdProc tcl_cmd_prefs;-Tcl_ObjCmdProc tcl_cmd_presence;-Tcl_ObjCmdProc tcl_cmd_savedstatus;-Tcl_ObjCmdProc tcl_cmd_send_im;-Tcl_ObjCmdProc tcl_cmd_signal;-Tcl_ObjCmdProc tcl_cmd_status;-Tcl_ObjCmdProc tcl_cmd_status_attr;-Tcl_ObjCmdProc tcl_cmd_status_type;-Tcl_ObjCmdProc tcl_cmd_unload;-#endif /* _PURPLE_TCL_PURPLE_H_ */--- a/libpurple/plugins/tcl/tcl_ref.c Tue Mar 08 20:31:03 2016 -0600
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,156 +0,0 @@
- * @file tcl_ref.c Purple Tcl typed references API- * Copyright (C) 2006 Ethan Blanton <eblanton@cs.purdue.edu>- * 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-/* Instead of all that internal representation mumbo jumbo, use these- * macros to access the internal representation of a PurpleTclRef */-#define OBJ_REF_TYPE(obj) (obj->internalRep.twoPtrValue.ptr1)-#define OBJ_REF_VALUE(obj) (obj->internalRep.twoPtrValue.ptr2)-static Tcl_FreeInternalRepProc purple_tcl_ref_free;-static Tcl_DupInternalRepProc purple_tcl_ref_dup;-static Tcl_UpdateStringProc purple_tcl_ref_update;-static Tcl_SetFromAnyProc purple_tcl_ref_set;-static Tcl_ObjType purple_tcl_ref = {-void purple_tcl_ref_init()- Tcl_RegisterObjType(&purple_tcl_ref);-void *purple_tcl_ref_get(Tcl_Interp *interp, Tcl_Obj *obj, PurpleStringref *type)- if (obj->typePtr != &purple_tcl_ref) {- if (Tcl_ConvertToType(interp, obj, &purple_tcl_ref) != TCL_OK)- if (strcmp(purple_stringref_value(OBJ_REF_TYPE(obj)),- purple_stringref_value(type))) {- Tcl_Obj *error = Tcl_NewStringObj("Bad Purple reference type: expected ", -1);- Tcl_AppendToObj(error, purple_stringref_value(type), -1);- Tcl_AppendToObj(error, " but got ", -1);- Tcl_AppendToObj(error, purple_stringref_value(OBJ_REF_TYPE(obj)), -1);- Tcl_SetObjResult(interp, error);- return OBJ_REF_VALUE(obj);-Tcl_Obj *purple_tcl_ref_new(PurpleStringref *type, void *value)- Tcl_Obj *obj = Tcl_NewObj();- obj->typePtr = &purple_tcl_ref;- OBJ_REF_TYPE(obj) = purple_stringref_ref(type);- OBJ_REF_VALUE(obj) = value;- Tcl_InvalidateStringRep(obj);-static void purple_tcl_ref_free(Tcl_Obj *obj)- purple_stringref_unref(OBJ_REF_TYPE(obj));-static void purple_tcl_ref_dup(Tcl_Obj *obj1, Tcl_Obj *obj2)- OBJ_REF_TYPE(obj2) = purple_stringref_ref(OBJ_REF_TYPE(obj1));- OBJ_REF_VALUE(obj2) = OBJ_REF_VALUE(obj1);-static void purple_tcl_ref_update(Tcl_Obj *obj)- /* This is ugly on memory, but we pretty much have to either- * do this or guesstimate lengths or introduce a varargs- * function in here ... ugh. */- char *bytes = g_strdup_printf("purple-%s:%p",- purple_stringref_value(OBJ_REF_TYPE(obj)),- obj->length = strlen(bytes);- obj->bytes = ckalloc(len);- g_strlcpy(obj->bytes, bytes, len);-/* This isn't as memory-efficient as setting could be, because we- * essentially have to synthesize the Stringref here, where we would- * really rather dup it. Oh, well. */-static int purple_tcl_ref_set(Tcl_Interp *interp, Tcl_Obj *obj)- char *bytes = Tcl_GetStringFromObj(obj, NULL);- static const char prefix[] = "purple-";- static const gsize prefixlen = sizeof(prefix) - 1;- if (strlen(bytes) < prefixlen- || strncmp(bytes, prefix, prefixlen)- || (ptr = strchr(bytes, ':')) == NULL- || (gsize)(ptr - bytes) == prefixlen)- type = purple_stringref_new(bytes + prefixlen);- if (sscanf(ptr, "%p", &value) == 0) {- purple_stringref_unref(type);- /* At this point we know we have a good object; free the old and- * install our internal representation. */- if (obj->typePtr != NULL && obj->typePtr->freeIntRepProc != NULL)- obj->typePtr->freeIntRepProc(obj);- obj->typePtr = &purple_tcl_ref;- OBJ_REF_TYPE(obj) = type;- OBJ_REF_VALUE(obj) = value;- Tcl_SetObjResult(interp,- Tcl_NewStringObj("invalid PurpleTclRef representation", -1));--- a/libpurple/plugins/tcl/tcl_signals.c Tue Mar 08 20:31:03 2016 -0600
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,404 +0,0 @@
- * @file tcl_signals.c Purple Tcl signal API- * Copyright (C) 2003 Ethan Blanton <eblanton@cs.purdue.edu>- * 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 "conversation.h"-static GList *tcl_callbacks;-static void *tcl_signal_callback(va_list args, struct tcl_signal_handler *handler);-static Tcl_Obj *new_cb_namespace (void);-void tcl_signal_handler_free(struct tcl_signal_handler *handler)- Tcl_DecrRefCount(handler->signal);- if (handler->namespace)- Tcl_DecrRefCount(handler->namespace);-void tcl_signal_cleanup(Tcl_Interp *interp)- struct tcl_signal_handler *handler;- for (cur = tcl_callbacks; cur != NULL; cur = g_list_next(cur)) {- if (handler->interp == interp) {- tcl_signal_handler_free(handler);- tcl_callbacks = g_list_remove_all(tcl_callbacks, NULL);-gboolean tcl_signal_connect(struct tcl_signal_handler *handler)- purple_signal_get_types(handler->instance,- Tcl_GetString(handler->signal),- &handler->returntype, &handler->nargs,- tcl_signal_disconnect(handler->interp, Tcl_GetString(handler->signal),- if (!purple_signal_connect_vargs(handler->instance,- Tcl_GetString(handler->signal),- (void *)handler->interp,- PURPLE_CALLBACK(tcl_signal_callback),- handler->namespace = new_cb_namespace ();- Tcl_IncrRefCount(handler->namespace);- proc = g_string_new("");- g_string_append_printf(proc, "namespace eval %s { proc cb { %s } { %s } }",- Tcl_GetString(handler->namespace),- Tcl_GetString(handler->args),- Tcl_GetString(handler->proc));- if (Tcl_Eval(handler->interp, proc->str) != TCL_OK) {- Tcl_DecrRefCount(handler->namespace);- g_string_free(proc, TRUE);- g_string_free(proc, TRUE);- tcl_callbacks = g_list_append(tcl_callbacks, (gpointer)handler);-void tcl_signal_disconnect(void *instance, const char *signal, Tcl_Interp *interp)- struct tcl_signal_handler *handler;- gboolean found = FALSE;- for (cur = tcl_callbacks; cur != NULL; cur = g_list_next(cur)) {- if (handler->interp == interp && handler->instance == instance- && !strcmp(signal, Tcl_GetString(handler->signal))) {- purple_signal_disconnect(instance, signal, handler->interp,- PURPLE_CALLBACK(tcl_signal_callback));- cmd = g_string_sized_new(64);- g_string_printf(cmd, "namespace delete %s",- Tcl_GetString(handler->namespace));- Tcl_EvalEx(interp, cmd->str, -1, TCL_EVAL_GLOBAL);- tcl_signal_handler_free(handler);- g_string_free(cmd, TRUE);- tcl_callbacks = g_list_remove_all(tcl_callbacks, NULL);-static PurpleStringref *ref_purple_type(GType type)- if (type == PURPLE_TYPE_ACCOUNT)- return PurpleTclRefAccount;- else if (type == PURPLE_TYPE_CONNECTION)- return PurpleTclRefConnection;- else if (type == PURPLE_TYPE_CONVERSATION)- return PurpleTclRefConversation;- else if (type == PURPLE_TYPE_PLUGIN)- return PurpleTclRefPlugin;- else if (type == PURPLE_TYPE_STATUS)- return PurpleTclRefStatus;- else if (type == PURPLE_TYPE_XFER)- return PurpleTclRefXfer;-static void *tcl_signal_callback(va_list args, struct tcl_signal_handler *handler)- Tcl_Obj *cmd, *arg, *result;- void **vals; /* Used for inout parameters */- vals = g_new0(void *, handler->nargs);- strs = g_new0(char **, handler->nargs);- name = g_string_sized_new(32);- val = g_string_sized_new(32);- cmd = Tcl_NewListObj(0, NULL);- arg = Tcl_DuplicateObj(handler->namespace);- Tcl_AppendStringsToObj(arg, "::cb", NULL);- Tcl_ListObjAppendElement(handler->interp, cmd, arg);- for (i = 0; i < handler->nargs; i++) {- if (purple_value_is_outgoing(handler->argtypes[i]))- g_string_printf(name, "%s::arg%d",- Tcl_GetString(handler->namespace), i);- switch(handler->argtypes[i]) {- /* These are all "pointer" types to us */- if (purple_value_is_outgoing(handler->argtypes[i]))- purple_debug_error("tcl", "pointer types do not currently support outgoing arguments\n");- arg = purple_tcl_ref_new(PurpleTclRefPointer, va_arg(args, void *));- if (purple_value_is_outgoing(handler->argtypes[i])) {- vals[i] = va_arg(args, gboolean *);- Tcl_LinkVar(handler->interp, name->str,- (char *)&vals[i], TCL_LINK_BOOLEAN);- arg = Tcl_NewStringObj(name->str, -1);- arg = Tcl_NewBooleanObj(va_arg(args, gboolean));- /* I should really cast these individually to- * preserve as much information as possible ...- if (purple_value_is_outgoing(handler->argtypes[i])) {- vals[i] = va_arg(args, int *);- Tcl_LinkVar(handler->interp, name->str,- vals[i], TCL_LINK_INT);- arg = Tcl_NewStringObj(name->str, -1);- arg = Tcl_NewIntObj(va_arg(args, int));- /* Tcl < 8.4 doesn't have wide ints, so we have ugly- if (purple_value_is_outgoing(handler->argtypes[i])) {- vals[i] = (void *)va_arg(args, gint64 *);- #if (TCL_MAJOR_VERSION >= 8 && TCL_MINOR_VERSION >= 4)- Tcl_LinkVar(handler->interp, name->str,- vals[i], TCL_LINK_WIDE_INT);- /* This is going to cause weirdness at best,- * but what do you want ... we're losing- Tcl_LinkVar(handler->interp, name->str,- vals[i], TCL_LINK_INT);- #endif /* Tcl >= 8.4 */- arg = Tcl_NewStringObj(name->str, -1);- #if (TCL_MAJOR_VERSION >= 8 && TCL_MINOR_VERSION >= 4)- arg = Tcl_NewWideIntObj(va_arg(args, gint64));- arg = Tcl_NewIntObj((int)va_arg(args, int));- #endif /* Tcl >= 8.4 */- if (purple_value_is_outgoing(handler->argtypes[i])) {- strs[i] = va_arg(args, char **);- if (strs[i] == NULL || *strs[i] == NULL) {- *(char *)vals[i] = '\0';- size_t len = strlen(*strs[i]) + 1;- vals[i] = ckalloc(len);- g_strlcpy(vals[i], *strs[i], len);- Tcl_LinkVar(handler->interp, name->str,- (char *)&vals[i], TCL_LINK_STRING);- arg = Tcl_NewStringObj(name->str, -1);- arg = Tcl_NewStringObj(va_arg(args, char *), -1);- if (handler->argtypes[i] == PURPLE_TYPE_ACCOUNT ||- handler->argtypes[i] == PURPLE_TYPE_CONNECTION ||- handler->argtypes[i] == PURPLE_TYPE_CONVERSATION ||- handler->argtypes[i] == PURPLE_TYPE_STATUS ||- handler->argtypes[i] == PURPLE_TYPE_PLUGIN ||- handler->argtypes[i] == PURPLE_TYPE_XFER )- if (purple_value_is_outgoing(handler->argtypes[i]))- purple_debug_error("tcl", "pointer subtypes do not currently support outgoing arguments\n");- arg = purple_tcl_ref_new(ref_purple_type(handler->argtypes[i]), va_arg(args, void *));- if (handler->argtypes[i] == PURPLE_TYPE_CONTACT ||- handler->argtypes[i] == PURPLE_TYPE_BUDDY ||- handler->argtypes[i] == PURPLE_TYPE_GROUP ||- handler->argtypes[i] == PURPLE_TYPE_CHAT )- /* We're going to switch again for code-deduping */- if (purple_value_is_outgoing(handler->argtypes[i]))- node = *va_arg(args, PurpleBlistNode **);- node = va_arg(args, PurpleBlistNode *);- if (PURPLE_IS_GROUP(node)) {- arg = Tcl_NewListObj(0, NULL);- Tcl_ListObjAppendElement(handler->interp, arg,- Tcl_NewStringObj("group", -1));- Tcl_ListObjAppendElement(handler->interp, arg,- Tcl_NewStringObj(purple_group_get_name(PURPLE_GROUP(node)), -1));- } else if (PURPLE_IS_CONTACT(node)) {- /* g_string_printf(val, "contact {%s}", Contact Name? ); */- arg = Tcl_NewStringObj("contact", -1);- } else if (PURPLE_IS_BUDDY(node)) {- arg = Tcl_NewListObj(0, NULL);- Tcl_ListObjAppendElement(handler->interp, arg,- Tcl_NewStringObj("buddy", -1));- Tcl_ListObjAppendElement(handler->interp, arg,- Tcl_NewStringObj(purple_buddy_get_name(PURPLE_BUDDY(node)), -1));- Tcl_ListObjAppendElement(handler->interp, arg,- purple_tcl_ref_new(PurpleTclRefAccount,- purple_buddy_get_account(PURPLE_BUDDY(node))));- } else if (PURPLE_IS_CHAT(node)) {- arg = Tcl_NewListObj(0, NULL);- Tcl_ListObjAppendElement(handler->interp, arg,- Tcl_NewStringObj("chat", -1));- Tcl_ListObjAppendElement(handler->interp, arg,- Tcl_NewStringObj(purple_chat_get_name(PURPLE_CHAT(node)), -1));- Tcl_ListObjAppendElement(handler->interp, arg,- purple_tcl_ref_new(PurpleTclRefAccount,- purple_chat_get_account(PURPLE_CHAT(node))));- else if (G_TYPE_IS_ENUM(handler->argtypes[i]))- arg = Tcl_NewIntObj(va_arg(args, int));- /* What? I guess just pass the word ... */- /* treat this as a pointer, but complain first */- purple_debug(PURPLE_DEBUG_ERROR, "tcl", "unknown type %s\n",- g_type_name(handler->argtypes[i]));- Tcl_ListObjAppendElement(handler->interp, cmd, arg);- /* Call the friggin' procedure already */- if (Tcl_EvalObjEx(handler->interp, cmd, TCL_EVAL_GLOBAL) != TCL_OK) {- purple_debug(PURPLE_DEBUG_ERROR, "tcl", "error evaluating callback: %s\n",- Tcl_GetString(Tcl_GetObjResult(handler->interp)));- result = Tcl_GetObjResult(handler->interp);- /* handle return values -- strings and words only */- if (handler->returntype) {- if (handler->returntype == G_TYPE_STRING) {- retval = (void *)g_strdup(Tcl_GetString(result));- if (Tcl_GetIntFromObj(handler->interp, result, (int *)&retval) != TCL_OK) {- purple_debug(PURPLE_DEBUG_ERROR, "tcl", "Error retrieving procedure result: %s\n",- Tcl_GetString(Tcl_GetObjResult(handler->interp)));- /* And finally clean up */- for (i = 0; i < handler->nargs; i++) {- g_string_printf(name, "%s::arg%d",- Tcl_GetString(handler->namespace), i);- if (purple_value_is_outgoing(handler->argtypes[i])- && purple_value_get_type(handler->argtypes[i]) != G_TYPE_SUBTYPE)- Tcl_UnlinkVar(handler->interp, name->str);- /* We basically only have to deal with strings on the- switch (handler->argtypes[i]) {- if (purple_value_is_outgoing(handler->argtypes[i])) {- if (vals[i] != NULL && *(char **)vals[i] != NULL) {- *strs[i] = g_strdup(vals[i]);- g_string_free(name, TRUE);- g_string_free(val, TRUE);-static Tcl_Obj *new_cb_namespace ()- g_snprintf (name, sizeof(name), "::purple::_callback::cb_%d", cbnum++);- return Tcl_NewStringObj (name, -1);
