view libpurple/plugins/perl/perl-handlers.c @ 22863:56a38b60576e

Kill off sound playing child processes if they are still around after 15 seconds, as they will be if we are piling up children due to blocking on the audio device. This prevents a barrage of sounds when the device becomes available.

#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;
	STRLEN na;
	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_EVAL | G_VOID | G_DISCARD);

	SPAGAIN;

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

	PUTBACK;
	FREETMPS;
	LEAVE;
}

GList *
purple_perl_plugin_actions(PurplePlugin *plugin, gpointer context)
{
	GList *l = NULL;
	PurplePerlScript *gps;
	int i = 0, count = 0;
	STRLEN na;
	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_EVAL | G_ARRAY);

	SPAGAIN;

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

	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;
	STRLEN na;
	dSP;

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

	ENTER;
	SAVETMPS;

	count = call_pv(gps->gtk_prefs_sub, G_EVAL | 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;

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

	/* 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;
	STRLEN na;
	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_EVAL | G_SCALAR | G_NOARGS);

	SPAGAIN;

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

	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 gboolean
destroy_timeout_handler(PurplePerlTimeoutHandler *handler)
{
	gboolean ret = FALSE;

	timeout_handlers = g_list_remove(timeout_handlers, handler);

	if (handler->iotag > 0)
		ret = purple_timeout_remove(handler->iotag);

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

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

	g_free(handler);

	return ret;
}

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;
	gboolean ret = FALSE;
	STRLEN na;

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

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

	ret = POPi;

	PUTBACK;
	FREETMPS;
	LEAVE;

	if (ret == FALSE)
		destroy_timeout_handler(handler);

	return ret;
}

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_EVAL | 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;
}

guint
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 0;
	}

	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 = purple_timeout_add(seconds * 1000, perl_timeout_cb, handler);

	return handler->iotag;
}

gboolean
purple_perl_timeout_remove(guint handle)
{
	GList *l, *l_next;

	for (l = timeout_handlers; l != NULL; l = l_next) {
		PurplePerlTimeoutHandler *handler;

		l_next = l->next;

		handler = (PurplePerlTimeoutHandler *)l->data;

		if (handler->iotag == handle)
			return destroy_timeout_handler(handler);
	}

	purple_debug_info("perl", "No timeout handler found with handle %u.\n",
	                  handle);
	return FALSE;
}

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

	for (l = timeout_handlers; l != NULL; l = l_next) {
		PurplePerlTimeoutHandler *handler;

		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;
	STRLEN na;
	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");

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

	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);
}