static gboolean
perl_timeout_cb(gpointer data)
{
PurplePerlTimeoutHandler *handler = data;
gboolean ret = FALSE;
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",
SvPVutf8_nolen(ERRSV));
}
ret = POPi;
PUTBACK;
FREETMPS;
LEAVE;
if (ret == FALSE)
destroy_timeout_handler(handler);
return ret;
}
/* this is public so that other extensions which use GtkMenuPosFunc (e.g.
* libgnomeui) don't need to reimplement it. */
void
gtk2perl_menu_position_func (GtkMenu * menu,
gint * x,
gint * y,
gboolean * push_in,
GPerlCallback * callback)
{
int n;
dGPERL_CALLBACK_MARSHAL_SP;
GPERL_CALLBACK_MARSHAL_INIT (callback);
ENTER;
SAVETMPS;
PUSHMARK (SP);
EXTEND (SP, 3);
PUSHs (sv_2mortal (newSVGtkMenu (menu)));
PUSHs (sv_2mortal (newSViv (*x)));
PUSHs (sv_2mortal (newSViv (*y)));
if (callback->data)
XPUSHs (sv_2mortal (newSVsv (callback->data)));
/* A die() from callback->func is suspected to be bad or very bad.
Circa Gtk 2.18 a jump out of $menu->popup seems to leave an X
grab with no way to get rid of it (no keyboard Esc, and no mouse
click handlers). The position func can also be called later for
things like resizing or move to a different GdkScreen, and such a
call might come straight from the main loop, where a die() would
jump out of Gtk2->main. */
PUTBACK;
n = call_sv (callback->func, G_ARRAY | G_EVAL);
SPAGAIN;
if (SvTRUE (ERRSV)) {
g_warning ("menu position callback ignoring error: %s",
SvPVutf8_nolen (ERRSV));
} else if (n < 2 || n > 3) {
g_warning ("menu position callback must return two integers "
"(x, and y) or two integers and a boolean "
"(x, y, and push_in)");
} else {
/* POPs and POPi take things off the *end* of the stack! */
if (n > 2) {
SV *sv = POPs;
*push_in = sv_2bool (sv);
}
if (n > 1) *y = POPi;
if (n > 0) *x = POPi;
}
PUTBACK;
FREETMPS;
LEAVE;
}
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 = 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",
SvPVutf8_nolen(ERRSV));
}
SPAGAIN;
ret_value = POPi;
PUTBACK;
FREETMPS;
LEAVE;
return ret_value;
}
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_EVAL | G_VOID | G_DISCARD);
SPAGAIN;
if (SvTRUE(ERRSV)) {
purple_debug_error("perl",
"Perl plugin action function exited abnormally: %s\n",
SvPVutf8_nolen(ERRSV));
}
PUTBACK;
FREETMPS;
LEAVE;
}
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_EVAL | G_SCALAR | G_NOARGS);
SPAGAIN;
if (SvTRUE(ERRSV)) {
purple_debug_error("perl",
"Perl plugin prefs frame init exited abnormally: %s\n",
SvPVutf8_nolen(ERRSV));
}
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;
}
GtkWidget *
purple_perl_gtk_get_plugin_frame(PurplePlugin *plugin)
{
SV * sv;
int count;
MAGIC *mg;
GtkWidget *ret;
PurplePerlScript *gps;
dSP;
gps = 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",
SvPVutf8_nolen(ERRSV));
}
/* 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;
}
static void *
perl_signal_cb(va_list args, void *data)
{
PurplePerlSignalHandler *handler = data;
void *ret_val = NULL;
int i;
int count;
int value_count;
PurpleValue *ret_value, **values;
SV **sv_args;
DATATYPE **copy_args;
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],
#ifdef VA_COPY_AS_ARRAY
args,
#else
(va_list*)&args,
#endif
©_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",
SvPVutf8_nolen(ERRSV));
}
/* 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(SvPVutf8_nolen(sv_args[i]));
}
/* Clean up sv_args[i] - we're done with it */
sv_2mortal(sv_args[i]);
break;
case PURPLE_TYPE_POINTER:
case PURPLE_TYPE_BOXED:
*((void **)copy_args[i]) = (void *)SvIV(sv_args[i]);
break;
case PURPLE_TYPE_SUBTYPE:
*((void **)copy_args[i]) = purple_perl_ref_object(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;
}