view libpurple/plugins/perl/perl-handlers.c @ 17472:ae7a4134e499

Changing this timer to run every 50 milliseconds instead of every 5 milliseconds. The timer is used to integrate our glib mainloop with silcclient's mainloop. Some Red Hat people complained that the timer causes the CPU to wake up really often and that hurts out power consumption on laptops and what not. Ideally the integration wouldn't need the timeout thing and would instead by event-driven. http://bugzilla.redhat.com/bugzilla/show_bug.cgi?id=242398

#include "perl-common.h"
#include "perl-handlers.h"

#include "debug.h"
#include "signals.h"

extern PerlInterpreter *my_perl;
static GList *cmd_handlers = NULL;
static GList *signal_handlers = NULL;
static GList *timeout_handlers = NULL;

/* perl < 5.8.0 doesn't define PERL_MAGIC_ext */
#ifndef PERL_MAGIC_ext
#define PERL_MAGIC_ext '~'
#endif

void
purple_perl_plugin_action_cb(PurplePluginAction *action)
{
	SV **callback;
	HV *hv = NULL;
	gchar *hvname;
	PurplePlugin *plugin;
	PurplePerlScript *gps;
	dSP;

	plugin = action->plugin;
	gps = (PurplePerlScript *)plugin->info->extra_info;
	hvname = g_strdup_printf("%s::plugin_actions", gps->package);
	hv = get_hv(hvname, FALSE);
	g_free(hvname);

	if (hv == NULL)
		croak("No plugin_actions hash found in \"%s\" plugin.", purple_plugin_get_name(plugin));

	ENTER;
	SAVETMPS;

	callback = hv_fetch(hv, action->label, strlen(action->label), 0);

	if (callback == NULL || *callback == NULL)
		croak("No plugin_action function named \"%s\" in \"%s\" plugin.", action->label, purple_plugin_get_name(plugin));

	PUSHMARK(sp);
	XPUSHs(purple_perl_bless_object(gps->plugin, "Purple::Plugin"));
	PUTBACK;

	call_sv(*callback, G_VOID | G_DISCARD);
	SPAGAIN;

	PUTBACK;
	FREETMPS;
	LEAVE;
}

GList *
purple_perl_plugin_actions(PurplePlugin *plugin, gpointer context)
{
	GList *l = NULL;
	PurplePerlScript *gps;
	int i = 0, count = 0;
	dSP;

	gps = (PurplePerlScript *)plugin->info->extra_info;

	ENTER;
	SAVETMPS;

	PUSHMARK(SP);
	XPUSHs(sv_2mortal(purple_perl_bless_object(plugin, "Purple::Plugin")));
	/* XXX This *will* cease working correctly if context gets changed to
	 * ever be able to hold anything other than a PurpleConnection */
	if (context != NULL)
		XPUSHs(sv_2mortal(purple_perl_bless_object(context,
		                                         "Purple::Connection")));
	else
		XPUSHs(&PL_sv_undef);
	PUTBACK;

	count = call_pv(gps->plugin_action_sub, G_ARRAY);

	SPAGAIN;

	if (count == 0)
		croak("The plugin_actions sub didn't return anything.\n");

	for (i = 0; i < count; i++) {
		SV *sv;
		gchar *label;
		PurplePluginAction *act = NULL;

		sv = POPs;
		label = SvPV_nolen(sv);
		/* XXX I think this leaks, but doing it without the strdup
		 * just showed garbage */
		act = purple_plugin_action_new(g_strdup(label), purple_perl_plugin_action_cb);
		l = g_list_prepend(l, act);
	}

	PUTBACK;
	FREETMPS;
	LEAVE;

	return l;
}

#ifdef PURPLE_GTKPERL
GtkWidget *
purple_perl_gtk_get_plugin_frame(PurplePlugin *plugin)
{
	SV * sv;
	int count;
	MAGIC *mg;
	GtkWidget *ret;
	PurplePerlScript *gps;
	dSP;

	gps = (PurplePerlScript *)plugin->info->extra_info;

	ENTER;
	SAVETMPS;

	count = call_pv(gps->gtk_prefs_sub, G_SCALAR | G_NOARGS);
	if (count != 1)
		croak("call_pv: Did not return the correct number of values.\n");

	/* the frame was created in a perl sub and is returned */
	SPAGAIN;

	/* We have a Gtk2::Frame on top of the stack */
	sv = POPs;

	/* The magic field hides the pointer to the actual GtkWidget */
	mg = mg_find(SvRV(sv), PERL_MAGIC_ext);
	ret = (GtkWidget *)mg->mg_ptr;

	PUTBACK;
	FREETMPS;
	LEAVE;

	return ret;
}
#endif

PurplePluginPrefFrame *
purple_perl_get_plugin_frame(PurplePlugin *plugin)
{
	/* Sets up the Perl Stack for our call back into the script to run the
	 * plugin_pref... sub */
	int count;
	PurplePerlScript *gps;
	PurplePluginPrefFrame *ret_frame;
	dSP;

	gps = (PurplePerlScript *)plugin->info->extra_info;

	ENTER;
	SAVETMPS;
	/* Some perl magic to run perl_plugin_pref_frame_SV perl sub and
	 * return the frame */
	PUSHMARK(SP);
	PUTBACK;

	count = call_pv(gps->prefs_sub, G_SCALAR | G_NOARGS);

	SPAGAIN;

	if (count != 1)
		croak("call_pv: Did not return the correct number of values.\n");
	/* the frame was created in a perl sub and is returned */
	ret_frame = (PurplePluginPrefFrame *)purple_perl_ref_object(POPs);

	/* Tidy up the Perl stack */
	PUTBACK;
	FREETMPS;
	LEAVE;

	return ret_frame;
}

static void
destroy_timeout_handler(PurplePerlTimeoutHandler *handler)
{
	timeout_handlers = g_list_remove(timeout_handlers, handler);

	if (handler->iotag > 0)
		g_source_remove(handler->iotag);

	if (handler->callback != NULL)
		SvREFCNT_dec(handler->callback);

	if (handler->data != NULL)
		SvREFCNT_dec(handler->data);

	g_free(handler);
}

static void
destroy_signal_handler(PurplePerlSignalHandler *handler)
{
	signal_handlers = g_list_remove(signal_handlers, handler);

	if (handler->callback != NULL)
		SvREFCNT_dec(handler->callback);

	if (handler->data != NULL)
		SvREFCNT_dec(handler->data);

	g_free(handler->signal);
	g_free(handler);
}

static gboolean
perl_timeout_cb(gpointer data)
{
	PurplePerlTimeoutHandler *handler = (PurplePerlTimeoutHandler *)data;

	dSP;
	ENTER;
	SAVETMPS;
	PUSHMARK(sp);
	XPUSHs((SV *)handler->data);
	PUTBACK;
	call_sv(handler->callback, G_EVAL | G_SCALAR);
	SPAGAIN;

	PUTBACK;
	FREETMPS;
	LEAVE;

	/* We're returning FALSE, so no need to manually remove the source */
	handler->iotag = 0;

	destroy_timeout_handler(handler);

	return FALSE;
}

typedef void *DATATYPE;

static void *
perl_signal_cb(va_list args, void *data)
{
	PurplePerlSignalHandler *handler = (PurplePerlSignalHandler *)data;
	void *ret_val = NULL;
	int i;
	int count;
	int value_count;
	PurpleValue *ret_value, **values;
	SV **sv_args;
	DATATYPE **copy_args;
	STRLEN na;

	dSP;
	ENTER;
	SAVETMPS;
	PUSHMARK(sp);

	purple_signal_get_values(handler->instance, handler->signal,
	                       &ret_value, &value_count, &values);

	sv_args   = g_new(SV *,    value_count);
	copy_args = g_new(void **, value_count);

	for (i = 0; i < value_count; i++) {
		sv_args[i] = purple_perl_sv_from_vargs(values[i],
		                                     (va_list*)&args,
		                                     &copy_args[i]);

		XPUSHs(sv_args[i]);
	}

	XPUSHs((SV *)handler->data);

	PUTBACK;

	if (ret_value != NULL) {
		count = call_sv(handler->callback, G_EVAL | G_SCALAR);

		SPAGAIN;

		if (count != 1)
			croak("Uh oh! call_sv returned %i != 1", i);
		else
			ret_val = purple_perl_data_from_sv(ret_value, POPs);
	} else {
		call_sv(handler->callback, G_SCALAR);

		SPAGAIN;
	}

	if (SvTRUE(ERRSV)) {
		purple_debug_error("perl",
		                 "Perl function exited abnormally: %s\n",
		                 SvPV(ERRSV, na));
	}

	/* See if any parameters changed. */
	for (i = 0; i < value_count; i++) {
		if (purple_value_is_outgoing(values[i])) {
			switch (purple_value_get_type(values[i])) {
				case PURPLE_TYPE_BOOLEAN:
					*((gboolean *)copy_args[i]) = SvIV(sv_args[i]);
					break;

				case PURPLE_TYPE_INT:
					*((int *)copy_args[i]) = SvIV(sv_args[i]);
					break;

				case PURPLE_TYPE_UINT:
					*((unsigned int *)copy_args[i]) = SvUV(sv_args[i]);
					break;

				case PURPLE_TYPE_LONG:
					*((long *)copy_args[i]) = SvIV(sv_args[i]);
					break;

				case PURPLE_TYPE_ULONG:
					*((unsigned long *)copy_args[i]) = SvUV(sv_args[i]);
					break;

				case PURPLE_TYPE_INT64:
					*((gint64 *)copy_args[i]) = SvIV(sv_args[i]);
					break;

				case PURPLE_TYPE_UINT64:
					*((guint64 *)copy_args[i]) = SvUV(sv_args[i]);
					break;

				case PURPLE_TYPE_STRING:
					if (strcmp(*((char **)copy_args[i]), SvPVX(sv_args[i]))) {
						g_free(*((char **)copy_args[i]));
						*((char **)copy_args[i]) =
							g_strdup(SvPV(sv_args[i], na));
					}
					break;

				case PURPLE_TYPE_POINTER:
					*((void **)copy_args[i]) = (void *)SvIV(sv_args[i]);
					break;

				case PURPLE_TYPE_BOXED:
					*((void **)copy_args[i]) = (void *)SvIV(sv_args[i]);
					break;

				default:
					break;
			}

#if 0
			*((void **)copy_args[i]) = purple_perl_data_from_sv(values[i],
															  sv_args[i]);
#endif
		}
	}

	PUTBACK;
	FREETMPS;
	LEAVE;

	g_free(sv_args);
	g_free(copy_args);

	purple_debug_misc("perl", "ret_val = %p\n", ret_val);

	return ret_val;
}

static PurplePerlSignalHandler *
find_signal_handler(PurplePlugin *plugin, void *instance, const char *signal)
{
	PurplePerlSignalHandler *handler;
	GList *l;

	for (l = signal_handlers; l != NULL; l = l->next) {
		handler = (PurplePerlSignalHandler *)l->data;

		if (handler->plugin == plugin &&
			handler->instance == instance &&
			!strcmp(handler->signal, signal)) {
			return handler;
		}
	}

	return NULL;
}

void
purple_perl_timeout_add(PurplePlugin *plugin, int seconds, SV *callback, SV *data)
{
	PurplePerlTimeoutHandler *handler;

	if (plugin == NULL) {
		croak("Invalid handle in adding perl timeout handler.\n");
		return;
	}

	handler = g_new0(PurplePerlTimeoutHandler, 1);

	handler->plugin   = plugin;
	handler->callback = (callback != NULL && callback != &PL_sv_undef
	                     ? newSVsv(callback) : NULL);
	handler->data     = (data != NULL && data != &PL_sv_undef
	                     ? newSVsv(data) : NULL);

	timeout_handlers = g_list_append(timeout_handlers, handler);

	handler->iotag = g_timeout_add(seconds * 1000, perl_timeout_cb, handler);
}

void
purple_perl_timeout_clear_for_plugin(PurplePlugin *plugin)
{
	PurplePerlTimeoutHandler *handler;
	GList *l, *l_next;

	for (l = timeout_handlers; l != NULL; l = l_next) {
		l_next = l->next;

		handler = (PurplePerlTimeoutHandler *)l->data;

		if (handler->plugin == plugin)
			destroy_timeout_handler(handler);
	}
}

void
purple_perl_timeout_clear(void)
{
	while (timeout_handlers != NULL)
		destroy_timeout_handler(timeout_handlers->data);
}

void
purple_perl_signal_connect(PurplePlugin *plugin, void *instance,
                         const char *signal, SV *callback, SV *data,
                         int priority)
{
	PurplePerlSignalHandler *handler;

	handler = g_new0(PurplePerlSignalHandler, 1);
	handler->plugin   = plugin;
	handler->instance = instance;
	handler->signal   = g_strdup(signal);
	handler->callback = (callback != NULL &&
	                     callback != &PL_sv_undef ? newSVsv(callback)
	                                              : NULL);
	handler->data     = (data != NULL &&
	                     data != &PL_sv_undef ? newSVsv(data) : NULL);

	signal_handlers = g_list_append(signal_handlers, handler);

	purple_signal_connect_priority_vargs(instance, signal, plugin,
	                                   PURPLE_CALLBACK(perl_signal_cb),
	                                   handler, priority);
}

void
purple_perl_signal_disconnect(PurplePlugin *plugin, void *instance,
                            const char *signal)
{
	PurplePerlSignalHandler *handler;

	handler = find_signal_handler(plugin, instance, signal);

	if (handler == NULL) {
		croak("Invalid signal handler information in "
		      "disconnecting a perl signal handler.\n");
		return;
	}

	destroy_signal_handler(handler);
}

void
purple_perl_signal_clear_for_plugin(PurplePlugin *plugin)
{
	PurplePerlSignalHandler *handler;
	GList *l, *l_next;

	for (l = signal_handlers; l != NULL; l = l_next) {
		l_next = l->next;

		handler = (PurplePerlSignalHandler *)l->data;

		if (handler->plugin == plugin)
			destroy_signal_handler(handler);
	}
}

void
purple_perl_signal_clear(void)
{
	while (signal_handlers != NULL)
		destroy_signal_handler(signal_handlers->data);
}

static PurpleCmdRet
perl_cmd_cb(PurpleConversation *conv, const gchar *command,
            gchar **args, gchar **error, void *data)
{
	int i = 0, count, ret_value = PURPLE_CMD_RET_OK;
	SV *cmdSV, *tmpSV, *convSV;
	PurplePerlCmdHandler *handler = (PurplePerlCmdHandler *)data;

	dSP;
	ENTER;
	SAVETMPS;
	PUSHMARK(SP);

	/* Push the conversation onto the perl stack */
	convSV = sv_2mortal(purple_perl_bless_object(conv, "Purple::Conversation"));
	XPUSHs(convSV);

	/* Push the command string onto the perl stack */
	cmdSV = newSVpv(command, 0);
	cmdSV = sv_2mortal(cmdSV);
	XPUSHs(cmdSV);

	/* Push the data onto the perl stack */
	XPUSHs((SV *)handler->data);

	/* Push any arguments we may have */
	for (i = 0; args[i] != NULL; i++) {
		/* XXX The mortality of these created SV's should prevent
		 * memory issues, if I read/understood everything correctly...
		 */
		tmpSV = newSVpv(args[i], 0);
		tmpSV = sv_2mortal(tmpSV);
		XPUSHs(tmpSV);
	}

	PUTBACK;
	count = call_sv(handler->callback, G_EVAL|G_SCALAR);

	if (count != 1)
		croak("call_sv: Did not return the correct number of values.\n");

	SPAGAIN;

	ret_value = POPi;

	PUTBACK;
	FREETMPS;
	LEAVE;

	return ret_value;
}

PurpleCmdId
purple_perl_cmd_register(PurplePlugin *plugin, const gchar *command,
                       const gchar *args, PurpleCmdPriority priority,
                       PurpleCmdFlag flag, const gchar *prpl_id, SV *callback,
                       const gchar *helpstr, SV *data)
{
	PurplePerlCmdHandler *handler;

	handler          = g_new0(PurplePerlCmdHandler, 1);
	handler->plugin  = plugin;
	handler->cmd     = g_strdup(command);
	handler->prpl_id = g_strdup(prpl_id);

	if (callback != NULL && callback != &PL_sv_undef)
		handler->callback = newSVsv(callback);
	else
		handler->callback = NULL;

	if (data != NULL && data != &PL_sv_undef)
		handler->data = newSVsv(data);
	else
		handler->data = NULL;

	cmd_handlers = g_list_append(cmd_handlers, handler);

	handler->id = purple_cmd_register(command, args, priority, flag, prpl_id,
	                                PURPLE_CMD_FUNC(perl_cmd_cb), helpstr,
	                                handler);

	return handler->id;
}

static void
destroy_cmd_handler(PurplePerlCmdHandler *handler)
{
	cmd_handlers = g_list_remove(cmd_handlers, handler);

	if (handler->callback != NULL)
		SvREFCNT_dec(handler->callback);

	if (handler->data != NULL)
		SvREFCNT_dec(handler->data);

	g_free(handler->cmd);
	g_free(handler->prpl_id);
	g_free(handler);
}

void
purple_perl_cmd_clear_for_plugin(PurplePlugin *plugin)
{
	GList *l, *l_next;

	for (l = cmd_handlers; l != NULL; l = l_next) {
		PurplePerlCmdHandler *handler = (PurplePerlCmdHandler *)l->data;

		l_next = l->next;

		if (handler->plugin == plugin)
			destroy_cmd_handler(handler);
	}
}

static PurplePerlCmdHandler *
find_cmd_handler(PurpleCmdId id)
{
	GList *l;

	for (l = cmd_handlers; l != NULL; l = l->next) {
		PurplePerlCmdHandler *handler = (PurplePerlCmdHandler *)l->data;

		if (handler->id == id)
			return handler;
	}

	return NULL;
}

void
purple_perl_cmd_unregister(PurpleCmdId id)
{
	PurplePerlCmdHandler *handler;

	handler = find_cmd_handler(id);

	if (handler == NULL) {
		croak("Invalid command id in removing a perl command handler.\n");
		return;
	}

	purple_cmd_unregister(id);
	destroy_cmd_handler(handler);
}