changeset 6520:2e2593d95121

[gaim-migrate @ 7037] Added timeout handler support to perl. It may not work. Probably should, but who knows. committer: Tailor Script <[e-mail]>

--- 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 \

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

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

--- 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
 

--- 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 <XSUB.h>
-#include <EXTERN.h>
-#include <perl.h>
-#include <glib.h>
+#include "debug.h"
 
 #include "perl-common.h"
 
@@ -105,3 +102,119 @@
 	return p;
 }
 
+/*
+  2003/02/06: execute_perl modified by Mark Doliner <[e-mail]>
+		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 <[e-mail]>
+		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 <[e-mail]>
+		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;
+}
+
+

--- 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 <XSUB.h>
+#include <EXTERN.h>
+#include <perl.h>
+#include <glib.h>
+
+
 //#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_ */

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

--- /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_ */

--- 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 <[e-mail]>
-		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 <[e-mail]>
-		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 <[e-mail]>
-		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