X-Git-Url: https://git.octo.it/?a=blobdiff_plain;f=src%2Fperl.c;h=d0c7e372e79434a06c50cf8610de6ca158bcaee0;hb=c1219a1c9db2e8400e2ee94b87f86ccd441485d5;hp=41e763dc098d303f9cc67fc7028b780707d528dd;hpb=09a676620cb38503f57d12e0452c0e72cd691f7f;p=collectd.git

diff --git a/src/perl.c b/src/perl.c
index 41e763dc..d0c7e372 100644
--- a/src/perl.c
+++ b/src/perl.c
@@ -24,7 +24,7 @@
  * interface for collectd plugins written in perl.
  */
 
-/* do not automatically get the thread specific perl interpreter */
+/* do not automatically get the thread specific Perl interpreter */
 #define PERL_NO_GET_CONTEXT
 
 #define DONT_POISON_SPRINTF_YET 1
@@ -33,6 +33,10 @@
 
 #include "configfile.h"
 
+#if HAVE_STDBOOL_H
+# include <stdbool.h>
+#endif
+
 #include <EXTERN.h>
 #include <perl.h>
 
@@ -98,6 +102,7 @@ void boot_DynaLoader (PerlInterpreter *, CV *);
 static XS (Collectd_plugin_register_ds);
 static XS (Collectd_plugin_unregister_ds);
 static XS (Collectd_plugin_dispatch_values);
+static XS (Collectd_plugin_get_interval);
 static XS (Collectd__plugin_write);
 static XS (Collectd__plugin_flush);
 static XS (Collectd_plugin_dispatch_notification);
@@ -112,6 +117,9 @@ static XS (Collectd_call_by_name);
 typedef struct c_ithread_s {
 	/* the thread's Perl interpreter */
 	PerlInterpreter *interp;
+	_Bool running;  /* thread is inside Perl interpreter */
+	_Bool shutdown;
+	pthread_t pthread;
 
 	/* double linked list of threads */
 	struct c_ithread_s *prev;
@@ -128,6 +136,7 @@ typedef struct {
 #endif /* COLLECT_DEBUG */
 
 	pthread_mutex_t mutex;
+	pthread_mutexattr_t mutexattr;
 } c_ithread_list_t;
 
 /* name / user_data for Perl matches / targets */
@@ -173,6 +182,7 @@ static struct {
 	{ "Collectd::plugin_register_data_set",   Collectd_plugin_register_ds },
 	{ "Collectd::plugin_unregister_data_set", Collectd_plugin_unregister_ds },
 	{ "Collectd::plugin_dispatch_values",     Collectd_plugin_dispatch_values },
+	{ "Collectd::plugin_get_interval",        Collectd_plugin_get_interval },
 	{ "Collectd::_plugin_write",              Collectd__plugin_write },
 	{ "Collectd::_plugin_flush",              Collectd__plugin_flush },
 	{ "Collectd::plugin_dispatch_notification",
@@ -231,15 +241,6 @@ struct {
 	{ "", NULL }
 };
 
-struct {
-	char  name[64];
-	int  *var;
-} g_integers[] =
-{
-	{ "Collectd::interval_g", &interval_g },
-	{ "", NULL }
-};
-
 /*
  * Helper functions for data type conversion.
  */
@@ -393,10 +394,16 @@ static int hv2value_list (pTHX_ HV *hash, value_list_t *vl)
 	}
 
 	if (NULL != (tmp = hv_fetch (hash, "time", 4, 0)))
-		vl->time = (time_t)SvIV (*tmp);
+	{
+		double t = SvNV (*tmp);
+		vl->time = DOUBLE_TO_CDTIME_T (t);
+	}
 
 	if (NULL != (tmp = hv_fetch (hash, "interval", 8, 0)))
-		vl->interval = SvIV (*tmp);
+	{
+		double t = SvNV (*tmp);
+		vl->interval = DOUBLE_TO_CDTIME_T (t);
+	}
 
 	if (NULL != (tmp = hv_fetch (hash, "host", 4, 0)))
 		sstrncpy (vl->host, SvPV_nolen (*tmp), sizeof (vl->host));
@@ -507,7 +514,6 @@ static int av2notification_meta (pTHX_ AV *array, notification_meta_t **meta)
 		if (NULL == (tmp = hv_fetch (hash, "value", 5, 0))) {
 			log_warn ("av2notification_meta: Skipping invalid "
 					"meta information.");
-			free ((*m)->name);
 			free (*m);
 			continue;
 		}
@@ -548,9 +554,12 @@ static int hv2notification (pTHX_ HV *hash, notification_t *n)
 		n->severity = NOTIF_FAILURE;
 
 	if (NULL != (tmp = hv_fetch (hash, "time", 4, 0)))
-		n->time = (time_t)SvIV (*tmp);
+	{
+		double t = SvNV (*tmp);
+		n->time = DOUBLE_TO_CDTIME_T (t);
+	}
 	else
-		n->time = time (NULL);
+		n->time = cdtime ();
 
 	if (NULL != (tmp = hv_fetch (hash, "message", 7, 0)))
 		sstrncpy (n->message, SvPV_nolen (*tmp), sizeof (n->message));
@@ -668,11 +677,17 @@ static int value_list2hv (pTHX_ value_list_t *vl, data_set_t *ds, HV *hash)
 		return -1;
 
 	if (0 != vl->time)
-		if (NULL == hv_store (hash, "time", 4, newSViv (vl->time), 0))
+	{
+		double t = CDTIME_T_TO_DOUBLE (vl->time);
+		if (NULL == hv_store (hash, "time", 4, newSVnv (t), 0))
 			return -1;
+	}
 
-	if (NULL == hv_store (hash, "interval", 8, newSViv (vl->interval), 0))
-		return -1;
+	{
+		double t = CDTIME_T_TO_DOUBLE (vl->interval);
+		if (NULL == hv_store (hash, "interval", 8, newSVnv (t), 0))
+			return -1;
+	}
 
 	if ('\0' != vl->host[0])
 		if (NULL == hv_store (hash, "host", 4, newSVpv (vl->host, 0), 0))
@@ -750,8 +765,11 @@ static int notification2hv (pTHX_ notification_t *n, HV *hash)
 		return -1;
 
 	if (0 != n->time)
-		if (NULL == hv_store (hash, "time", 4, newSViv (n->time), 0))
+	{
+		double t = CDTIME_T_TO_DOUBLE (n->time);
+		if (NULL == hv_store (hash, "time", 4, newSVnv (t), 0))
 			return -1;
+	}
 
 	if ('\0' != *n->message)
 		if (NULL == hv_store (hash, "message", 7, newSVpv (n->message, 0), 0))
@@ -988,6 +1006,32 @@ static int pplugin_dispatch_notification (pTHX_ HV *notif)
 } /* static int pplugin_dispatch_notification (HV *) */
 
 /*
+ * Call perl sub with thread locking flags handled.
+ */
+static int call_pv_locked (pTHX_ const char* sub_name)
+{
+	_Bool old_running;
+	int ret;
+
+	c_ithread_t *t = (c_ithread_t *)pthread_getspecific(perl_thr_key);
+	if (t == NULL) /* thread destroyed */
+		return 0;
+
+	old_running = t->running;
+	t->running = 1;
+
+	if (t->shutdown) {
+		t->running = old_running;
+		return 0;
+	}
+
+	ret = call_pv (sub_name, G_SCALAR);
+
+	t->running = old_running;
+	return ret;
+} /* static int call_pv_locked (pTHX, *sub_name) */
+
+/*
  * Call all working functions of the given type.
  */
 static int pplugin_call_all (pTHX_ int type, ...)
@@ -1102,17 +1146,21 @@ static int pplugin_call_all (pTHX_ int type, ...)
 		XPUSHs (sv_2mortal (newRV_noinc ((SV *)notif)));
 	}
 	else if (PLUGIN_FLUSH == type) {
+		cdtime_t timeout;
+
 		/*
 		 * $_[0] = $timeout;
 		 * $_[1] = $identifier;
 		 */
-		XPUSHs (sv_2mortal (newSViv (va_arg (ap, int))));
+		timeout = va_arg (ap, cdtime_t);
+
+		XPUSHs (sv_2mortal (newSVnv (CDTIME_T_TO_DOUBLE (timeout))));
 		XPUSHs (sv_2mortal (newSVpv (va_arg (ap, char *), 0)));
 	}
 
 	PUTBACK;
 
-	retvals = call_pv ("Collectd::plugin_call_all", G_SCALAR);
+	retvals = call_pv_locked (aTHX_ "Collectd::plugin_call_all");
 
 	SPAGAIN;
 	if (0 < retvals) {
@@ -1130,7 +1178,7 @@ static int pplugin_call_all (pTHX_ int type, ...)
 } /* static int pplugin_call_all (int, ...) */
 
 /*
- * collectd's perl interpreter based thread implementation.
+ * collectd's Perl interpreter based thread implementation.
  *
  * This has been inspired by Perl's ithreads introduced in version 5.6.0.
  */
@@ -1184,7 +1232,10 @@ static void c_ithread_destructor (void *arg)
 
 	/* the ithread no longer exists */
 	if (NULL == t)
+	{
+		pthread_mutex_unlock (&perl_threads->mutex);
 		return;
+	}
 
 	c_ithread_destroy (ithread);
 
@@ -1230,6 +1281,9 @@ static c_ithread_t *c_ithread_create (PerlInterpreter *base)
 		t->prev = perl_threads->tail;
 	}
 
+	t->pthread = pthread_self();
+	t->running = 0;
+	t->shutdown = 0;
 	perl_threads->tail = t;
 
 	pthread_setspecific (perl_thr_key, (const void *)t);
@@ -1350,7 +1404,7 @@ static int fc_call (pTHX_ int type, int cb_type, pfc_user_data_t *data, ...)
 
 	PUTBACK;
 
-	retvals = call_pv ("Collectd::fc_call", G_SCALAR);
+	retvals = call_pv_locked (aTHX_ "Collectd::fc_call");
 
 	if ((FC_CB_EXEC == cb_type) && (meta != NULL)) {
 		assert (pmeta != NULL);
@@ -1610,38 +1664,27 @@ static XS (Collectd_plugin_unregister_ds)
 static XS (Collectd_plugin_dispatch_values)
 {
 	SV *values     = NULL;
-	int values_idx = 0;
 
 	int ret = 0;
 
 	dXSARGS;
 
-	if (2 == items) {
-		log_warn ("Collectd::plugin_dispatch_values with two arguments "
-				"is deprecated - pass the type through values->{type}.");
-		values_idx = 1;
-	}
-	else if (1 != items) {
+	if (1 != items) {
 		log_err ("Usage: Collectd::plugin_dispatch_values(values)");
 		XSRETURN_EMPTY;
 	}
 
 	log_debug ("Collectd::plugin_dispatch_values: values=\"%s\"",
-			SvPV_nolen (ST (values_idx)));
+			SvPV_nolen (ST (/* stack index = */ 0)));
 
-	values = ST (values_idx);
-
-	if (! (SvROK (values) && (SVt_PVHV == SvTYPE (SvRV (values))))) {
-		log_err ("Collectd::plugin_dispatch_values: Invalid values.");
-		XSRETURN_EMPTY;
-	}
+	values = ST (/* stack index = */ 0);
 
-	if (((2 == items) && (NULL == ST (0))) || (NULL == values))
+	if (NULL == values)
 		XSRETURN_EMPTY;
 
-	if ((2 == items) && (NULL == hv_store ((HV *)SvRV (values), "type", 4,
-			newSVsv (ST (0)), 0))) {
-		log_err ("Collectd::plugin_dispatch_values: Could not store type.");
+	/* Make sure the argument is a hash reference. */
+	if (! (SvROK (values) && (SVt_PVHV == SvTYPE (SvRV (values))))) {
+		log_err ("Collectd::plugin_dispatch_values: Invalid values.");
 		XSRETURN_EMPTY;
 	}
 
@@ -1653,6 +1696,21 @@ static XS (Collectd_plugin_dispatch_values)
 		XSRETURN_EMPTY;
 } /* static XS (Collectd_plugin_dispatch_values) */
 
+/*
+ * Collectd::plugin_get_interval ().
+ */
+static XS (Collectd_plugin_get_interval)
+{
+	dXSARGS;
+
+	/* make sure we don't get any unused variable warnings for 'items';
+	 * don't abort, though */
+	if (items)
+		log_err ("Usage: Collectd::plugin_get_interval()");
+
+	XSRETURN_NV ((NV) CDTIME_T_TO_DOUBLE (plugin_get_interval ()));
+} /* static XS (Collectd_plugin_get_interval) */
+
 /* Collectd::plugin_write (plugin, ds, vl).
  *
  * plugin:
@@ -1886,6 +1944,7 @@ static XS (Collectd_call_by_name)
 
 static int perl_init (void)
 {
+	int status;
 	dTHX;
 
 	if (NULL == perl_threads)
@@ -1903,7 +1962,19 @@ static int perl_init (void)
 
 	log_debug ("perl_init: c_ithread: interp = %p (active threads: %i)",
 			aTHX, perl_threads->number_of_threads);
-	return pplugin_call_all (aTHX_ PLUGIN_INIT);
+
+	/* Lock the base thread to avoid race conditions with c_ithread_create().
+	 * See https://github.com/collectd/collectd/issues/9 and
+	 *     https://github.com/collectd/collectd/issues/1706 for details.
+	*/
+	assert (aTHX == perl_threads->head->interp);
+	pthread_mutex_lock (&perl_threads->mutex);
+
+	status = pplugin_call_all (aTHX_ PLUGIN_INIT);
+
+	pthread_mutex_unlock (&perl_threads->mutex);
+
+	return status;
 } /* static int perl_init (void) */
 
 static int perl_read (void)
@@ -1988,7 +2059,9 @@ static void perl_log (int level, const char *msg,
 
 	/* Lock the base thread if this is not called from one of the read threads
 	 * to avoid race conditions with c_ithread_create(). See
-	 * https://github.com/collectd/collectd/issues/9 for details. */
+	 * https://github.com/collectd/collectd/issues/9 for details.
+	*/
+
 	if (aTHX == perl_threads->head->interp)
 		pthread_mutex_lock (&perl_threads->mutex);
 
@@ -2020,7 +2093,7 @@ static int perl_notify (const notification_t *notif,
 	return pplugin_call_all (aTHX_ PLUGIN_NOTIF, notif);
 } /* static int perl_notify (const notification_t *) */
 
-static int perl_flush (int timeout, const char *identifier,
+static int perl_flush (cdtime_t timeout, const char *identifier,
 		user_data_t __attribute__((unused)) *user_data)
 {
 	dTHX;
@@ -2054,7 +2127,7 @@ static int perl_shutdown (void)
 		return 0;
 
 	if (NULL == aTHX) {
-		c_ithread_t *t = NULL;
+		t = NULL;
 
 		pthread_mutex_lock (&perl_threads->mutex);
 		t = c_ithread_create (perl_threads->head->interp);
@@ -2079,17 +2152,31 @@ static int perl_shutdown (void)
 	t = perl_threads->tail;
 
 	while (NULL != t) {
+		struct timespec ts_wait;
 		c_ithread_t *thr = t;
 
 		/* the pointer has to be advanced before destroying
 		 * the thread as this will free the memory */
 		t = t->prev;
 
+		thr->shutdown = 1;
+		if (thr->running) {
+			/* Give some time to thread to exit from Perl interpreter */
+			WARNING ("perl shutdown: Thread is running inside Perl. Waiting.");
+			ts_wait.tv_sec = 0;
+			ts_wait.tv_nsec = 500000;
+			nanosleep (&ts_wait, NULL);
+		}
+		if (thr->running) {
+			pthread_kill (thr->pthread, SIGTERM);
+			ERROR ("perl shutdown: Thread hangs inside Perl. Thread killed.");
+		}
 		c_ithread_destroy (thr);
 	}
 
 	pthread_mutex_unlock (&perl_threads->mutex);
 	pthread_mutex_destroy (&perl_threads->mutex);
+	pthread_mutexattr_destroy (&perl_threads->mutexattr);
 
 	sfree (perl_threads);
 
@@ -2122,19 +2209,24 @@ static int g_pv_set (pTHX_ SV *var, MAGIC *mg)
 	return 0;
 } /* static int g_pv_set (pTHX_ SV *, MAGIC *) */
 
-static int g_iv_get (pTHX_ SV *var, MAGIC *mg)
+static int g_interval_get (pTHX_ SV *var, MAGIC *mg)
 {
-	int *iv = (int *)mg->mg_ptr;
-	sv_setiv (var, *iv);
+	log_warn ("Accessing $interval_g is deprecated (and might not "
+			"give the desired results) - plugin_get_interval() should "
+			"be used instead.");
+	sv_setnv (var, CDTIME_T_TO_DOUBLE (interval_g));
 	return 0;
-} /* static int g_iv_get (pTHX_ SV *, MAGIC *) */
+} /* static int g_interval_get (pTHX_ SV *, MAGIC *) */
 
-static int g_iv_set (pTHX_ SV *var, MAGIC *mg)
+static int g_interval_set (pTHX_ SV *var, MAGIC *mg)
 {
-	int *iv = (int *)mg->mg_ptr;
-	*iv = (int)SvIV (var);
+	double nv = (double)SvNV (var);
+	log_warn ("Accessing $interval_g is deprecated (and might not "
+			"give the desired results) - plugin_get_interval() should "
+			"be used instead.");
+	interval_g = DOUBLE_TO_CDTIME_T (nv);
 	return 0;
-} /* static int g_iv_set (pTHX_ SV *, MAGIC *) */
+} /* static int g_interval_set (pTHX_ SV *, MAGIC *) */
 
 static MGVTBL g_pv_vtbl = {
 	g_pv_get, g_pv_set, NULL, NULL, NULL, NULL, NULL
@@ -2142,8 +2234,8 @@ static MGVTBL g_pv_vtbl = {
 		, NULL
 #endif
 };
-static MGVTBL g_iv_vtbl = {
-	g_iv_get, g_iv_set, NULL, NULL, NULL, NULL, NULL
+static MGVTBL g_interval_vtbl = {
+	g_interval_get, g_interval_set, NULL, NULL, NULL, NULL, NULL
 #if HAVE_PERL_STRUCT_MGVTBL_SVT_LOCAL
 		, NULL
 #endif
@@ -2185,12 +2277,11 @@ static void xs_init (pTHX)
 				g_strings[i].var, 0);
 	}
 
-	/* global integers */
-	for (i = 0; '\0' != g_integers[i].name[0]; ++i) {
-		tmp = get_sv (g_integers[i].name, 1);
-		sv_magicext (tmp, NULL, PERL_MAGIC_ext, &g_iv_vtbl,
-				(char *)g_integers[i].var, 0);
-	}
+	tmp = get_sv ("Collectd::interval_g", /* create = */ 1);
+	sv_magicext (tmp, NULL, /* how = */ PERL_MAGIC_ext,
+			/* vtbl = */ &g_interval_vtbl,
+			/* name = */ NULL, /* namelen = */ 0);
+
 	return;
 } /* static void xs_init (pTHX) */
 
@@ -2229,7 +2320,9 @@ static int init_pi (int argc, char **argv)
 	perl_threads = (c_ithread_list_t *)smalloc (sizeof (c_ithread_list_t));
 	memset (perl_threads, 0, sizeof (c_ithread_list_t));
 
-	pthread_mutex_init (&perl_threads->mutex, NULL);
+	pthread_mutexattr_init(&perl_threads->mutexattr);
+	pthread_mutexattr_settype(&perl_threads->mutexattr, PTHREAD_MUTEX_RECURSIVE);
+	pthread_mutex_init (&perl_threads->mutex, &perl_threads->mutexattr);
 	/* locking the mutex should not be necessary at this point
 	 * but let's just do it for the sake of completeness */
 	pthread_mutex_lock (&perl_threads->mutex);
@@ -2310,7 +2403,7 @@ static int perl_config_loadplugin (pTHX_ oconfig_item_t *ci)
 
 	aTHX = perl_threads->head->interp;
 
-	log_debug ("perl_config: loading perl plugin \"%s\"", value);
+	log_debug ("perl_config: Loading Perl plugin \"%s\"", value);
 	load_module (PERL_LOADMOD_NOIMPORT,
 			newSVpv (module_name, strlen (module_name)), Nullsv);
 	return 0;
@@ -2483,7 +2576,10 @@ static int perl_config (oconfig_item_t *ci)
 		int current_status = 0;
 
 		if (NULL != perl_threads)
-			aTHX = PERL_GET_CONTEXT;
+		{
+			if ((aTHX = PERL_GET_CONTEXT) == NULL)
+				return -1;
+		}
 
 		if (0 == strcasecmp (c->key, "LoadPlugin"))
 			current_status = perl_config_loadplugin (aTHX_ c);