changeset
Remove the tcl loader
Tue, 08 Mar 2016 20:31:18 -0600
- author
- Gary Kramlich <grim@reaperworld.com>
- date
- Tue, 08 Mar 2016 20:31:18 -0600
- changeset 37581
- 1fb661b5f206
- parent 37580
- 498763742ea4
- child 37582
- ca3533cdddc7
Remove the tcl loader
| libpurple/plugins/tcl/Makefile.am | file | annotate | diff | comparison | revisions | |
| libpurple/plugins/tcl/Makefile.mingw | file | annotate | diff | comparison | revisions | |
| libpurple/plugins/tcl/signal-test.tcl | file | annotate | diff | comparison | revisions | |
| libpurple/plugins/tcl/tcl.c | file | annotate | diff | comparison | revisions | |
| libpurple/plugins/tcl/tcl_cmd.c | file | annotate | diff | comparison | revisions | |
| libpurple/plugins/tcl/tcl_cmds.c | file | annotate | diff | comparison | revisions | |
| libpurple/plugins/tcl/tcl_glib.c | file | annotate | diff | comparison | revisions | |
| libpurple/plugins/tcl/tcl_glib.h | file | annotate | diff | comparison | revisions | |
| libpurple/plugins/tcl/tcl_purple.h | file | annotate | diff | comparison | revisions | |
| libpurple/plugins/tcl/tcl_ref.c | file | annotate | diff | comparison | revisions | |
| libpurple/plugins/tcl/tcl_signals.c | file | annotate | diff | comparison | revisions |
--- 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_ref.c tcl_cmd.c - -tcl_la_LIBADD = @PURPLE_LIBS@ $(GPLUGIN_LIBS) $(TCL_LIBS) $(TK_LIBS) - -EXTRA_DIST = signal-test.tcl Makefile.mingw - -AM_CPPFLAGS = \ - -I$(top_srcdir) \ - -I$(top_srcdir)/libpurple \ - -I$(top_builddir)/libpurple \ - $(DEBUG_CFLAGS) \ - $(GLIB_CFLAGS) \ - $(GPLUGIN_CFLAGS) \ - $(PLUGIN_CFLAGS) \ - $(TK_CFLAGS) \ - $(TCL_CFLAGS)
--- 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 @@ -# -# Makefile.mingw -# -# Description: Makefile for tcl plugin loader plugin. -# - -PIDGIN_TREE_TOP := ../../.. -include $(PIDGIN_TREE_TOP)/libpurple/win32/global.mak - -TARGET = tcl -TCL_INC_DIR := $(TCL_LIB_TOP)/include -DEFINES += -DHAVE_TK -DUSE_TCL_STUBS -DUSE_TK_STUBS - -## -## INCLUDE PATHS -## -INCLUDE_PATHS += -I. \ - -I$(PIDGIN_TREE_TOP) \ - -I$(PURPLE_TOP) \ - -I$(PURPLE_TOP)/win32 \ - -I$(GTK_TOP)/include \ - -I$(GTK_TOP)/include/glib-2.0 \ - -I$(GTK_TOP)/lib/glib-2.0/include \ - -I$(TCL_INC_DIR) - -LIB_PATHS += -L$(GTK_TOP)/lib \ - -L$(PURPLE_TOP) \ - -L$(TCL_LIB_TOP)/lib - -## -## SOURCES, OBJECTS -## -C_SRC = tcl.c \ - tcl_cmd.c \ - tcl_cmds.c \ - tcl_glib.c \ - tcl_ref.c \ - tcl_signals.c - -OBJECTS = $(C_SRC:%.c=%.o) - -## -## LIBRARIES -## -LIBS = \ - -lglib-2.0 \ - -lgobject-2.0 \ - -lws2_32 \ - -lintl \ - -lpurple \ - -ltclstub85 \ - -ltkstub85 - -include $(PIDGIN_COMMON_RULES) - -## -## TARGET DEFINITIONS -## -.PHONY: all install clean - -all: $(TARGET).dll - -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 - -## -## CLEAN RULES -## -clean: - rm -rf $(OBJECTS) - rm -rf $(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\"" - return 0 -} - -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\"" - return 0 -} - -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\"" - return 0 -} - -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\"" - return 0 -} - -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]]" -} - -if { 0 } { -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]" -} - -proc plugin_init { } { - list "Tcl Signal Test" \ - "$purple::version" \ - "Tests Tcl signal handlers" \ - "Debugs a ridiculous amount of signal information." \ - "Ethan Blanton <elb@pidgin.im>" \ - "https://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 - * - * purple - * - * 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 "config.h" - -#include <tcl.h> - -#ifdef HAVE_TK -#include <tk.h> -#endif - -#include <stdio.h> -#include <sys/types.h> -#include <unistd.h> -#include <string.h> - -#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 <eblanton@cs.purdue.edu>", - 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);
--- 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 - * - * purple - * - * 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 - */ -#include <tcl.h> - -#include "tcl_purple.h" - -#include "internal.h" -#include "cmds.h" -#include "debug.h" - -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); - -void tcl_cmd_init() -{ - tcl_cmd_callbacks = NULL; -} - -void tcl_cmd_handler_free(struct tcl_cmd_handler *handler) -{ - if (handler == NULL) - return; - - Tcl_DecrRefCount(handler->namespace); - g_free(handler); -} - -void tcl_cmd_cleanup(Tcl_Interp *interp) -{ - GList *cur; - struct tcl_cmd_handler *handler; - - for (cur = tcl_cmd_callbacks; cur != NULL; cur = g_list_next(cur)) { - handler = cur->data; - if (handler->interp == interp) { - purple_cmd_unregister(handler->id); - tcl_cmd_handler_free(handler); - cur->data = NULL; - } - } - tcl_cmd_callbacks = g_list_remove_all(tcl_cmd_callbacks, NULL); -} - -PurpleCmdId tcl_cmd_register(struct tcl_cmd_handler *handler) -{ - int id; - GString *proc; - - 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) - return 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); - return 0; - } - g_string_free(proc, TRUE); - - tcl_cmd_callbacks = g_list_append(tcl_cmd_callbacks, (gpointer)handler); - - return id; -} - -void tcl_cmd_unregister(PurpleCmdId id, Tcl_Interp *interp) -{ - GList *cur; - GString *cmd; - gboolean found = FALSE; - struct tcl_cmd_handler *handler; - - for (cur = tcl_cmd_callbacks; cur != NULL; cur = g_list_next(cur)) { - handler = cur->data; - 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); - cur->data = NULL; - found = TRUE; - break; - } - } - - if (found) - 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) -{ - int retval, i; - Tcl_Obj *command, *arg, *tclargs, *result; - - command = Tcl_NewListObj(0, NULL); - Tcl_IncrRefCount(command); - - /* The callback */ - arg = Tcl_DuplicateObj(handler->namespace); - Tcl_AppendStringsToObj(arg, "::cb", NULL); - Tcl_ListObjAppendElement(handler->interp, command, arg); - - /* The conversation */ - arg = purple_tcl_ref_new(PurpleTclRefConversation, conv); - Tcl_ListObjAppendElement(handler->interp, command, arg); - - /* The command */ - arg = Tcl_NewStringObj(cmd, -1); - Tcl_ListObjAppendElement(handler->interp, command, arg); - - /* The args list */ - 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) { - gchar *errorstr; - - errorstr = g_strdup_printf("error evaluating callback: %s\n", - Tcl_GetString(Tcl_GetObjResult(handler->interp))); - purple_debug(PURPLE_DEBUG_ERROR, "tcl", "%s", errorstr); - *errors = errorstr; - retval = PURPLE_CMD_RET_FAILED; - } else { - result = Tcl_GetObjResult(handler->interp); - if (Tcl_GetIntFromObj(handler->interp, result, - &retval) != TCL_OK) { - gchar *errorstr; - - errorstr = g_strdup_printf("Error retreiving procedure result: %s\n", - Tcl_GetString(Tcl_GetObjResult(handler->interp))); - purple_debug(PURPLE_DEBUG_ERROR, "tcl", "%s", errorstr); - *errors = errorstr; - retval = PURPLE_CMD_RET_FAILED; - } - } - - return retval; -} - -static Tcl_Obj *new_cmd_cb_namespace() -{ - char name[32]; - static int cbnum; - - g_snprintf(name, sizeof(name), "::purple::_cmd_callback::cb_%d", - cbnum++); - 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 - * - * purple - * - * 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 <tcl.h> - -#include "internal.h" -#include "conversation.h" -#include "connection.h" -#include "eventloop.h" -#include "account.h" -#include "server.h" -#include "notify.h" -#include "buddylist.h" -#include "savedstatuses.h" -#include "debug.h" -#include "prefs.h" -#include "presence.h" -#include "core.h" - -#include "tcl_purple.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; - GList *cur; - - account = purple_tcl_ref_get(interp, obj, PurpleTclRefAccount); - - if (account == NULL) - return NULL; - - for (cur = purple_accounts_get_all(); cur != NULL; cur = g_list_next(cur)) { - if (account == cur->data) - return account; - } - if (interp != NULL) - Tcl_SetObjResult(interp, Tcl_NewStringObj("invalid account", -1)); - return NULL; -} - -static PurpleConversation *tcl_validate_conversation(Tcl_Obj *obj, Tcl_Interp *interp) -{ - PurpleConversation *convo; - GList *cur; - - convo = purple_tcl_ref_get(interp, obj, PurpleTclRefConversation); - - if (convo == NULL) - return NULL; - - for (cur = purple_conversations_get_all(); cur != NULL; cur = g_list_next(cur)) { - if (convo == cur->data) - return convo; - } - if (interp != NULL) - Tcl_SetObjResult(interp, Tcl_NewStringObj("invalid conversation", -1)); - return NULL; -} - -static PurpleConnection *tcl_validate_gc(Tcl_Obj *obj, Tcl_Interp *interp) -{ - PurpleConnection *gc; - GList *cur; - - gc = purple_tcl_ref_get(interp, obj, PurpleTclRefConnection); - - if (gc == NULL) - return NULL; - - for (cur = purple_connections_get_all(); cur != NULL; cur = g_list_next(cur)) { - if (gc == cur->data) - return gc; - } - return NULL; -} - -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", - NULL }; - 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; - const char *alias; - GList *cur; - PurpleAccount *account; - PurpleStatus *status; - PurpleStatusType *status_type; - GValue *value; - char *attr_id; - int error; - int b, i; - - if (objc < 2) { - Tcl_WrongNumArgs(interp, 1, objv, "subcommand ?args?"); - return TCL_ERROR; - } - - if ((error = Tcl_GetIndexFromObj(interp, objv[1], cmds, "subcommand", 0, (int *)&cmd)) != TCL_OK) - return error; - - switch (cmd) { - case CMD_ACCOUNT_ALIAS: - if (objc != 3) { - Tcl_WrongNumArgs(interp, 2, objv, "account"); - return TCL_ERROR; - } - if ((account = tcl_validate_account(objv[2], interp)) == NULL) - return TCL_ERROR; - alias = purple_account_get_private_alias(account); - Tcl_SetObjResult(interp, Tcl_NewStringObj(alias ? (char *)alias : "", -1)); - break; - case CMD_ACCOUNT_CONNECT: - if (objc != 3) { - Tcl_WrongNumArgs(interp, 2, objv, "account"); - return TCL_ERROR; - } - if ((account = tcl_validate_account(objv[2], interp)) == NULL) - return TCL_ERROR; - if (!purple_account_is_connected(account)) - purple_account_connect(account); - Tcl_SetObjResult(interp, - purple_tcl_ref_new(PurpleTclRefConnection, - purple_account_get_connection(account))); - break; - case CMD_ACCOUNT_CONNECTION: - if (objc != 3) { - Tcl_WrongNumArgs(interp, 2, objv, "account"); - return TCL_ERROR; - } - - if ((account = tcl_validate_account(objv[2], interp)) == NULL) - return TCL_ERROR; - Tcl_SetObjResult(interp, - purple_tcl_ref_new(PurpleTclRefConnection, - purple_account_get_connection(account))); - break; - case CMD_ACCOUNT_DISCONNECT: - if (objc != 3) { - Tcl_WrongNumArgs(interp, 2, objv, "account"); - return TCL_ERROR; - } - if ((account = tcl_validate_account(objv[2], interp)) == NULL) - return TCL_ERROR; - purple_account_disconnect(account); - break; - case CMD_ACCOUNT_ENABLED: - if (objc != 3 && objc != 4) { - Tcl_WrongNumArgs(interp, 2, objv, "account ?enabled?"); - return TCL_ERROR; - } - if ((account = tcl_validate_account(objv[2], interp)) == NULL) - return TCL_ERROR; - if (objc == 3) { - Tcl_SetObjResult(interp, - Tcl_NewBooleanObj( - purple_account_get_enabled(account, - purple_core_get_ui()))); - } else { - if ((error = Tcl_GetBooleanFromObj(interp, objv[3], &b)) != TCL_OK) - return TCL_ERROR; - purple_account_set_enabled(account, purple_core_get_ui(), b); - } - break; - case CMD_ACCOUNT_FIND: - if (objc != 4) { - Tcl_WrongNumArgs(interp, 2, objv, "username protocol"); - return TCL_ERROR; - } - account = purple_accounts_find(Tcl_GetString(objv[2]), - Tcl_GetString(objv[3])); - Tcl_SetObjResult(interp, - purple_tcl_ref_new(PurpleTclRefAccount, account)); - break; - case CMD_ACCOUNT_HANDLE: - if (objc != 2) { - Tcl_WrongNumArgs(interp, 2, objv, ""); - return TCL_ERROR; - } - Tcl_SetObjResult(interp, - purple_tcl_ref_new(PurpleTclRefHandle, - purple_accounts_get_handle())); - break; - case CMD_ACCOUNT_ISCONNECTED: - if (objc != 3) { - Tcl_WrongNumArgs(interp, 2, objv, "account"); - return TCL_ERROR; - } - if ((account = tcl_validate_account(objv[2], interp)) == NULL) - return TCL_ERROR; - Tcl_SetObjResult(interp, - Tcl_NewBooleanObj( - purple_account_is_connected(account))); - break; - case CMD_ACCOUNT_LIST: - listopt = CMD_ACCOUNTLIST_ALL; - if (objc > 3) { - Tcl_WrongNumArgs(interp, 2, objv, "?option?"); - return TCL_ERROR; - } - if (objc == 3) { - if ((error = Tcl_GetIndexFromObj(interp, objv[2], listopts, "option", 0, (int *)&listopt)) != TCL_OK) - return error; - } - list = Tcl_NewListObj(0, NULL); - for (cur = purple_accounts_get_all(); cur != NULL; cur = g_list_next(cur)) { - account = cur->data; - if (listopt == CMD_ACCOUNTLIST_ONLINE && !purple_account_is_connected(account)) - continue; - elem = purple_tcl_ref_new(PurpleTclRefAccount, account); - Tcl_ListObjAppendElement(interp, list, elem); - } - Tcl_SetObjResult(interp, list); - break; - case CMD_ACCOUNT_PRESENCE: - if (objc != 3) { - Tcl_WrongNumArgs(interp, 2, objv, "account"); - return TCL_ERROR; - } - if ((account = tcl_validate_account(objv[2], interp)) == NULL) - return TCL_ERROR; - Tcl_SetObjResult(interp, purple_tcl_ref_new(PurpleTclRefPresence, - purple_account_get_presence(account))); - break; - case CMD_ACCOUNT_PROTOCOL: - if (objc != 3) { - Tcl_WrongNumArgs(interp, 2, objv, "account"); - return TCL_ERROR; - } - if ((account = tcl_validate_account(objv[2], interp)) == NULL) - return TCL_ERROR; - Tcl_SetObjResult(interp, Tcl_NewStringObj((char *)purple_account_get_protocol_id(account), -1)); - break; - case CMD_ACCOUNT_STATUS: - if (objc < 3) { - Tcl_WrongNumArgs(interp, 2, objv, "account ?status_id name value ...?"); - return TCL_ERROR; - } - if ((account = tcl_validate_account(objv[2], interp)) == NULL) - return TCL_ERROR; - if (objc == 3) { - Tcl_SetObjResult(interp, - purple_tcl_ref_new(PurpleTclRefStatus, - purple_account_get_active_status(account))); - } else { - GList *l = NULL; - if (objc % 2) { - Tcl_SetObjResult(interp, Tcl_NewStringObj("name without value setting status", -1)); - return TCL_ERROR; - } - status = purple_account_get_status(account, Tcl_GetString(objv[3])); - if (status == NULL) { - Tcl_SetObjResult(interp, Tcl_NewStringObj("invalid status for account", -1)); - return TCL_ERROR; - } - for (i = 4; i < objc; i += 2) { - attr_id = Tcl_GetString(objv[i]); - value = purple_status_get_attr_value(status, attr_id); - if (value == NULL) { - Tcl_SetObjResult(interp, Tcl_NewStringObj("invalid attribute for account", -1)); - return TCL_ERROR; - } - switch (G_VALUE_TYPE(value)) { - case G_TYPE_BOOLEAN: - error = Tcl_GetBooleanFromObj(interp, objv[i + 1], &b); - if (error != TCL_OK) - return error; - l = g_list_append(l, attr_id); - l = g_list_append(l, GINT_TO_POINTER(b)); - break; - case G_TYPE_INT: - error = Tcl_GetIntFromObj(interp, objv[i + 1], &b); - if (error != TCL_OK) - return error; - l = g_list_append(l, attr_id); - l = g_list_append(l, GINT_TO_POINTER(b)); - break; - case G_TYPE_STRING: - l = g_list_append(l, attr_id); - l = g_list_append(l, Tcl_GetString(objv[i + 1])); - break; - default: - Tcl_SetObjResult(interp, Tcl_NewStringObj("unknown GValue type", -1)); - return TCL_ERROR; - } - } - purple_account_set_status_list(account, Tcl_GetString(objv[3]), TRUE, l); - g_list_free(l); - } - break; - case CMD_ACCOUNT_STATUS_TYPE: - if (objc != 4 && objc != 5) { - Tcl_WrongNumArgs(interp, 2, objv, "account ?statustype? ?-primitive primitive?"); - return TCL_ERROR; - } - if ((account = tcl_validate_account(objv[2], interp)) == NULL) - return TCL_ERROR; - if (objc == 4) { - status_type = purple_account_get_status_type(account, - Tcl_GetString(objv[3])); - } else { - 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); - return TCL_ERROR; - } - primitive = purple_primitive_get_type_from_id(Tcl_GetString(objv[4])); - status_type = purple_account_get_status_type_with_primitive(account, - primitive); - } - if (status_type == NULL) { - Tcl_SetObjResult(interp, Tcl_NewStringObj("status type not found", -1)); - return TCL_ERROR; - } - Tcl_SetObjResult(interp, - purple_tcl_ref_new(PurpleTclRefStatusType, - status_type)); - break; - case CMD_ACCOUNT_STATUS_TYPES: - if (objc != 3) { - Tcl_WrongNumArgs(interp, 2, objv, "account"); - return TCL_ERROR; - } - if ((account = tcl_validate_account(objv[2], interp)) == NULL) - return TCL_ERROR; - 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, - cur->data)); - } - Tcl_SetObjResult(interp, list); - break; - case CMD_ACCOUNT_USERNAME: - if (objc != 3) { - Tcl_WrongNumArgs(interp, 2, objv, "account"); - return TCL_ERROR; - } - if ((account = tcl_validate_account(objv[2], interp)) == NULL) - return TCL_ERROR; - Tcl_SetObjResult(interp, - Tcl_NewStringObj((char *)purple_account_get_username(account), -1)); - break; - } - - return TCL_OK; -} - -static PurpleBlistNode *tcl_list_to_buddy(Tcl_Interp *interp, int count, Tcl_Obj **elems) -{ - PurpleBlistNode *node = NULL; - PurpleAccount *account; - char *name; - char *type; - - if (count < 3) { - Tcl_SetObjResult(interp, - Tcl_NewStringObj("list too short", -1)); - return NULL; - } - - type = Tcl_GetString(elems[0]); - name = Tcl_GetString(elems[1]); - if ((account = tcl_validate_account(elems[2], interp)) == NULL) - return 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)); - } - - return node; -} - -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; - PurpleBuddy *bud; - PurpleChat *cnode; - int error, all = 0, count; - - if (objc < 2) { - Tcl_WrongNumArgs(interp, 1, objv, "subcommand ?args?"); - return TCL_ERROR; - } - if ((error = Tcl_GetIndexFromObj(interp, objv[1], cmds, "subcommand", 0, (int *)&cmd)) != TCL_OK) - return error; - - switch (cmd) { - case CMD_BUDDY_ALIAS: - if (objc != 3) { - Tcl_WrongNumArgs(interp, 2, objv, "buddy"); - return TCL_ERROR; - } - if ((error = Tcl_ListObjGetElements(interp, objv[2], &count, &elems)) != TCL_OK) - return error; - if ((node = tcl_list_to_buddy(interp, count, elems)) == NULL) - return TCL_ERROR; - 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)); - return TCL_OK; - break; - case CMD_BUDDY_HANDLE: - if (objc != 2) { - Tcl_WrongNumArgs(interp, 2, objv, ""); - return TCL_ERROR; - } - Tcl_SetObjResult(interp, - purple_tcl_ref_new(PurpleTclRefHandle, - purple_blist_get_handle())); - break; - case CMD_BUDDY_INFO: - if (objc != 3 && objc != 4) { - Tcl_WrongNumArgs(interp, 2, objv, "( buddy | account username )"); - return TCL_ERROR; - } - if (objc == 3) { - if ((error = Tcl_ListObjGetElements(interp, objv[2], &count, &elems)) != TCL_OK) - return error; - if (count < 3) { - Tcl_SetObjResult(interp, - Tcl_NewStringObj("buddy too short", -1)); - return TCL_ERROR; - } - if (strcmp("buddy", Tcl_GetString(elems[0]))) { - Tcl_SetObjResult(interp, - Tcl_NewStringObj("invalid buddy", -1)); - return TCL_ERROR; - } - if ((account = tcl_validate_account(elems[2], interp)) == NULL) - return TCL_ERROR; - purple_serv_get_info(purple_account_get_connection(account), Tcl_GetString(elems[1])); - } else { - if ((account = tcl_validate_account(objv[2], interp)) == NULL) - return TCL_ERROR; - purple_serv_get_info(purple_account_get_connection(account), Tcl_GetString(objv[3])); - } - break; - case CMD_BUDDY_LIST: - if (objc == 3) { - if (!strcmp("-all", Tcl_GetString(objv[2]))) { - all = 1; - } else { - result = Tcl_NewStringObj("",-1); - Tcl_AppendStringsToObj(result, "unknown option: ", Tcl_GetString(objv[2]), NULL); - Tcl_SetObjResult(interp,result); - return TCL_ERROR; - } - } - 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); - count = 0; - for (bnode = purple_blist_node_get_first_child(node); bnode != NULL; bnode = purple_blist_node_get_sibling_next(bnode)) { - if (!PURPLE_IS_BUDDY(bnode)) - continue; - bud = PURPLE_BUDDY(bnode); - account = purple_buddy_get_account(bud); - if (!all && !purple_account_is_connected(account)) - continue; - count++; - 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); - } - if (count) { - 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)) - continue; - 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); - } else { - purple_debug(PURPLE_DEBUG_WARNING, "tcl", "Unexpected buddy type %s", G_OBJECT_TYPE_NAME(node)); - continue; - } - } - Tcl_ListObjAppendElement(interp, tclgroup, tclgrouplist); - Tcl_ListObjAppendElement(interp, list, tclgroup); - } - Tcl_SetObjResult(interp, list); - break; - } - - return TCL_OK; -} - -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; - Tcl_Obj *list, *elem; - PurpleConversation *convo; - PurpleCmdId id; - PurpleCmdStatus status; - int error; - GList *l, *cur; - gchar *escaped, *errstr = NULL; - - if (objc < 2) { - Tcl_WrongNumArgs(interp, 1, objv, "subcommand ?args?"); - return TCL_ERROR; - } - - if ((error = Tcl_GetIndexFromObj(interp, objv[1], cmds, "subcommand", 0, (int *)&cmd)) != TCL_OK) - return error; - - switch (cmd) { - case CMD_CMD_DO: - if (objc != 4) { - Tcl_WrongNumArgs(interp, 2, objv, "conversation command"); - return TCL_ERROR; - } - if ((convo = tcl_validate_conversation(objv[2], interp)) == NULL) - return TCL_ERROR; - escaped = g_markup_escape_text(Tcl_GetString(objv[3]), -1); - status = purple_cmd_do_command(convo, Tcl_GetString(objv[3]), - escaped, &errstr); - g_free(escaped); - Tcl_SetObjResult(interp, - Tcl_NewStringObj(errstr ? (char *)errstr : "", -1)); - g_free(errstr); - if (status != PURPLE_CMD_STATUS_OK) { - return TCL_ERROR; - } - break; - case CMD_CMD_HELP: - if (objc != 4) { - Tcl_WrongNumArgs(interp, 2, objv, "conversation name"); - return TCL_ERROR; - } - if ((convo = tcl_validate_conversation(objv[2], interp)) == NULL) - return TCL_ERROR; - l = cur = purple_cmd_help(convo, Tcl_GetString(objv[3])); - list = Tcl_NewListObj(0, NULL); - while (cur != NULL) { - elem = Tcl_NewStringObj((char *)cur->data, -1); - Tcl_ListObjAppendElement(interp, list, elem); - cur = g_list_next(cur); - } - g_list_free(l); - Tcl_SetObjResult(interp, list); - break; - case CMD_CMD_LIST: - if (objc != 3) { - Tcl_WrongNumArgs(interp, 2, objv, "conversation"); - return TCL_ERROR; - } - if ((convo = tcl_validate_conversation(objv[2], interp)) == NULL) - return TCL_ERROR; - l = cur = purple_cmd_list(convo); - list = Tcl_NewListObj(0, NULL); - while (cur != NULL) { - elem = Tcl_NewStringObj((char *)cur->data, -1); - Tcl_ListObjAppendElement(interp, list, elem); - cur = g_list_next(cur); - } - g_list_free(l); - Tcl_SetObjResult(interp, list); - break; - case CMD_CMD_REGISTER: - if (objc != 9) { - Tcl_WrongNumArgs(interp, 2, objv, "cmd arglist priority flags protocol_id proc helpstr"); - return TCL_ERROR; - } - 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) { - g_free(handler); - return error; - } - if ((error = Tcl_GetIntFromObj(interp, objv[5], - &handler->flags)) != TCL_OK) { - g_free(handler); - return error; - } - 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)); - } else { - handler->id = id; - Tcl_SetObjResult(interp, Tcl_NewIntObj(id)); - } - break; - case CMD_CMD_UNREGISTER: - if (objc != 3) { - Tcl_WrongNumArgs(interp, 2, objv, "id"); - return TCL_ERROR; - } - if ((error = Tcl_GetIntFromObj(interp, objv[2], - (int *)&id)) != TCL_OK) - return error; - tcl_cmd_unregister(id, interp); - break; - } - - return TCL_OK; -} - -int tcl_cmd_connection(ClientData unused, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) -{ - Tcl_Obj *list, *elem; - 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; - int error; - GList *cur; - PurpleConnection *gc; - - if (objc < 2) { - Tcl_WrongNumArgs(interp, 1, objv, "subcommand ?args?"); - return TCL_ERROR; - } - - if ((error = Tcl_GetIndexFromObj(interp, objv[1], cmds, "subcommand", 0, (int *)&cmd)) != TCL_OK) - return error; - - switch (cmd) { - case CMD_CONN_ACCOUNT: - if (objc != 3) { - Tcl_WrongNumArgs(interp, 2, objv, "gc"); - return TCL_ERROR; - } - if ((gc = tcl_validate_gc(objv[2], interp)) == NULL) - return TCL_ERROR; - Tcl_SetObjResult(interp, - purple_tcl_ref_new(PurpleTclRefAccount, - purple_connection_get_account(gc))); - break; - case CMD_CONN_DISPLAYNAME: - if (objc != 3) { - Tcl_WrongNumArgs(interp, 2, objv, "gc"); - return TCL_ERROR; - } - if ((gc = tcl_validate_gc(objv[2], interp)) == NULL) - return TCL_ERROR; - Tcl_SetObjResult(interp, - Tcl_NewStringObj(purple_connection_get_display_name(gc), -1)); - break; - case CMD_CONN_HANDLE: - if (objc != 2) { - Tcl_WrongNumArgs(interp, 2, objv, ""); - return TCL_ERROR; - } - Tcl_SetObjResult(interp, purple_tcl_ref_new(PurpleTclRefHandle, - purple_connections_get_handle())); - break; - case CMD_CONN_LIST: - if (objc != 2) { - Tcl_WrongNumArgs(interp, 2, objv, ""); - return TCL_ERROR; - } - 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); - break; - case CMD_CONN_STATE: - if (objc != 3) { - Tcl_WrongNumArgs(interp, 2, objv, "gc"); - return TCL_ERROR; - } - if ((gc = tcl_validate_gc(objv[2], interp)) == NULL) - return TCL_ERROR; - switch (purple_connection_get_state(gc)) { - case PURPLE_CONNECTION_DISCONNECTED: - Tcl_SetObjResult(interp, Tcl_NewStringObj("disconnected", -1)); - break; - case PURPLE_CONNECTION_CONNECTED: - Tcl_SetObjResult(interp, Tcl_NewStringObj("connected", -1)); - break; - case PURPLE_CONNECTION_CONNECTING: - Tcl_SetObjResult(interp, Tcl_NewStringObj("connecting", -1)); - break; - } - break; - } - - return TCL_OK; -} - -int tcl_cmd_conversation(ClientData unused, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) -{ - Tcl_Obj *list, *elem; - 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; - PurpleMessage *pmsg; - gboolean is_chat = FALSE; - GList *cur; - char *opt, *from, *what; - int error, argsused; - - if (objc < 2) { - Tcl_WrongNumArgs(interp, 1, objv, "subcommand ?args?"); - return TCL_ERROR; - } - - if ((error = Tcl_GetIndexFromObj(interp, objv[1], cmds, "subcommand", 0, (int *)&cmd)) != TCL_OK) - return error; - - switch (cmd) { - case CMD_CONV_FIND: - if (objc != 4) { - Tcl_WrongNumArgs(interp, 2, objv, "account name"); - return TCL_ERROR; - } - account = NULL; - if ((account = tcl_validate_account(objv[2], interp)) == NULL) - return TCL_ERROR; - convo = purple_conversations_find_with_account(Tcl_GetString(objv[3]), - account); - Tcl_SetObjResult(interp, purple_tcl_ref_new(PurpleTclRefConversation, convo)); - break; - case CMD_CONV_HANDLE: - if (objc != 2) { - Tcl_WrongNumArgs(interp, 2, objv, ""); - return TCL_ERROR; - } - Tcl_SetObjResult(interp, - purple_tcl_ref_new(PurpleTclRefHandle, - purple_conversations_get_handle())); - break; - case CMD_CONV_LIST: - 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); - break; - case CMD_CONV_NEW: - if (objc < 4) { - Tcl_WrongNumArgs(interp, 2, objv, "?options? account name"); - return TCL_ERROR; - } - argsused = 2; - is_chat = FALSE; - while (argsused < objc) { - opt = Tcl_GetString(objv[argsused]); - if (*opt == '-') { - if ((error = Tcl_GetIndexFromObj(interp, objv[argsused], newopts, - "option", 0, (int *)&newopt)) != TCL_OK) - return error; - argsused++; - switch (newopt) { - case CMD_CONV_NEW_CHAT: - is_chat = TRUE; - break; - case CMD_CONV_NEW_IM: - is_chat = FALSE; - break; - } - } else { - break; - } - } - if (objc - argsused != 2) { - Tcl_WrongNumArgs(interp, 2, objv, "?options? account name"); - return TCL_ERROR; - } - if ((account = tcl_validate_account(objv[argsused++], interp)) == NULL) - return TCL_ERROR; - if (is_chat) - convo = PURPLE_CONVERSATION(purple_chat_conversation_new(account, Tcl_GetString(objv[argsused]))); - else - convo = PURPLE_CONVERSATION(purple_im_conversation_new(account, Tcl_GetString(objv[argsused]))); - Tcl_SetObjResult(interp, purple_tcl_ref_new(PurpleTclRefConversation, convo)); - break; - case CMD_CONV_WRITE: - if (objc != 6) { - Tcl_WrongNumArgs(interp, 2, objv, "conversation style from what"); - return TCL_ERROR; - } - if ((convo = tcl_validate_conversation(objv[2], interp)) == NULL) - return TCL_ERROR; - if ((error = Tcl_GetIndexFromObj(interp, objv[3], styles, "style", 0, (int *)&style)) != TCL_OK) - return error; - from = Tcl_GetString(objv[4]); - what = Tcl_GetString(objv[5]); - - switch (style) { - case CMD_CONV_WRITE_SEND: - pmsg = purple_message_new_outgoing(from, what, 0); - break; - case CMD_CONV_WRITE_RECV: - pmsg = purple_message_new_incoming(from, what, 0, 0); - break; - case CMD_CONV_WRITE_SYSTEM: - default: - pmsg = purple_message_new_system(what, 0); - break; - } - purple_conversation_write_message(convo, pmsg); - break; - case CMD_CONV_NAME: - if (objc != 3) { - Tcl_WrongNumArgs(interp, 2, objv, "conversation"); - return TCL_ERROR; - } - - if ((convo = tcl_validate_conversation(objv[2], interp)) == NULL) - return TCL_ERROR; - Tcl_SetObjResult(interp, - Tcl_NewStringObj((char *)purple_conversation_get_name(convo), -1)); - break; - case CMD_CONV_TITLE: - if (objc != 3) { - Tcl_WrongNumArgs(interp, 2, objv, "conversation"); - return TCL_ERROR; - } - - if ((convo = tcl_validate_conversation(objv[2], interp)) == NULL) - return TCL_ERROR; - Tcl_SetObjResult(interp, - Tcl_NewStringObj((char *)purple_conversation_get_title(convo), -1)); - break; - case CMD_CONV_SEND: - if (objc != 4) { - Tcl_WrongNumArgs(interp, 2, objv, "conversation message"); - return TCL_ERROR; - } - if ((convo = tcl_validate_conversation(objv[2], interp)) == NULL) - return TCL_ERROR; - what = Tcl_GetString(objv[3]); - purple_conversation_send(convo, what); - break; - } - - return TCL_OK; -} - -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; - int error; - - if (objc < 2) { - Tcl_WrongNumArgs(interp, 1, objv, "subcommand ?args?"); - return TCL_ERROR; - } - - if ((error = Tcl_GetIndexFromObj(interp, objv[1], cmds, "subcommand", 0, (int *)&cmd)) != TCL_OK) - return error; - - switch (cmd) { - case CMD_CORE_HANDLE: - if (objc != 2) { - Tcl_WrongNumArgs(interp, 2, objv, ""); - return TCL_ERROR; - } - Tcl_SetObjResult(interp, - purple_tcl_ref_new(PurpleTclRefHandle, - purple_get_core())); - break; - case CMD_CORE_QUIT: - if (objc != 2) { - Tcl_WrongNumArgs(interp, 2, objv, ""); - return TCL_ERROR; - } - purple_core_quit(); - break; - } - - return TCL_OK; -} - -int tcl_cmd_debug(ClientData unused, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) -{ - char *category, *message; - int lev; - const char *levels[] = { "-misc", "-info", "-warning", "-error", NULL }; - PurpleDebugLevel levelind[] = { PURPLE_DEBUG_MISC, PURPLE_DEBUG_INFO, PURPLE_DEBUG_WARNING, PURPLE_DEBUG_ERROR }; - int error; - - if (objc != 4) { - Tcl_WrongNumArgs(interp, 1, objv, "level category message"); - return TCL_ERROR; - } - - error = Tcl_GetIndexFromObj(interp, objv[1], levels, "debug level", 0, &lev); - if (error != TCL_OK) - return error; - - category = Tcl_GetString(objv[2]); - message = Tcl_GetString(objv[3]); - - purple_debug(levelind[lev], category, "%s\n", message); - - return TCL_OK; -} - -int tcl_cmd_notify(ClientData unused, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) -{ - int error, type; - 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"); - return TCL_ERROR; - } - - if (objc == 4) { - type = 1; /* Default to warning */ - title = Tcl_GetString(objv[1]); - msg1 = Tcl_GetString(objv[2]); - msg2 = Tcl_GetString(objv[3]); - } else { - error = Tcl_GetIndexFromObj(interp, objv[1], opts, "message type", 0, &type); - if (error != TCL_OK) - return error; - 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); - - return TCL_OK; -} - -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; - int error; - - if (objc < 2) { - Tcl_WrongNumArgs(interp, 1, objv, "subcommand ?args?"); - return TCL_ERROR; - } - - if ((error = Tcl_GetIndexFromObj(interp, objv[1], cmds, "subcommand", 0, (int *)&cmd)) != TCL_OK) - return error; - - switch (cmd) { - case CMD_PLUGINS_HANDLE: - if (objc != 2) { - Tcl_WrongNumArgs(interp, 2, objv, ""); - return TCL_ERROR; - } - Tcl_SetObjResult(interp, - purple_tcl_ref_new(PurpleTclRefHandle, - purple_plugins_get_handle())); - break; - } - - return TCL_OK; -} - -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; - GList *cur; - int error, intval, nelem, i; - - if (objc < 2) { - Tcl_WrongNumArgs(interp, 1, objv, "subcommand ?args?"); - return TCL_ERROR; - } - - if ((error = Tcl_GetIndexFromObj(interp, objv[1], cmds, "subcommand", 0, (int *)&cmd)) != TCL_OK) - return error; - - switch (cmd) { - case CMD_PREFS_GET: - if (objc != 3) { - Tcl_WrongNumArgs(interp, 1, objv, "path"); - return TCL_ERROR; - } - preftype = purple_prefs_get_pref_type(Tcl_GetString(objv[2])); - switch (preftype) { - case PURPLE_PREF_NONE: - Tcl_SetObjResult(interp, - Tcl_NewStringObj("pref type none", -1)); - return TCL_ERROR; - break; - case PURPLE_PREF_BOOLEAN: - Tcl_SetObjResult(interp, - Tcl_NewBooleanObj( - purple_prefs_get_bool(Tcl_GetString(objv[2])))); - break; - case PURPLE_PREF_INT: - Tcl_SetObjResult(interp, Tcl_NewIntObj(purple_prefs_get_int(Tcl_GetString(objv[2])))); - break; - case PURPLE_PREF_STRING: - Tcl_SetObjResult(interp, - Tcl_NewStringObj((char *)purple_prefs_get_string(Tcl_GetString(objv[2])), -1)); - break; - case PURPLE_PREF_STRING_LIST: - cur = purple_prefs_get_string_list(Tcl_GetString(objv[2])); - list = Tcl_NewListObj(0, NULL); - while (cur != NULL) { - elem = Tcl_NewStringObj((char *)cur->data, -1); - Tcl_ListObjAppendElement(interp, list, elem); - cur = g_list_next(cur); - } - Tcl_SetObjResult(interp, list); - break; - default: - 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)); - return TCL_ERROR; - } - break; - case CMD_PREFS_SET: - if (objc != 4) { - Tcl_WrongNumArgs(interp, 1, objv, "path value"); - return TCL_ERROR; - } - preftype = purple_prefs_get_pref_type(Tcl_GetString(objv[2])); - switch (preftype) { - case PURPLE_PREF_NONE: - Tcl_SetObjResult(interp, - Tcl_NewStringObj("bad path or pref type none", -1)); - return TCL_ERROR; - break; - case PURPLE_PREF_BOOLEAN: - if ((error = Tcl_GetBooleanFromObj(interp, objv[3], &intval)) != TCL_OK) - return error; - purple_prefs_set_bool(Tcl_GetString(objv[2]), intval); - break; - case PURPLE_PREF_INT: - if ((error = Tcl_GetIntFromObj(interp, objv[3], &intval)) != TCL_OK) - return error; - purple_prefs_set_int(Tcl_GetString(objv[2]), intval); - break; - case PURPLE_PREF_STRING: - purple_prefs_set_string(Tcl_GetString(objv[2]), Tcl_GetString(objv[3])); - break; - case PURPLE_PREF_STRING_LIST: - if ((error = Tcl_ListObjGetElements(interp, objv[3], &nelem, &elems)) != TCL_OK) - return error; - cur = NULL; - 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); - g_list_free(cur); - break; - default: - purple_debug(PURPLE_DEBUG_ERROR, "tcl", "tcl does not know about pref type %d\n", preftype); - return TCL_ERROR; - } - break; - case CMD_PREFS_TYPE: - if (objc != 3) { - Tcl_WrongNumArgs(interp, 1, objv, "path"); - return TCL_ERROR; - } - preftype = purple_prefs_get_pref_type(Tcl_GetString(objv[2])); - switch (preftype) { - case PURPLE_PREF_NONE: - Tcl_SetObjResult(interp, Tcl_NewStringObj("none", -1)); - break; - case PURPLE_PREF_BOOLEAN: - Tcl_SetObjResult(interp, Tcl_NewStringObj("boolean", -1)); - break; - case PURPLE_PREF_INT: - Tcl_SetObjResult(interp, Tcl_NewStringObj("int", -1)); - break; - case PURPLE_PREF_STRING: - Tcl_SetObjResult(interp, Tcl_NewStringObj("string", -1)); - break; - case PURPLE_PREF_STRING_LIST: - Tcl_SetObjResult(interp, Tcl_NewStringObj("stringlist", -1)); - break; - default: - purple_debug(PURPLE_DEBUG_ERROR, "tcl", "tcl does not know about pref type %d\n", preftype); - Tcl_SetObjResult(interp, Tcl_NewStringObj("unknown", -1)); - } - break; - } - - return TCL_OK; -} - -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", - "statuses", NULL }; - 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; - Tcl_Obj *result; - Tcl_Obj *list, *elem; - PurplePresence *presence; - GList *cur; - int error, idle, idle_time, login_time; - - if (objc < 2) { - Tcl_WrongNumArgs(interp, 1, objv, "subcommand ?args?"); - return TCL_ERROR; - } - - if ((error = Tcl_GetIndexFromObj(interp, objv[1], cmds, "subcommand", 0, (int *)&cmd)) != TCL_OK) - return error; - - switch (cmd) { - case CMD_PRESENCE_ACCOUNT: - if (objc != 3) { - Tcl_WrongNumArgs(interp, 2, objv, "presence"); - return TCL_ERROR; - } - if ((presence = purple_tcl_ref_get(interp, objv[2], PurpleTclRefPresence)) == NULL) - return TCL_ERROR; - Tcl_SetObjResult(interp, purple_tcl_ref_new(PurpleTclRefAccount, - purple_account_presence_get_account(PURPLE_ACCOUNT_PRESENCE(presence)))); - break; - case CMD_PRESENCE_ACTIVE_STATUS: - if (objc != 3 && objc != 4 && objc != 5) { - Tcl_WrongNumArgs(interp, 2, objv, "presence [?status_id? | ?-primitive primitive?]"); - return TCL_ERROR; - } - if ((presence = purple_tcl_ref_get(interp, objv[2], PurpleTclRefPresence)) == NULL) - return TCL_ERROR; - if (objc == 3) { - Tcl_SetObjResult(interp, - purple_tcl_ref_new(PurpleTclRefStatus, - purple_presence_get_active_status(presence))); - } else if (objc == 4) { - Tcl_SetObjResult(interp, - Tcl_NewBooleanObj( - purple_presence_is_status_active(presence, - Tcl_GetString(objv[3])))); - } else { - 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); - return TCL_ERROR; - } - 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); - return TCL_ERROR; - } - Tcl_SetObjResult(interp, - Tcl_NewBooleanObj( - purple_presence_is_status_primitive_active(presence, primitive))); - break; - } - break; - case CMD_PRESENCE_AVAILABLE: - if (objc != 3) { - Tcl_WrongNumArgs(interp, 2, objv, "presence"); - return TCL_ERROR; - } - if ((presence = purple_tcl_ref_get(interp, objv[2], PurpleTclRefPresence)) == NULL) - return TCL_ERROR; - Tcl_SetObjResult(interp, - Tcl_NewBooleanObj(purple_presence_is_available(presence))); - break; - case CMD_PRESENCE_TYPE: - if (objc != 3) { - Tcl_WrongNumArgs(interp, 2, objv, "presence"); - return TCL_ERROR; - } - if ((presence = purple_tcl_ref_get(interp, objv[2], PurpleTclRefPresence)) == NULL) - return TCL_ERROR; - 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)); - break; - case CMD_PRESENCE_IDLE: - if (objc < 3 || objc > 5) { - Tcl_WrongNumArgs(interp, 2, objv, "presence ?idle? ?time?"); - return TCL_ERROR; - } - if ((presence = purple_tcl_ref_get(interp, objv[2], PurpleTclRefPresence)) == NULL) - return TCL_ERROR; - if (objc == 3) { - if (purple_presence_is_idle(presence)) { - idle_time = purple_presence_get_idle_time (presence); - Tcl_SetObjResult(interp, Tcl_NewIntObj(idle_time)); - } else { - result = Tcl_NewListObj(0, NULL); - Tcl_SetObjResult(interp, result); - } - break; - } - if ((error = Tcl_GetBooleanFromObj(interp, objv[3], &idle)) != TCL_OK) - return TCL_ERROR; - if (objc == 4) { - purple_presence_set_idle(presence, idle, time(NULL)); - } else if (objc == 5) { - if ((error = Tcl_GetIntFromObj(interp, - objv[4], - &idle_time)) != TCL_OK) - return TCL_ERROR; - purple_presence_set_idle(presence, idle, idle_time); - } - break; - case CMD_PRESENCE_LOGIN: - if (objc != 3 && objc != 4) { - Tcl_WrongNumArgs(interp, 2, objv, "presence ?time?"); - return TCL_ERROR; - } - if ((presence = purple_tcl_ref_get(interp, objv[2], PurpleTclRefPresence)) == NULL) - return TCL_ERROR; - if (objc == 3) { - Tcl_SetObjResult(interp, Tcl_NewIntObj(purple_presence_get_login_time(presence))); - } else { - if ((error == Tcl_GetIntFromObj(interp, - objv[3], - &login_time)) != TCL_OK) - return TCL_ERROR; - purple_presence_set_login_time(presence, login_time); - } - break; - case CMD_PRESENCE_ONLINE: - if (objc != 3) { - Tcl_WrongNumArgs(interp, 2, objv, "presence"); - return TCL_ERROR; - } - if ((presence = purple_tcl_ref_get(interp, objv[2], PurpleTclRefPresence)) == NULL) - return TCL_ERROR; - Tcl_SetObjResult(interp, - Tcl_NewBooleanObj( - purple_presence_is_online(presence))); - break; - case CMD_PRESENCE_STATUS: - if (objc != 4) { - Tcl_WrongNumArgs(interp, 2, objv, "presence status_id"); - return TCL_ERROR; - } - if ((presence = purple_tcl_ref_get(interp, objv[2], PurpleTclRefPresence)) == NULL) - return TCL_ERROR; - Tcl_SetObjResult(interp, - purple_tcl_ref_new(PurpleTclRefStatus, - purple_presence_get_status(presence, - Tcl_GetString(objv[3])))); - break; - case CMD_PRESENCE_STATUSES: - if (objc != 3) { - Tcl_WrongNumArgs(interp, 2, objv, "presence"); - return TCL_ERROR; - } - if ((presence = purple_tcl_ref_get(interp, objv[2], PurpleTclRefPresence)) == NULL) - return TCL_ERROR; - 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); - break; - } - - return TCL_OK; -} - -int tcl_cmd_savedstatus(ClientData unused, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) -{ - Tcl_Obj *result; - const char *cmds[] = { "current", "handle", NULL }; - enum { CMD_SAVEDSTATUS_CURRENT, CMD_SAVEDSTATUS_HANDLE } cmd; - int error; - PurpleSavedStatus *saved_status; - - if (objc < 2) { - Tcl_WrongNumArgs(interp, 1, objv, "subcommand ?args?"); - return TCL_ERROR; - } - - if ((error = Tcl_GetIndexFromObj(interp, objv[1], cmds, "subcommand", 0, (int *)&cmd)) != TCL_OK) - return error; - - switch (cmd) { - case CMD_SAVEDSTATUS_CURRENT: - if (objc != 2) { - Tcl_WrongNumArgs(interp, 2, objv, ""); - return TCL_ERROR; - } - if ((saved_status = purple_savedstatus_get_current()) == NULL) - return TCL_ERROR; - 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); - break; - case CMD_SAVEDSTATUS_HANDLE: - if (objc != 2) { - Tcl_WrongNumArgs(interp, 2, objv, ""); - return TCL_ERROR; - } - Tcl_SetObjResult(interp, - purple_tcl_ref_new(PurpleTclRefHandle, - purple_savedstatuses_get_handle())); - break; - } - - return TCL_OK; -} - -int tcl_cmd_send_im(ClientData unused, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) -{ - PurpleConnection *gc; - char *who, *text; - - if (objc != 4) { - Tcl_WrongNumArgs(interp, 1, objv, "gc who text"); - return TCL_ERROR; - } - - if ((gc = tcl_validate_gc(objv[1], interp)) == NULL) - return TCL_ERROR; - - who = Tcl_GetString(objv[2]); - text = Tcl_GetString(objv[3]); - - purple_serv_send_im(gc, purple_message_new_outgoing(who, text, 0)); - - return TCL_OK; -} - -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; - void *instance; - int error; - - if (objc < 2) { - Tcl_WrongNumArgs(interp, 1, objv, "subcommand ?args?"); - return TCL_ERROR; - } - - if ((error = Tcl_GetIndexFromObj(interp, objv[1], cmds, "subcommand", 0, (int *)&cmd)) != TCL_OK) - return error; - - switch (cmd) { - case CMD_SIGNAL_CONNECT: - if (objc != 6) { - Tcl_WrongNumArgs(interp, 2, objv, "instance signal args proc"); - return TCL_ERROR; - } - handler = g_new0(struct tcl_signal_handler, 1); - if ((handler->instance = purple_tcl_ref_get(interp, objv[2],PurpleTclRefHandle)) == NULL) { - g_free(handler); - return error; - } - 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)); - } else { - Tcl_SetObjResult(interp, Tcl_NewIntObj(0)); - } - break; - case CMD_SIGNAL_DISCONNECT: - if (objc != 4) { - Tcl_WrongNumArgs(interp, 2, objv, "instance signal"); - return TCL_ERROR; - } - if ((instance = purple_tcl_ref_get(interp, objv[2],PurpleTclRefHandle)) == NULL) - return error; - tcl_signal_disconnect(instance, Tcl_GetString(objv[3]), interp); - break; - } - - return TCL_OK; -} - -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; - PurpleStatus *status; - PurpleStatusType *status_type; - int error; -# if (0) -/* #if !(defined PURPLE_DISABLE_DEPRECATED) */ - PurpleValue *value; - const char *attr; - int v; -#endif - - if (objc < 2) { - Tcl_WrongNumArgs(interp, 1, objv, "subcommand ?args?"); - return TCL_ERROR; - } - - if ((error = Tcl_GetIndexFromObj(interp, objv[1], cmds, "subcommand", 0, (int *)&cmd)) != TCL_OK) - return error; - - switch (cmd) { - case CMD_STATUS_ATTRIBUTE: -# if (0) -/* #if !(defined PURPLE_DISABLE_DEPRECATED) */ - if (objc != 4 && objc != 5) { - Tcl_WrongNumArgs(interp, 2, objv, "status attr_id ?value?"); - return TCL_ERROR; - } - if ((status = purple_tcl_ref_get(interp, objv[2], PurpleTclRefStatus)) == NULL) - return TCL_ERROR; - attr = Tcl_GetString(objv[3]); - value = purple_status_get_attr_value(status, attr); - if (value == NULL) { - Tcl_SetObjResult(interp, - Tcl_NewStringObj("no such attribute", -1)); - return TCL_ERROR; - } - switch (purple_value_get_type(value)) { - case PURPLE_TYPE_BOOLEAN: - if (objc == 4) { - Tcl_SetObjResult(interp, - Tcl_NewBooleanObj(purple_value_get_boolean(value))); - } else { - if ((error = Tcl_GetBooleanFromObj(interp, objv[4], &v)) != TCL_OK) - return error; - purple_status_set_attr_boolean(status, attr, v); - } - break; - case PURPLE_TYPE_INT: - if (objc == 4) { - Tcl_SetObjResult(interp, Tcl_NewIntObj(purple_value_get_int(value))); - } else { - if ((error = Tcl_GetIntFromObj(interp, objv[4], &v)) != TCL_OK) - return error; - purple_status_set_attr_int(status, attr, v ); - } - break; - case PURPLE_TYPE_STRING: - if (objc == 4) - Tcl_SetObjResult(interp, - Tcl_NewStringObj(purple_value_get_string(value), -1)); - else - purple_status_set_attr_string(status, attr, Tcl_GetString(objv[4])); - break; - default: - Tcl_SetObjResult(interp, - Tcl_NewStringObj("attribute has unknown type", -1)); - return TCL_ERROR; - } -#endif - break; - case CMD_STATUS_TYPE: - if (objc != 3) { - Tcl_WrongNumArgs(interp, 2, objv, "status"); - return TCL_ERROR; - } - if ((status = purple_tcl_ref_get(interp, objv[2], PurpleTclRefStatus)) == NULL) - return TCL_ERROR; - status_type = purple_status_get_status_type(status); - Tcl_SetObjResult(interp, purple_tcl_ref_new(PurpleTclRefStatusType, - status_type)); - break; - } - - return TCL_OK; -} - -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; - int error; - - if (objc < 2) { - Tcl_WrongNumArgs(interp, 1, objv, "subcommand ?args?"); - return TCL_ERROR; - } - - if ((error = Tcl_GetIndexFromObj(interp, objv[1], cmds, "subcommand", 0, (int *)&cmd)) != TCL_OK) - return error; - - switch (cmd) { - case CMD_STATUS_ATTRIBUTE_ID: - if (objc != 3) { - Tcl_WrongNumArgs(interp, 2, objv, "attr"); - return TCL_ERROR; - } - if ((attr = purple_tcl_ref_get(interp, objv[2], PurpleTclRefStatusAttr)) == NULL) - return TCL_ERROR; - Tcl_SetObjResult(interp, - Tcl_NewStringObj(purple_status_attribute_get_id(attr), -1)); - break; - case CMD_STATUS_ATTRIBUTE_NAME: - if (objc != 3) { - Tcl_WrongNumArgs(interp, 2, objv, "attr"); - return TCL_ERROR; - } - if ((attr = purple_tcl_ref_get(interp, objv[2], PurpleTclRefStatusAttr)) == NULL) - return TCL_ERROR; - Tcl_SetObjResult(interp, - Tcl_NewStringObj(purple_status_attribute_get_name(attr), -1)); - break; - } - - return TCL_OK; -} - -int tcl_cmd_status_type(ClientData unused, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) -{ - const char *cmds[] = { "attr", "attrs", "available", "exclusive", "id", - "independent", "name", - "primitive", "saveable", "user_settable", - NULL }; - 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_NAME, - CMD_STATUS_TYPE_PRIMITIVE, CMD_STATUS_TYPE_SAVEABLE, - CMD_STATUS_TYPE_USER_SETTABLE } cmd; - PurpleStatusType *status_type; - Tcl_Obj *list, *elem; - GList *cur; - int error; - - if (objc < 2) { - Tcl_WrongNumArgs(interp, 1, objv, "subcommand ?args?"); - return TCL_ERROR; - } - - if ((error = Tcl_GetIndexFromObj(interp, objv[1], cmds, "subcommand", 0, (int *)&cmd)) != TCL_OK) - return error; - - switch (cmd) { - case CMD_STATUS_TYPE_AVAILABLE: - if (objc != 3) { - Tcl_WrongNumArgs(interp, 2, objv, "statustype"); - return TCL_ERROR; - } - if ((status_type = purple_tcl_ref_get(interp, objv[2], PurpleTclRefStatusType)) == NULL) - return TCL_ERROR; - Tcl_SetObjResult(interp, - Tcl_NewBooleanObj(purple_status_type_is_available(status_type))); - break; - case CMD_STATUS_TYPE_ATTR: - if (objc != 4) { - Tcl_WrongNumArgs(interp, 2, objv, "statustype attr"); - return TCL_ERROR; - } - if ((status_type = purple_tcl_ref_get(interp, objv[2], PurpleTclRefStatusType)) == NULL) - return TCL_ERROR; - Tcl_SetObjResult(interp, - purple_tcl_ref_new(PurpleTclRefStatusAttr, - purple_status_type_get_attr(status_type, - Tcl_GetStringFromObj(objv[3], NULL)))); - break; - case CMD_STATUS_TYPE_ATTRS: - if (objc != 3) { - Tcl_WrongNumArgs(interp, 2, objv, "statustype"); - return TCL_ERROR; - } - if ((status_type = purple_tcl_ref_get(interp, objv[2], PurpleTclRefStatusType)) == NULL) - return TCL_ERROR; - 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); - break; - case CMD_STATUS_TYPE_EXCLUSIVE: - if (objc != 3) { - Tcl_WrongNumArgs(interp, 2, objv, "statustype"); - return TCL_ERROR; - } - if ((status_type = purple_tcl_ref_get(interp, objv[2], PurpleTclRefStatusType)) == NULL) - return TCL_ERROR; - Tcl_SetObjResult(interp, - Tcl_NewBooleanObj(purple_status_type_is_exclusive(status_type))); - break; - case CMD_STATUS_TYPE_ID: - if (objc != 3) { - Tcl_WrongNumArgs(interp, 2, objv, "statustype"); - return TCL_ERROR; - } - if ((status_type = purple_tcl_ref_get(interp, objv[2], PurpleTclRefStatusType)) == NULL) - return TCL_ERROR; - Tcl_SetObjResult(interp, - Tcl_NewStringObj(purple_status_type_get_id(status_type), -1)); - break; - case CMD_STATUS_TYPE_INDEPENDENT: - if (objc != 3) { - Tcl_WrongNumArgs(interp, 2, objv, "statustype"); - return TCL_ERROR; - } - if ((status_type = purple_tcl_ref_get(interp, objv[2], PurpleTclRefStatusType)) == NULL) - return TCL_ERROR; - Tcl_SetObjResult(interp, - Tcl_NewBooleanObj(purple_status_type_is_independent(status_type))); - break; - case CMD_STATUS_TYPE_NAME: - if (objc != 3) { - Tcl_WrongNumArgs(interp, 2, objv, "statustype"); - return TCL_ERROR; - } - if ((status_type = purple_tcl_ref_get(interp, objv[2], PurpleTclRefStatusType)) == NULL) - return TCL_ERROR; - Tcl_SetObjResult(interp, - Tcl_NewStringObj(purple_status_type_get_name(status_type), -1)); - break; - case CMD_STATUS_TYPE_PRIMITIVE: - if (objc != 3) { - Tcl_WrongNumArgs(interp, 2, objv, "statustype"); - return TCL_ERROR; - } - if ((status_type = purple_tcl_ref_get(interp, objv[2], PurpleTclRefStatusType)) == NULL) - return TCL_ERROR; - Tcl_SetObjResult(interp, - Tcl_NewStringObj(purple_primitive_get_id_from_type - (purple_status_type_get_primitive(status_type)), -1)); - break; - case CMD_STATUS_TYPE_SAVEABLE: - if (objc != 3) { - Tcl_WrongNumArgs(interp, 2, objv, "statustype"); - return TCL_ERROR; - } - if ((status_type = purple_tcl_ref_get(interp, objv[2], PurpleTclRefStatusType)) == NULL) - return TCL_ERROR; - Tcl_SetObjResult(interp, - Tcl_NewBooleanObj( - purple_status_type_is_saveable(status_type))); - break; - case CMD_STATUS_TYPE_USER_SETTABLE: - if (objc != 3) { - Tcl_WrongNumArgs(interp, 2, objv, "statustype"); - return TCL_ERROR; - } - if ((status_type = purple_tcl_ref_get(interp, objv[2], PurpleTclRefStatusType)) == NULL) - return TCL_ERROR; - Tcl_SetObjResult(interp, - Tcl_NewBooleanObj( - purple_status_type_is_user_settable(status_type))); - break; - } - - return TCL_OK; -} - -static gboolean unload_self(gpointer data) -{ - PurplePlugin *plugin = data; - purple_plugin_unload(plugin); - return FALSE; -} - -int tcl_cmd_unload(ClientData unused, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) -{ - PurplePlugin *plugin; - if (objc != 1) { - Tcl_WrongNumArgs(interp, 1, objv, ""); - return TCL_ERROR; - } - - if ((plugin = tcl_interp_get_plugin(interp)) == NULL) { - /* This isn't exactly OK, but heh. What do you do? */ - return TCL_OK; - } - /* We can't unload immediately, but we can unload at the first - * known safe opportunity. */ - purple_timeout_add(0, unload_self, (gpointer)plugin); - - return TCL_OK; -}
--- 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 @@ -/* - * Tcl/Glib glue - * - * 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. - * - * TERMS 1 - * - * 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 - * - * TERMS 2 - * - * Redistribution and use in source and binary forms, with or without - * modification, are permitted provided that the following conditions - * are met: - * - * 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 - * distribution. - * - * DISCLAIMER - * - * 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. - */ - -/* - * NOTES - * - * 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 - * heart's content. - * - * BUGS - * - * 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 - */ - -#include <tcl.h> -#include <glib.h> -#include <string.h> - -#include "tcl_glib.h" - -#ifndef CONST86 -# define CONST86 -#endif - -struct tcl_file_handler { - int source; - int fd; - int mask; - int pending; - Tcl_FileProc *proc; - ClientData data; -}; - -struct tcl_file_event { - Tcl_Event header; - int fd; -}; - -static guint tcl_timer; -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); - -#undef Tcl_InitNotifier - -ClientData Tcl_InitNotifier() -{ - return NULL; -} - -void tcl_glib_init () -{ - 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) -{ - guint interval; - - if (tcl_timer_pending) - g_source_remove(tcl_timer); - - if (timePtr == NULL) { - tcl_timer_pending = FALSE; - return; - } - - 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); - return 1; - } else { - tcl_set_timer(timePtr); - } - - g_main_context_iteration(NULL, TRUE); - - return 1; -} - -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); - GIOChannel *channel; - GIOCondition cond = 0; - - if (g_hash_table_lookup(tcl_file_handlers, GINT_TO_POINTER(fd))) - tcl_delete_file_handler(fd); - - if (mask & TCL_READABLE) - cond |= G_IO_IN; - if (mask & TCL_WRITABLE) - cond |= G_IO_OUT; - if (mask & TCL_EXCEPTION) - cond |= G_IO_ERR|G_IO_HUP|G_IO_NVAL; - - tfh->fd = fd; - tfh->mask = mask; - tfh->proc = proc; - tfh->data = data; - - 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); - - Tcl_ServiceAll(); -} - -static void tcl_delete_file_handler(int fd) -{ - struct tcl_file_handler *tfh = g_hash_table_lookup(tcl_file_handlers, GINT_TO_POINTER(fd)); - - if (tfh == NULL) - return; - - g_source_remove(tfh->source); - g_hash_table_remove(tcl_file_handlers, GINT_TO_POINTER(fd)); - - Tcl_ServiceAll(); -} - -static gboolean tcl_kick(gpointer data) -{ - tcl_timer_pending = FALSE; - - Tcl_ServiceAll(); - - return FALSE; -} - -static gboolean tcl_file_callback(GIOChannel *source, GIOCondition condition, gpointer data) -{ - struct tcl_file_handler *tfh = data; - struct tcl_file_event *fev; - int mask = 0; - - if (condition & G_IO_IN) - mask |= TCL_READABLE; - if (condition & G_IO_OUT) - mask |= TCL_WRITABLE; - if (condition & (G_IO_ERR|G_IO_HUP|G_IO_NVAL)) - mask |= TCL_EXCEPTION; - - if (!(tfh->mask & (mask & ~tfh->pending))) - return TRUE; - - tfh->pending |= mask; - /* 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; - fev->fd = tfh->fd; - Tcl_QueueEvent((Tcl_Event *)fev, TCL_QUEUE_TAIL); - - Tcl_ServiceAll(); - - return TRUE; -} - -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; - int mask; - - if (!(flags & TCL_FILE_EVENTS)) { - return 0; - } - - tfh = g_hash_table_lookup(tcl_file_handlers, GINT_TO_POINTER(fev->fd)); - if (tfh == NULL) - return 1; - - mask = tfh->mask & tfh->pending; - if (mask) - (*tfh->proc)(tfh->data, mask); - tfh->pending = 0; - - return 1; -}
--- 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 @@ -/* - * Tcl/Glib glue - * - * 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_ - -#include <tcl.h> -#include <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 - * - * purple - * - * 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_ - -#include <tcl.h> - -#include "internal.h" -#include "cmds.h" -#include "plugins.h" -#include "stringref.h" - -struct tcl_signal_handler { - Tcl_Obj *signal; - Tcl_Interp *interp; - - void *instance; - Tcl_Obj *namespace; - /* These following two are temporary during setup */ - Tcl_Obj *args; - Tcl_Obj *proc; - - GType returntype; - int nargs; - GType *argtypes; -}; - -struct tcl_cmd_handler { - PurpleCmdId id; - Tcl_Obj *cmd; - Tcl_Interp *interp; - - Tcl_Obj *namespace; - /* These are temporary during setup */ - const char *args; - int priority; - int flags; - const char *protocol_id; - Tcl_Obj *proc; - const char *helpstr; - - int nargs; -}; - -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 - * - * purple - * - * 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 - */ - -#include <tcl.h> -#include <glib.h> - -#include "tcl_purple.h" -#include "stringref.h" - -/* 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 = { - "PurpleTclRef", - purple_tcl_ref_free, - purple_tcl_ref_dup, - purple_tcl_ref_update, - purple_tcl_ref_set -}; - -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) - return NULL; - } - if (strcmp(purple_stringref_value(OBJ_REF_TYPE(obj)), - purple_stringref_value(type))) { - if (interp) { - 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 NULL; - } - 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); - return 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) -{ - size_t len; - /* 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_REF_VALUE(obj)); - - obj->length = strlen(bytes); - len = obj->length + 1; - obj->bytes = ckalloc(len); - g_strlcpy(obj->bytes, bytes, len); - g_free(bytes); -} - -/* 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); - char *ptr; - PurpleStringref *type; - void *value; - 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) - goto badobject; - - /* Bad Ethan */ - *ptr = '\0'; - type = purple_stringref_new(bytes + prefixlen); - *ptr = ':'; - ptr++; - - if (sscanf(ptr, "%p", &value) == 0) { - purple_stringref_unref(type); - goto badobject; - } - - /* 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; - - return TCL_OK; - -badobject: - if (interp) { - Tcl_SetObjResult(interp, - Tcl_NewStringObj("invalid PurpleTclRef representation", -1)); - } - return TCL_ERROR; -}
--- 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 - * - * purple - * - * 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 <tcl.h> -#include <stdarg.h> - -#include "tcl_purple.h" - -#include "internal.h" -#include "connection.h" -#include "conversation.h" -#include "signals.h" -#include "debug.h" -#include "core.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_init() -{ - tcl_callbacks = NULL; -} - -void tcl_signal_handler_free(struct tcl_signal_handler *handler) -{ - if (handler == NULL) - return; - - Tcl_DecrRefCount(handler->signal); - if (handler->namespace) - { - Tcl_DecrRefCount(handler->namespace); - } - g_free(handler); -} - -void tcl_signal_cleanup(Tcl_Interp *interp) -{ - GList *cur; - struct tcl_signal_handler *handler; - - for (cur = tcl_callbacks; cur != NULL; cur = g_list_next(cur)) { - handler = cur->data; - if (handler->interp == interp) { - tcl_signal_handler_free(handler); - cur->data = NULL; - } - } - tcl_callbacks = g_list_remove_all(tcl_callbacks, NULL); -} - -gboolean tcl_signal_connect(struct tcl_signal_handler *handler) -{ - GString *proc; - - purple_signal_get_types(handler->instance, - Tcl_GetString(handler->signal), - &handler->returntype, &handler->nargs, - &handler->argtypes); - - tcl_signal_disconnect(handler->interp, Tcl_GetString(handler->signal), - handler->interp); - - if (!purple_signal_connect_vargs(handler->instance, - Tcl_GetString(handler->signal), - (void *)handler->interp, - PURPLE_CALLBACK(tcl_signal_callback), - (void *)handler)) - return FALSE; - - 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); - return FALSE; - } - g_string_free(proc, TRUE); - - tcl_callbacks = g_list_append(tcl_callbacks, (gpointer)handler); - - return TRUE; -} - -void tcl_signal_disconnect(void *instance, const char *signal, Tcl_Interp *interp) -{ - GList *cur; - struct tcl_signal_handler *handler; - gboolean found = FALSE; - GString *cmd; - - for (cur = tcl_callbacks; cur != NULL; cur = g_list_next(cur)) { - handler = cur->data; - 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); - cur->data = NULL; - found = TRUE; - break; - } - } - if (found) - 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; - else - return NULL; -} - -static void *tcl_signal_callback(va_list args, struct tcl_signal_handler *handler) -{ - GString *name, *val; - PurpleBlistNode *node; - int i; - void *retval = NULL; - Tcl_Obj *cmd, *arg, *result; - void **vals; /* Used for inout parameters */ - char ***strs; - - 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); - Tcl_IncrRefCount(cmd); - - arg = Tcl_DuplicateObj(handler->namespace); - Tcl_AppendStringsToObj(arg, "::cb", NULL); - Tcl_ListObjAppendElement(handler->interp, cmd, arg); - - for (i = 0; i < handler->nargs; i++) { -#if 0 - if (purple_value_is_outgoing(handler->argtypes[i])) - g_string_printf(name, "%s::arg%d", - Tcl_GetString(handler->namespace), i); -#endif - switch(handler->argtypes[i]) { - case G_TYPE_POINTER: -#if 0 - case G_TYPE_OBJECT: - case G_TYPE_BOXED: - /* 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"); -#endif - arg = purple_tcl_ref_new(PurpleTclRefPointer, va_arg(args, void *)); - break; - case G_TYPE_BOOLEAN: -#if 0 - 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); - } else -#endif - arg = Tcl_NewBooleanObj(va_arg(args, gboolean)); - break; - case G_TYPE_CHAR: - case G_TYPE_UCHAR: - case G_TYPE_INT: - case G_TYPE_UINT: - case G_TYPE_LONG: - case G_TYPE_ULONG: - /* I should really cast these individually to - * preserve as much information as possible ... - * but heh */ -#if 0 - 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); - } else -#endif - arg = Tcl_NewIntObj(va_arg(args, int)); - break; - case G_TYPE_INT64: - case G_TYPE_UINT64: - /* Tcl < 8.4 doesn't have wide ints, so we have ugly - * ifdefs in here */ -#if 0 - 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); - #else - /* This is going to cause weirdness at best, - * but what do you want ... we're losing - * precision */ - Tcl_LinkVar(handler->interp, name->str, - vals[i], TCL_LINK_INT); - #endif /* Tcl >= 8.4 */ - arg = Tcl_NewStringObj(name->str, -1); - } else { -#endif - #if (TCL_MAJOR_VERSION >= 8 && TCL_MINOR_VERSION >= 4) - arg = Tcl_NewWideIntObj(va_arg(args, gint64)); - #else - arg = Tcl_NewIntObj((int)va_arg(args, int)); - #endif /* Tcl >= 8.4 */ - break; - case G_TYPE_STRING: -#if 0 - if (purple_value_is_outgoing(handler->argtypes[i])) { - strs[i] = va_arg(args, char **); - if (strs[i] == NULL || *strs[i] == NULL) { - vals[i] = ckalloc(1); - *(char *)vals[i] = '\0'; - } else { - 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); - } else -#endif - arg = Tcl_NewStringObj(va_arg(args, char *), -1); - break; - default: - 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 0 - if (purple_value_is_outgoing(handler->argtypes[i])) - purple_debug_error("tcl", "pointer subtypes do not currently support outgoing arguments\n"); -#endif - arg = purple_tcl_ref_new(ref_purple_type(handler->argtypes[i]), va_arg(args, void *)); - } - else - 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 0 - if (purple_value_is_outgoing(handler->argtypes[i])) - node = *va_arg(args, PurpleBlistNode **); - else -#endif - 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)); - } - else - { - /* 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))); - } else { - 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)); - } else { - 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))); - retval = NULL; - } - } - } - } - - /* And finally clean up */ - for (i = 0; i < handler->nargs; i++) { - g_string_printf(name, "%s::arg%d", - Tcl_GetString(handler->namespace), i); -#if 0 - 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 - * way out */ - switch (handler->argtypes[i]) { - case G_TYPE_STRING: - if (purple_value_is_outgoing(handler->argtypes[i])) { - if (vals[i] != NULL && *(char **)vals[i] != NULL) { - g_free(*strs[i]); - *strs[i] = g_strdup(vals[i]); - } - ckfree(vals[i]); - } - break; - default: - /* nothing */ - ; - } -#endif - } - - g_string_free(name, TRUE); - g_string_free(val, TRUE); - g_free(vals); - g_free(strs); - - return retval; -} - -static Tcl_Obj *new_cb_namespace () -{ - static int cbnum; - char name[32]; - - g_snprintf (name, sizeof(name), "::purple::_callback::cb_%d", cbnum++); - return Tcl_NewStringObj (name, -1); -}
