GList *
purple_perl_plugin_actions(PurplePlugin *plugin, gpointer context)
{
GList *l = NULL;
PurplePerlScript *gps;
int i = 0, count = 0;
dSP;
gps = 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",
SvPVutf8_nolen(ERRSV));
}
if (count == 0)
croak("The plugin_actions sub didn't return anything.\n");
for (i = 0; i < count; i++) {
SV *sv;
PurplePluginAction *act;
sv = POPs;
act = purple_plugin_action_new(SvPVutf8_nolen(sv), purple_perl_plugin_action_cb);
l = g_list_prepend(l, act);
}
PUTBACK;
FREETMPS;
LEAVE;
return l;
}
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;
}
static gboolean
load_perl_plugin(PurplePlugin *plugin)
{
PurplePerlScript *gps = (PurplePerlScript *)plugin->info->extra_info;
char *atmp[3] = { plugin->path, NULL, NULL };
if (gps == NULL || gps->load_sub == NULL)
return FALSE;
purple_debug(PURPLE_DEBUG_INFO, "perl", "Loading perl script\n");
if (my_perl == NULL)
perl_init();
plugin->handle = gps;
atmp[1] = gps->package;
PERL_SET_CONTEXT(my_perl);
execute_perl("Purple::PerlLoader::load_n_eval", 2, atmp);
{
dSP;
PERL_SET_CONTEXT(my_perl);
SPAGAIN;
ENTER;
SAVETMPS;
PUSHMARK(sp);
XPUSHs(sv_2mortal(purple_perl_bless_object(plugin,
"Purple::Plugin")));
PUTBACK;
perl_call_pv(gps->load_sub, G_EVAL | G_SCALAR);
SPAGAIN;
if (SvTRUE(ERRSV)) {
STRLEN len;
purple_debug(PURPLE_DEBUG_ERROR, "perl",
"Perl function %s exited abnormally: %s\n",
gps->load_sub, SvPV(ERRSV, len));
}
PUTBACK;
FREETMPS;
LEAVE;
}
return TRUE;
}
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;
}
static gboolean
unload_perl_plugin(PurplePlugin *plugin)
{
PurplePerlScript *gps = (PurplePerlScript *)plugin->info->extra_info;
if (gps == NULL)
return FALSE;
purple_debug(PURPLE_DEBUG_INFO, "perl", "Unloading perl script\n");
if (gps->unload_sub != NULL) {
dSP;
PERL_SET_CONTEXT(my_perl);
SPAGAIN;
ENTER;
SAVETMPS;
PUSHMARK(sp);
XPUSHs(sv_2mortal(purple_perl_bless_object(plugin,
"Purple::Plugin")));
PUTBACK;
perl_call_pv(gps->unload_sub, G_EVAL | G_SCALAR);
SPAGAIN;
if (SvTRUE(ERRSV)) {
STRLEN len;
purple_debug(PURPLE_DEBUG_ERROR, "perl",
"Perl function %s exited abnormally: %s\n",
gps->load_sub, SvPV(ERRSV, len));
}
PUTBACK;
FREETMPS;
LEAVE;
}
purple_perl_cmd_clear_for_plugin(plugin);
purple_perl_signal_clear_for_plugin(plugin);
purple_perl_timeout_clear_for_plugin(plugin);
destroy_package(gps->package);
return TRUE;
}