libpurple/plugins/tcl/tcl.c

/**
 * @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 "plugin.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 gboolean tcl_load(PurplePlugin *plugin)
{
	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)
{
	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;
}

static PurplePluginLoaderInfo tcl_loader_info =
{
	NULL,
	tcl_probe_plugin,
	tcl_load_plugin,
	tcl_unload_plugin,
	tcl_destroy_plugin,

	/* pidgin */
	NULL,
	NULL,
	NULL,
	NULL
};

static PurplePluginInfo tcl_info =
{
	PURPLE_PLUGIN_MAGIC,
	PURPLE_MAJOR_VERSION,
	PURPLE_MINOR_VERSION,
	PURPLE_PLUGIN_LOADER,
	NULL,
	0,
	NULL,
	PURPLE_PRIORITY_DEFAULT,
	"core-tcl",
	N_("Tcl Plugin Loader"),
	DISPLAY_VERSION,
	N_("Provides support for loading Tcl plugins"),
	N_("Provides support for loading Tcl plugins"),
	"Ethan Blanton <eblanton@cs.purdue.edu>",
	PURPLE_WEBSITE,
	tcl_load,
	tcl_unload,
	NULL,
	NULL,
	&tcl_loader_info,
	NULL,
	NULL,

	/* padding */
	NULL,
	NULL,
	NULL,
	NULL
};

#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_INIT_PLUGIN(tcl, tcl_init_plugin, tcl_info)