# HG changeset patch # User Christian Hammond # Date 1061375158 0 # Node ID 2e2593d951211eb10300273256956620757bc102 # Parent 7f0fffa1077ba8cf6c9f0dba7afb628de80c88a3 [gaim-migrate @ 7037] Added timeout handler support to perl. It may not work. Probably should, but who knows. committer: Tailor Script diff -r 7f0fffa1077b -r 2e2593d95121 plugins/perl/Makefile.am --- a/plugins/perl/Makefile.am Wed Aug 20 09:33:56 2003 +0000 +++ b/plugins/perl/Makefile.am Wed Aug 20 10:25:58 2003 +0000 @@ -8,7 +8,10 @@ perl_la_LIBADD = $(PERL_LIBS) perl_la_SOURCES = \ perl.c \ - perl-common.c + perl-common.c \ + perl-common.h \ + perl-handlers.c \ + perl-handlers.h perl_la_DEPENDENCIES = \ .libs/libperl_orig.a \ diff -r 7f0fffa1077b -r 2e2593d95121 plugins/perl/common/Gaim.xs --- a/plugins/perl/common/Gaim.xs Wed Aug 20 09:33:56 2003 +0000 +++ b/plugins/perl/common/Gaim.xs Wed Aug 20 10:25:58 2003 +0000 @@ -1,13 +1,33 @@ #include "module.h" +#include "../perl-handlers.h" MODULE = Gaim PACKAGE = Gaim PROTOTYPES: ENABLE void -debug(string) +timeout_add(plugin, seconds, func, arg) + Gaim::Plugin plugin + int seconds + const char *func + void *arg +CODE: + gaim_perl_timeout_add(plugin, 1000 * seconds, func, arg); + +void +debug(category, string) + const char *category const char *string CODE: - gaim_debug(GAIM_DEBUG_INFO, "perl script", string); + gaim_debug(GAIM_DEBUG_INFO, category, string); + +void +deinit() +PREINIT: + GList *l; +CODE: + gaim_perl_timeout_clear(); + BOOT: GAIM_PERL_BOOT(Account); + diff -r 7f0fffa1077b -r 2e2593d95121 plugins/perl/common/module.h --- a/plugins/perl/common/module.h Wed Aug 20 09:33:56 2003 +0000 +++ b/plugins/perl/common/module.h Wed Aug 20 10:25:58 2003 +0000 @@ -17,3 +17,4 @@ typedef GaimAccount *Gaim__Account; typedef GaimConnection *Gaim__Connection; +typedef GaimPlugin *Gaim__Plugin; diff -r 7f0fffa1077b -r 2e2593d95121 plugins/perl/common/typemap --- a/plugins/perl/common/typemap Wed Aug 20 09:33:56 2003 +0000 +++ b/plugins/perl/common/typemap Wed Aug 20 10:25:58 2003 +0000 @@ -2,6 +2,7 @@ gboolean T_BOOL Gaim::Account T_GaimObj Gaim::Connection T_GaimObj +Gaim::Plugin T_GaimObj INPUT diff -r 7f0fffa1077b -r 2e2593d95121 plugins/perl/perl-common.c --- a/plugins/perl/perl-common.c Wed Aug 20 09:33:56 2003 +0000 +++ b/plugins/perl/perl-common.c Wed Aug 20 10:25:58 2003 +0000 @@ -1,7 +1,4 @@ -#include -#include -#include -#include +#include "debug.h" #include "perl-common.h" @@ -105,3 +102,119 @@ return p; } +/* + 2003/02/06: execute_perl modified by Mark Doliner + Pass parameters by pushing them onto the stack rather than + passing an array of strings. This way, perl scripts can + modify the parameters and we can get the changed values + and then shoot ourselves. I mean, uh, use them. + + 2001/06/14: execute_perl replaced by Martin Persson + previous use of perl_eval leaked memory, replaced with + a version that uses perl_call instead + + 30/11/2002: execute_perl modified by Eric Timme + args changed to char** so that we can have preparsed + arguments again, and many headaches ensued! This essentially + means we replaced one hacked method with a messier hacked + method out of perceived necessity. Formerly execute_perl + required a single char_ptr, and it would insert it into an + array of character pointers and NULL terminate the new array. + Now we have to pass in pre-terminated character pointer arrays + to accomodate functions that want to pass in multiple arguments. + + Previously arguments were preparsed because an argument list + was constructed in the form 'arg one','arg two' and was + executed via a call like &funcname(arglist) (see .59.x), so + the arglist was magically pre-parsed because of the method. + With Martin Persson's change to perl_call we now need to + use a null terminated list of character pointers for arguments + if we wish them to be parsed. Lacking a better way to allow + for both single arguments and many I created a NULL terminated + array in every function that called execute_perl and passed + that list into the function. In the former version a single + character pointer was passed in, and was placed into an array + of character pointers with two elements, with a NULL element + tacked onto the back, but this method no longer seemed prudent. + + Enhancements in the future might be to get rid of pre-declaring + the array sizes? I am not comfortable enough with this + subject to attempt it myself and hope it to stand the test + of time. +*/ +int +execute_perl(const char *function, int argc, char **args) +{ + int count = 0, i, ret_value = 1; + SV *sv_args[argc]; + STRLEN na; + + /* + * Set up the perl environment, push arguments onto the + * perl stack, then call the given function + */ + dSP; + ENTER; + SAVETMPS; + PUSHMARK(sp); + + for (i = 0; i < argc; i++) { + if (args[i]) { + sv_args[i] = sv_2mortal(newSVpv(args[i], 0)); + XPUSHs(sv_args[i]); + } + } + + PUTBACK; + count = call_pv(function, G_EVAL | G_SCALAR); + SPAGAIN; + + /* + * Check for "die," make sure we have 1 argument, and set our + * return value. + */ + if (SvTRUE(ERRSV)) { + gaim_debug(GAIM_DEBUG_ERROR, "perl", + "Perl function %s exited abnormally: %s\n", + function, SvPV(ERRSV, na)); + POPs; + } + else if (count != 1) { + /* + * This should NEVER happen. G_SCALAR ensures that we WILL + * have 1 parameter. + */ + gaim_debug(GAIM_DEBUG_ERROR, "perl", + "Perl error from %s: expected 1 return value, " + "but got %d\n", function, count); + } + else + ret_value = POPi; + + /* Check for changed arguments */ + for (i = 0; i < argc; i++) { + if (args[i] && strcmp(args[i], SvPVX(sv_args[i]))) { + /* + * Shizzel. So the perl script changed one of the parameters, + * and we want this change to affect the original parameters. + * args[i] is just a tempory little list of pointers. We don't + * want to free args[i] here because the new parameter doesn't + * overwrite the data that args[i] points to. That is done by + * the function that called execute_perl. I'm not explaining this + * very well. See, it's aggregate... Oh, but if 2 perl scripts + * both modify the data, _that's_ a memleak. This is really kind + * of hackish. I should fix it. Look how long this comment is. + * Holy crap. + */ + args[i] = g_strdup(SvPV(sv_args[i], na)); + } + } + + PUTBACK; + FREETMPS; + LEAVE; + + return ret_value; +} + + diff -r 7f0fffa1077b -r 2e2593d95121 plugins/perl/perl-common.h --- a/plugins/perl/perl-common.h Wed Aug 20 09:33:56 2003 +0000 +++ b/plugins/perl/perl-common.h Wed Aug 20 10:25:58 2003 +0000 @@ -1,6 +1,12 @@ #ifndef _GAIM_PERL_COMMON_H_ #define _GAIM_PERL_COMMON_H_ +#include +#include +#include +#include + + //#define plain_bless(object, stash) \ // sv_bless(sv_setref_pv(newRV((object)))) @@ -26,4 +32,6 @@ gboolean gaim_perl_is_ref_object(SV *o); void *gaim_perl_ref_object(SV *o); +int execute_perl(const char *function, int argc, char **args); + #endif /* _GAIM_PERL_COMMON_H_ */ diff -r 7f0fffa1077b -r 2e2593d95121 plugins/perl/perl-handlers.c --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/plugins/perl/perl-handlers.c Wed Aug 20 10:25:58 2003 +0000 @@ -0,0 +1,91 @@ +#include "perl-common.h" +#include "perl-handlers.h" + +#include "debug.h" + +static GList *timeout_handlers = NULL; + +extern PerlInterpreter *my_perl; + +static void +destroy_timeout_handler(GaimPerlTimeoutHandler *handler) +{ + timeout_handlers = g_list_remove(timeout_handlers, handler); + + g_free(handler->name); + g_free(handler); +} + +static int +perl_timeout_cb(gpointer data) +{ + void *atmp[2] = { NULL, NULL }; + GaimPerlTimeoutHandler *handler = (GaimPerlTimeoutHandler *)data; + + dSP; + ENTER; + SAVETMPS; + PUSHMARK(sp); + XPUSHs((SV *)handler->args); + PUTBACK; + call_pv(handler->name, G_EVAL | G_SCALAR); + SPAGAIN; + + atmp[0] = handler->args; + + PUTBACK; + FREETMPS; + LEAVE; + + destroy_timeout_handler(handler); + + return 0; +} + +void +gaim_perl_timeout_add(GaimPlugin *plugin, int seconds, const char *func, + void *args) +{ + GaimPerlTimeoutHandler *handler; + + if (plugin == NULL) + { + gaim_debug(GAIM_DEBUG_ERROR, "perl", + "Invalid handle in adding perl timeout handler.\n"); + return; + } + + handler = g_new0(GaimPerlTimeoutHandler, 1); + + handler->plugin = plugin; + handler->name = g_strdup(func); + handler->args = args; + + timeout_handlers = g_list_append(timeout_handlers, handler); + handler->iotag = g_timeout_add(seconds * 1000, perl_timeout_cb, handler); +} + +void +gaim_perl_timeout_clear_for_plugin(GaimPlugin *plugin) +{ + GaimPerlTimeoutHandler *handler; + GList *l, *l_next; + + for (l = timeout_handlers; l != NULL; l = l_next) + { + l_next = l->next; + + handler = (GaimPerlTimeoutHandler *)l->data; + + if (handler->plugin == plugin) + destroy_timeout_handler(handler); + } +} + +void +gaim_perl_timeout_clear(void) +{ + while (timeout_handlers) + destroy_timeout_handler(timeout_handlers->data); +} + diff -r 7f0fffa1077b -r 2e2593d95121 plugins/perl/perl-handlers.h --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/plugins/perl/perl-handlers.h Wed Aug 20 10:25:58 2003 +0000 @@ -0,0 +1,20 @@ +#ifndef _GAIM_PERL_HANDLERS_H_ +#define _GAIM_PERL_HANDLERS_H_ + +#include "plugin.h" + +typedef struct +{ + char *name; + char *args; + GaimPlugin *plugin; + int iotag; + +} GaimPerlTimeoutHandler; + +void gaim_perl_timeout_add(GaimPlugin *plugin, int seconds, const char *func, + void *args); +void gaim_perl_timeout_clear_for_plugin(GaimPlugin *plugin); +void gaim_perl_timeout_clear(void); + +#endif /* _GAIM_PERL_HANDLERS_H_ */ diff -r 7f0fffa1077b -r 2e2593d95121 plugins/perl/perl.c --- a/plugins/perl/perl.c Wed Aug 20 09:33:56 2003 +0000 +++ b/plugins/perl/perl.c Wed Aug 20 10:25:58 2003 +0000 @@ -161,130 +161,24 @@ perl_run(my_perl); } -/* - 2003/02/06: execute_perl modified by Mark Doliner - Pass parameters by pushing them onto the stack rather than - passing an array of strings. This way, perl scripts can - modify the parameters and we can get the changed values - and then shoot ourselves. I mean, uh, use them. - - 2001/06/14: execute_perl replaced by Martin Persson - previous use of perl_eval leaked memory, replaced with - a version that uses perl_call instead - - 30/11/2002: execute_perl modified by Eric Timme - args changed to char** so that we can have preparsed - arguments again, and many headaches ensued! This essentially - means we replaced one hacked method with a messier hacked - method out of perceived necessity. Formerly execute_perl - required a single char_ptr, and it would insert it into an - array of character pointers and NULL terminate the new array. - Now we have to pass in pre-terminated character pointer arrays - to accomodate functions that want to pass in multiple arguments. - - Previously arguments were preparsed because an argument list - was constructed in the form 'arg one','arg two' and was - executed via a call like &funcname(arglist) (see .59.x), so - the arglist was magically pre-parsed because of the method. - With Martin Persson's change to perl_call we now need to - use a null terminated list of character pointers for arguments - if we wish them to be parsed. Lacking a better way to allow - for both single arguments and many I created a NULL terminated - array in every function that called execute_perl and passed - that list into the function. In the former version a single - character pointer was passed in, and was placed into an array - of character pointers with two elements, with a NULL element - tacked onto the back, but this method no longer seemed prudent. - - Enhancements in the future might be to get rid of pre-declaring - the array sizes? I am not comfortable enough with this - subject to attempt it myself and hope it to stand the test - of time. -*/ - -static int -execute_perl(const char *function, int argc, char **args) -{ - int count = 0, i, ret_value = 1; - SV *sv_args[argc]; - STRLEN na; - - /* - * Set up the perl environment, push arguments onto the - * perl stack, then call the given function - */ - dSP; - ENTER; - SAVETMPS; - PUSHMARK(sp); - - for (i = 0; i < argc; i++) { - if (args[i]) { - sv_args[i] = sv_2mortal(newSVpv(args[i], 0)); - XPUSHs(sv_args[i]); - } - } - - PUTBACK; - count = call_pv(function, G_EVAL | G_SCALAR); - SPAGAIN; - - /* - * Check for "die," make sure we have 1 argument, and set our - * return value. - */ - if (SvTRUE(ERRSV)) { - gaim_debug(GAIM_DEBUG_ERROR, "perl", - "Perl function %s exited abnormally: %s\n", - function, SvPV(ERRSV, na)); - POPs; - } - else if (count != 1) { - /* - * This should NEVER happen. G_SCALAR ensures that we WILL - * have 1 parameter. - */ - gaim_debug(GAIM_DEBUG_ERROR, "perl", - "Perl error from %s: expected 1 return value, " - "but got %d\n", function, count); - } - else - ret_value = POPi; - - /* Check for changed arguments */ - for (i = 0; i < argc; i++) { - if (args[i] && strcmp(args[i], SvPVX(sv_args[i]))) { - /* - * Shizzel. So the perl script changed one of the parameters, - * and we want this change to affect the original parameters. - * args[i] is just a tempory little list of pointers. We don't - * want to free args[i] here because the new parameter doesn't - * overwrite the data that args[i] points to. That is done by - * the function that called execute_perl. I'm not explaining this - * very well. See, it's aggregate... Oh, but if 2 perl scripts - * both modify the data, _that's_ a memleak. This is really kind - * of hackish. I should fix it. Look how long this comment is. - * Holy crap. - */ - args[i] = g_strdup(SvPV(sv_args[i], na)); - } - } - - PUTBACK; - FREETMPS; - LEAVE; - - return ret_value; -} - static void perl_end(void) { - if (my_perl != NULL) { - perl_destruct(my_perl); - perl_free(my_perl); - my_perl = NULL; - } + if (my_perl == NULL) + return; + + perl_eval_pv( + "foreach my $lib (@DynaLoader::dl_modules) {" + "if ($lib =~ /^Gaim\\b/) {" + "$lib .= '::deinit();';" + "eval $lib;" + "}" + "}", + TRUE); + + perl_destruct(my_perl); + perl_free(my_perl); + my_perl = NULL; } void