Merge branch 'collectd-4.3' into collectd-4.4
[collectd.git] / src / perl.c
index 889ab56..84dd537 100644 (file)
@@ -1,6 +1,6 @@
 /**
  * collectd - src/perl.c
- * Copyright (C) 2007  Sebastian Harl
+ * Copyright (C) 2007, 2008  Sebastian Harl
  *
  * This program is free software; you can redistribute it and/or modify it
  * under the terms of the GNU General Public License as published by the
 /* do not automatically get the thread specific perl interpreter */
 #define PERL_NO_GET_CONTEXT
 
+#define DONT_POISON_SPRINTF_YET 1
 #include "collectd.h"
+#undef DONT_POISON_SPRINTF_YET
 
 #include "configfile.h"
 
 #include <EXTERN.h>
 #include <perl.h>
 
+#if __GNUC__
+# pragma GCC poison sprintf
+#endif
+
 #include <XSUB.h>
 
 /* Some versions of Perl define their own version of DEBUG... :-/ */
 # error "Perl does not support ithreads!"
 #endif /* !defined(USE_ITHREADS) */
 
+/* clear the Perl sub's stack frame
+ * (this should only be used inside an XSUB) */
+#define CLEAR_STACK_FRAME PL_stack_sp = PL_stack_base + *PL_markstack_ptr
+
 #define PLUGIN_INIT     0
 #define PLUGIN_READ     1
 #define PLUGIN_WRITE    2
 #define PLUGIN_SHUTDOWN 3
 #define PLUGIN_LOG      4
+#define PLUGIN_NOTIF    5
+#define PLUGIN_FLUSH    6
 
-#define PLUGIN_TYPES    5
+#define PLUGIN_TYPES    7
 
 #define PLUGIN_DATASET  255
 
@@ -72,7 +84,11 @@ 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_flush_one);
+static XS (Collectd_plugin_flush_all);
+static XS (Collectd_plugin_dispatch_notification);
 static XS (Collectd_plugin_log);
+static XS (Collectd_call_by_name);
 
 /*
  * private data types
@@ -91,6 +107,11 @@ typedef struct {
        c_ithread_t *head;
        c_ithread_t *tail;
 
+#if COLLECT_DEBUG
+       /* some usage stats */
+       int number_of_threads;
+#endif /* COLLECT_DEBUG */
+
        pthread_mutex_t mutex;
 } c_ithread_list_t;
 
@@ -102,6 +123,9 @@ typedef struct {
  * point to the "base" thread */
 static c_ithread_list_t *perl_threads = NULL;
 
+/* the key used to store each pthread's ithread */
+static pthread_key_t perl_thr_key;
+
 static int    perl_argc = 0;
 static char **perl_argv = NULL;
 
@@ -115,7 +139,12 @@ 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_flush_one",           Collectd_plugin_flush_one },
+       { "Collectd::plugin_flush_all",           Collectd_plugin_flush_all },
+       { "Collectd::plugin_dispatch_notification",
+               Collectd_plugin_dispatch_notification },
        { "Collectd::plugin_log",                 Collectd_plugin_log },
+       { "Collectd::call_by_name",               Collectd_call_by_name },
        { "", NULL }
 };
 
@@ -129,6 +158,8 @@ struct {
        { "Collectd::TYPE_WRITE",      PLUGIN_WRITE },
        { "Collectd::TYPE_SHUTDOWN",   PLUGIN_SHUTDOWN },
        { "Collectd::TYPE_LOG",        PLUGIN_LOG },
+       { "Collectd::TYPE_NOTIF",      PLUGIN_NOTIF },
+       { "Collectd::TYPE_FLUSH",      PLUGIN_FLUSH },
        { "Collectd::TYPE_DATASET",    PLUGIN_DATASET },
        { "Collectd::DS_TYPE_COUNTER", DS_TYPE_COUNTER },
        { "Collectd::DS_TYPE_GAUGE",   DS_TYPE_GAUGE },
@@ -137,9 +168,30 @@ struct {
        { "Collectd::LOG_NOTICE",      LOG_NOTICE },
        { "Collectd::LOG_INFO",        LOG_INFO },
        { "Collectd::LOG_DEBUG",       LOG_DEBUG },
+       { "Collectd::NOTIF_FAILURE",   NOTIF_FAILURE },
+       { "Collectd::NOTIF_WARNING",   NOTIF_WARNING },
+       { "Collectd::NOTIF_OKAY",      NOTIF_OKAY },
        { "", 0 }
 };
 
+struct {
+       char  name[64];
+       char *var;
+} g_strings[] =
+{
+       { "Collectd::hostname_g", hostname_g },
+       { "", NULL }
+};
+
+struct {
+       char  name[64];
+       int  *var;
+} g_integers[] =
+{
+       { "Collectd::interval_g", &interval_g },
+       { "", NULL }
+};
+
 /*
  * Helper functions for data type conversion.
  */
@@ -334,6 +386,43 @@ static int value_list2hv (pTHX_ value_list_t *vl, data_set_t *ds, HV *hash)
        return 0;
 } /* static int value2av (value_list_t *, data_set_t *, HV *) */
 
+static int notification2hv (pTHX_ notification_t *n, HV *hash)
+{
+       if (NULL == hv_store (hash, "severity", 8, newSViv (n->severity), 0))
+               return -1;
+
+       if (0 != n->time)
+               if (NULL == hv_store (hash, "time", 4, newSViv (n->time), 0))
+                       return -1;
+
+       if ('\0' != *n->message)
+               if (NULL == hv_store (hash, "message", 7, newSVpv (n->message, 0), 0))
+                       return -1;
+
+       if ('\0' != *n->host)
+               if (NULL == hv_store (hash, "host", 4, newSVpv (n->host, 0), 0))
+                       return -1;
+
+       if ('\0' != *n->plugin)
+               if (NULL == hv_store (hash, "plugin", 6, newSVpv (n->plugin, 0), 0))
+                       return -1;
+
+       if ('\0' != *n->plugin_instance)
+               if (NULL == hv_store (hash, "plugin_instance", 15,
+                               newSVpv (n->plugin_instance, 0), 0))
+                       return -1;
+
+       if ('\0' != *n->type)
+               if (NULL == hv_store (hash, "type", 4, newSVpv (n->type, 0), 0))
+                       return -1;
+
+       if ('\0' != *n->type_instance)
+               if (NULL == hv_store (hash, "type_instance", 13,
+                               newSVpv (n->type_instance, 0), 0))
+                       return -1;
+       return 0;
+} /* static int notification2hv (notification_t *, HV *) */
+
 /*
  * Internal functions.
  */
@@ -344,7 +433,7 @@ static char *get_module_name (char *buf, size_t buf_len, const char *module) {
                status = snprintf (buf, buf_len, "%s", module);
        else
                status = snprintf (buf, buf_len, "%s::%s", base_name, module);
-       if ((status < 0) || (status >= buf_len))
+       if ((status < 0) || ((unsigned int)status >= buf_len))
                return (NULL);
        buf[buf_len - 1] = '\0';
        return (buf);
@@ -356,6 +445,7 @@ static char *get_module_name (char *buf, size_t buf_len, const char *module) {
 static int pplugin_register_data_set (pTHX_ char *name, AV *dataset)
 {
        int len = -1;
+       int ret = 0;
        int i   = 0;
 
        data_source_t *ds  = NULL;
@@ -396,7 +486,12 @@ static int pplugin_register_data_set (pTHX_ char *name, AV *dataset)
 
        set->ds_num = len + 1;
        set->ds = ds;
-       return plugin_register_data_set (set);
+
+       ret = plugin_register_data_set (set);
+
+       free (ds);
+       free (set);
+       return ret;
 } /* static int pplugin_register_data_set (char *, SV *) */
 
 /*
@@ -470,7 +565,7 @@ static int pplugin_dispatch_values (pTHX_ char *name, HV *values)
                list.host[DATA_MAX_NAME_LEN - 1] = '\0';
        }
        else {
-               strcpy (list.host, hostname_g);
+               sstrncpy (list.host, hostname_g, sizeof (list.host));
        }
 
        if (NULL != (tmp = hv_fetch (values, "plugin", 6, 0))) {
@@ -478,8 +573,7 @@ static int pplugin_dispatch_values (pTHX_ char *name, HV *values)
                list.plugin[DATA_MAX_NAME_LEN - 1] = '\0';
        }
 
-       if (NULL != (tmp = hv_fetch (values,
-                       "plugin_instance", 15, 0))) {
+       if (NULL != (tmp = hv_fetch (values, "plugin_instance", 15, 0))) {
                strncpy (list.plugin_instance, SvPV_nolen (*tmp), DATA_MAX_NAME_LEN);
                list.plugin_instance[DATA_MAX_NAME_LEN - 1] = '\0';
        }
@@ -496,6 +590,71 @@ static int pplugin_dispatch_values (pTHX_ char *name, HV *values)
 } /* static int pplugin_dispatch_values (char *, HV *) */
 
 /*
+ * Dispatch a notification.
+ *
+ * notification:
+ * {
+ *   severity => $severity,
+ *   time     => $time,
+ *   message  => $msg,
+ *   host     => $host,
+ *   plugin   => $plugin,
+ *   type     => $type,
+ *   plugin_instance => $instance,
+ *   type_instance   => $type_instance
+ * }
+ */
+static int pplugin_dispatch_notification (pTHX_ HV *notif)
+{
+       notification_t n;
+
+       SV **tmp = NULL;
+
+       if (NULL == notif)
+               return -1;
+
+       memset (&n, 0, sizeof (n));
+
+       if (NULL != (tmp = hv_fetch (notif, "severity", 8, 0)))
+               n.severity = SvIV (*tmp);
+       else
+               n.severity = NOTIF_FAILURE;
+
+       if (NULL != (tmp = hv_fetch (notif, "time", 4, 0)))
+               n.time = (time_t)SvIV (*tmp);
+       else
+               n.time = time (NULL);
+
+       if (NULL != (tmp = hv_fetch (notif, "message", 7, 0)))
+               strncpy (n.message, SvPV_nolen (*tmp), sizeof (n.message));
+       n.message[sizeof (n.message) - 1] = '\0';
+
+       if (NULL != (tmp = hv_fetch (notif, "host", 4, 0)))
+               strncpy (n.host, SvPV_nolen (*tmp), sizeof (n.host));
+       else
+               strncpy (n.host, hostname_g, sizeof (n.host));
+       n.host[sizeof (n.host) - 1] = '\0';
+
+       if (NULL != (tmp = hv_fetch (notif, "plugin", 6, 0)))
+               strncpy (n.plugin, SvPV_nolen (*tmp), sizeof (n.plugin));
+       n.plugin[sizeof (n.plugin) - 1] = '\0';
+
+       if (NULL != (tmp = hv_fetch (notif, "plugin_instance", 15, 0)))
+               strncpy (n.plugin_instance, SvPV_nolen (*tmp),
+                               sizeof (n.plugin_instance));
+       n.plugin_instance[sizeof (n.plugin_instance) - 1] = '\0';
+
+       if (NULL != (tmp = hv_fetch (notif, "type", 4, 0)))
+               strncpy (n.type, SvPV_nolen (*tmp), sizeof (n.type));
+       n.type[sizeof (n.type) - 1] = '\0';
+
+       if (NULL != (tmp = hv_fetch (notif, "type_instance", 13, 0)))
+               strncpy (n.type_instance, SvPV_nolen (*tmp), sizeof (n.type_instance));
+       n.type_instance[sizeof (n.type_instance) - 1] = '\0';
+       return plugin_dispatch_notification (&n);
+} /* static int pplugin_dispatch_notification (HV *) */
+
+/*
  * Call all working functions of the given type.
  */
 static int pplugin_call_all (pTHX_ int type, ...)
@@ -553,11 +712,19 @@ static int pplugin_call_all (pTHX_ int type, ...)
                ds = va_arg (ap, data_set_t *);
                vl = va_arg (ap, value_list_t *);
 
-               if (-1 == data_set2av (aTHX_ ds, pds))
-                       return -1;
+               if (-1 == data_set2av (aTHX_ ds, pds)) {
+                       av_clear (pds);
+                       av_undef (pds);
+                       pds = Nullav;
+                       ret = -1;
+               }
 
-               if (-1 == value_list2hv (aTHX_ vl, ds, pvl))
-                       return -1;
+               if (-1 == value_list2hv (aTHX_ vl, ds, pvl)) {
+                       hv_clear (pvl);
+                       hv_undef (pvl);
+                       pvl = Nullhv;
+                       ret = -1;
+               }
 
                XPUSHs (sv_2mortal (newSVpv (ds->type, 0)));
                XPUSHs (sv_2mortal (newRV_noinc ((SV *)pds)));
@@ -572,6 +739,40 @@ static int pplugin_call_all (pTHX_ int type, ...)
                XPUSHs (sv_2mortal (newSViv (va_arg (ap, int))));
                XPUSHs (sv_2mortal (newSVpv (va_arg (ap, char *), 0)));
        }
+       else if (PLUGIN_NOTIF == type) {
+               /*
+                * $_[0] =
+                * {
+                *   severity => $severity,
+                *   time     => $time,
+                *   message  => $msg,
+                *   host     => $host,
+                *   plugin   => $plugin,
+                *   type     => $type,
+                *   plugin_instance => $instance,
+                *   type_instance   => $type_instance
+                * };
+                */
+               notification_t *n;
+               HV *notif = newHV ();
+
+               n = va_arg (ap, notification_t *);
+
+               if (-1 == notification2hv (aTHX_ n, notif)) {
+                       hv_clear (notif);
+                       hv_undef (notif);
+                       notif = Nullhv;
+                       ret = -1;
+               }
+
+               XPUSHs (sv_2mortal (newRV_noinc ((SV *)notif)));
+       }
+       else if (PLUGIN_FLUSH == type) {
+               /*
+                * $_[0] = $timeout;
+                */
+               XPUSHs (sv_2mortal (newSViv (va_arg (ap, int))));
+       }
 
        PUTBACK;
 
@@ -656,7 +857,7 @@ static XS (Collectd_plugin_unregister_ds)
        log_debug ("Collectd::plugin_unregister_data_set: type = \"%s\"",
                        SvPV_nolen (ST (0)));
 
-       if (0 == pplugin_unregister_data_set (SvPV_nolen (ST (1))))
+       if (0 == pplugin_unregister_data_set (SvPV_nolen (ST (0))))
                XSRETURN_YES;
        else
                XSRETURN_EMPTY;
@@ -708,6 +909,91 @@ static XS (Collectd_plugin_dispatch_values)
 } /* static XS (Collectd_plugin_dispatch_values) */
 
 /*
+ * Collectd::plugin_flush_one (timeout, name).
+ *
+ * timeout:
+ *   timeout to use when flushing the data
+ *
+ * name:
+ *   name of the plugin to flush
+ */
+static XS (Collectd_plugin_flush_one)
+{
+       dXSARGS;
+
+       if (2 != items) {
+               log_err ("Usage: Collectd::plugin_flush_one(timeout, name)");
+               XSRETURN_EMPTY;
+       }
+
+       log_debug ("Collectd::plugin_flush_one: timeout = %i, name = \"%s\"",
+                       (int)SvIV (ST (0)), SvPV_nolen (ST (1)));
+
+       if (0 == plugin_flush_one ((int)SvIV (ST (0)), SvPV_nolen (ST (1))))
+               XSRETURN_YES;
+       else
+               XSRETURN_EMPTY;
+} /* static XS (Collectd_plugin_flush_one) */
+
+/*
+ * Collectd::plugin_flush_all (timeout).
+ *
+ * timeout:
+ *   timeout to use when flushing the data
+ */
+static XS (Collectd_plugin_flush_all)
+{
+       dXSARGS;
+
+       if (1 != items) {
+               log_err ("Usage: Collectd::plugin_flush_all(timeout)");
+               XSRETURN_EMPTY;
+       }
+
+       log_debug ("Collectd::plugin_flush_all: timeout = %i", (int)SvIV (ST (0)));
+
+       plugin_flush_all ((int)SvIV (ST (0)));
+       XSRETURN_YES;
+} /* static XS (Collectd_plugin_flush_all) */
+
+/*
+ * Collectd::plugin_dispatch_notification (notif).
+ *
+ * notif:
+ *   notification to dispatch
+ */
+static XS (Collectd_plugin_dispatch_notification)
+{
+       SV *notif = NULL;
+
+       int ret = 0;
+
+       dXSARGS;
+
+       if (1 != items) {
+               log_err ("Usage: Collectd::plugin_dispatch_notification(notif)");
+               XSRETURN_EMPTY;
+       }
+
+       log_debug ("Collectd::plugin_dispatch_notification: notif = \"%s\"",
+                       SvPV_nolen (ST (0)));
+
+       notif = ST (0);
+
+       if (! (SvROK (notif) && (SVt_PVHV == SvTYPE (SvRV (notif))))) {
+               log_err ("Collectd::plugin_dispatch_notification: Invalid notif.");
+               XSRETURN_EMPTY;
+       }
+
+       ret = pplugin_dispatch_notification (aTHX_ (HV *)SvRV (notif));
+
+       if (0 == ret)
+               XSRETURN_YES;
+       else
+               XSRETURN_EMPTY;
+} /* static XS (Collectd_plugin_dispatch_notification) */
+
+/*
  * Collectd::plugin_log (level, message).
  *
  * level:
@@ -730,15 +1016,102 @@ static XS (Collectd_plugin_log)
 } /* static XS (Collectd_plugin_log) */
 
 /*
+ * Collectd::call_by_name (...).
+ *
+ * Call a Perl sub identified by its name passed through $Collectd::cb_name.
+ */
+static XS (Collectd_call_by_name)
+{
+       SV   *tmp  = NULL;
+       char *name = NULL;
+
+       if (NULL == (tmp = get_sv ("Collectd::cb_name", 0))) {
+               sv_setpv (get_sv ("@", 1), "cb_name has not been set");
+               CLEAR_STACK_FRAME;
+               return;
+       }
+
+       name = SvPV_nolen (tmp);
+
+       if (NULL == get_cv (name, 0)) {
+               sv_setpvf (get_sv ("@", 1), "unknown callback \"%s\"", name);
+               CLEAR_STACK_FRAME;
+               return;
+       }
+
+       /* simply pass on the subroutine call without touching the stack,
+        * thus leaving any arguments and return values in place */
+       call_pv (name, 0);
+} /* static XS (Collectd_call_by_name) */
+
+/*
  * collectd's perl interpreter based thread implementation.
  *
  * This has been inspired by Perl's ithreads introduced in version 5.6.0.
  */
 
 /* must be called with perl_threads->mutex locked */
+static void c_ithread_destroy (c_ithread_t *ithread)
+{
+       dTHXa (ithread->interp);
+
+       assert (NULL != perl_threads);
+
+       PERL_SET_CONTEXT (aTHX);
+       log_debug ("Shutting down Perl interpreter %p...", aTHX);
+
+#if COLLECT_DEBUG
+       sv_report_used ();
+
+       --perl_threads->number_of_threads;
+#endif /* COLLECT_DEBUG */
+
+       perl_destruct (aTHX);
+       perl_free (aTHX);
+
+       if (NULL == ithread->prev)
+               perl_threads->head = ithread->next;
+       else
+               ithread->prev->next = ithread->next;
+
+       if (NULL == ithread->next)
+               perl_threads->tail = ithread->prev;
+       else
+               ithread->next->prev = ithread->prev;
+
+       sfree (ithread);
+       return;
+} /* static void c_ithread_destroy (c_ithread_t *) */
+
+static void c_ithread_destructor (void *arg)
+{
+       c_ithread_t *ithread = (c_ithread_t *)arg;
+       c_ithread_t *t = NULL;
+
+       if (NULL == perl_threads)
+               return;
+
+       pthread_mutex_lock (&perl_threads->mutex);
+
+       for (t = perl_threads->head; NULL != t; t = t->next)
+               if (t == ithread)
+                       break;
+
+       /* the ithread no longer exists */
+       if (NULL == t)
+               return;
+
+       c_ithread_destroy (ithread);
+
+       pthread_mutex_unlock (&perl_threads->mutex);
+       return;
+} /* static void c_ithread_destructor (void *) */
+
+/* must be called with perl_threads->mutex locked */
 static c_ithread_t *c_ithread_create (PerlInterpreter *base)
 {
        c_ithread_t *t = NULL;
+       dTHXa (NULL);
 
        assert (NULL != perl_threads);
 
@@ -749,6 +1122,18 @@ static c_ithread_t *c_ithread_create (PerlInterpreter *base)
                ? NULL
                : perl_clone (base, CLONEf_KEEP_PTR_TABLE);
 
+       aTHX = t->interp;
+
+       if ((NULL != base) && (NULL != PL_endav)) {
+               av_clear (PL_endav);
+               av_undef (PL_endav);
+               PL_endav = Nullav;
+       }
+
+#if COLLECT_DEBUG
+       ++perl_threads->number_of_threads;
+#endif /* COLLECT_DEBUG */
+
        t->next = NULL;
 
        if (NULL == perl_threads->tail) {
@@ -761,6 +1146,8 @@ static c_ithread_t *c_ithread_create (PerlInterpreter *base)
        }
 
        perl_threads->tail = t;
+
+       pthread_setspecific (perl_thr_key, (const void *)t);
        return t;
 } /* static c_ithread_t *c_ithread_create (PerlInterpreter *) */
 
@@ -784,6 +1171,9 @@ static int perl_init (void)
 
                aTHX = t->interp;
        }
+
+       log_debug ("perl_init: c_ithread: interp = %p (active threads: %i)",
+                       aTHX, perl_threads->number_of_threads);
        return pplugin_call_all (aTHX_ PLUGIN_INIT);
 } /* static int perl_init (void) */
 
@@ -803,6 +1193,9 @@ static int perl_read (void)
 
                aTHX = t->interp;
        }
+
+       log_debug ("perl_read: c_ithread: interp = %p (active threads: %i)",
+                       aTHX, perl_threads->number_of_threads);
        return pplugin_call_all (aTHX_ PLUGIN_READ);
 } /* static int perl_read (void) */
 
@@ -822,6 +1215,9 @@ static int perl_write (const data_set_t *ds, const value_list_t *vl)
 
                aTHX = t->interp;
        }
+
+       log_debug ("perl_write: c_ithread: interp = %p (active threads: %i)",
+                       aTHX, perl_threads->number_of_threads);
        return pplugin_call_all (aTHX_ PLUGIN_WRITE, ds, vl);
 } /* static int perl_write (const data_set_t *, const value_list_t *) */
 
@@ -846,6 +1242,44 @@ static void perl_log (int level, const char *msg)
        return;
 } /* static void perl_log (int, const char *) */
 
+static int perl_notify (const notification_t *notif)
+{
+       dTHX;
+
+       if (NULL == perl_threads)
+               return 0;
+
+       if (NULL == aTHX) {
+               c_ithread_t *t = NULL;
+
+               pthread_mutex_lock (&perl_threads->mutex);
+               t = c_ithread_create (perl_threads->head->interp);
+               pthread_mutex_unlock (&perl_threads->mutex);
+
+               aTHX = t->interp;
+       }
+       return pplugin_call_all (aTHX_ PLUGIN_NOTIF, notif);
+} /* static int perl_notify (const notification_t *) */
+
+static int perl_flush (const int timeout)
+{
+       dTHX;
+
+       if (NULL == perl_threads)
+               return 0;
+
+       if (NULL == aTHX) {
+               c_ithread_t *t = NULL;
+
+               pthread_mutex_lock (&perl_threads->mutex);
+               t = c_ithread_create (perl_threads->head->interp);
+               pthread_mutex_unlock (&perl_threads->mutex);
+
+               aTHX = t->interp;
+       }
+       return pplugin_call_all (aTHX_ PLUGIN_FLUSH, timeout);
+} /* static int perl_flush (const int) */
+
 static int perl_shutdown (void)
 {
        c_ithread_t *t = NULL;
@@ -869,10 +1303,15 @@ static int perl_shutdown (void)
                aTHX = t->interp;
        }
 
+       log_debug ("perl_shutdown: c_ithread: interp = %p (active threads: %i)",
+                       aTHX, perl_threads->number_of_threads);
+
        plugin_unregister_log ("perl");
+       plugin_unregister_notification ("perl");
        plugin_unregister_init ("perl");
        plugin_unregister_read ("perl");
        plugin_unregister_write ("perl");
+       plugin_unregister_flush ("perl");
 
        ret = pplugin_call_all (aTHX_ PLUGIN_SHUTDOWN);
 
@@ -880,35 +1319,72 @@ static int perl_shutdown (void)
        t = perl_threads->tail;
 
        while (NULL != t) {
-               aTHX = t->interp;
-               PERL_SET_CONTEXT (aTHX);
-
-#if COLLECT_DEBUG
-               sv_report_used ();
-#endif /* COLLECT_DEBUG */
-
-               perl_destruct (aTHX);
-               perl_free (aTHX);
+               c_ithread_t *thr = t;
 
+               /* the pointer has to be advanced before destroying
+                * the thread as this will free the memory */
                t = t->prev;
 
-               sfree (t);
+               c_ithread_destroy (thr);
        }
 
        pthread_mutex_unlock (&perl_threads->mutex);
+       pthread_mutex_destroy (&perl_threads->mutex);
 
        sfree (perl_threads);
 
+       pthread_key_delete (perl_thr_key);
+
        PERL_SYS_TERM ();
 
        plugin_unregister_shutdown ("perl");
        return ret;
 } /* static void perl_shutdown (void) */
 
+/*
+ * Access functions for global variables.
+ *
+ * These functions implement the "magic" used to access
+ * the global variables from Perl.
+ */
+
+static int g_pv_get (pTHX_ SV *var, MAGIC *mg)
+{
+       char *pv = mg->mg_ptr;
+       sv_setpv (var, pv);
+       return 0;
+} /* static int g_pv_get (pTHX_ SV *, MAGIC *) */
+
+static int g_pv_set (pTHX_ SV *var, MAGIC *mg)
+{
+       char *pv = mg->mg_ptr;
+       strncpy (pv, SvPV_nolen (var), DATA_MAX_NAME_LEN);
+       pv[DATA_MAX_NAME_LEN - 1] = '\0';
+       return 0;
+} /* static int g_pv_set (pTHX_ SV *, MAGIC *) */
+
+static int g_iv_get (pTHX_ SV *var, MAGIC *mg)
+{
+       int *iv = (int *)mg->mg_ptr;
+       sv_setiv (var, *iv);
+       return 0;
+} /* static int g_iv_get (pTHX_ SV *, MAGIC *) */
+
+static int g_iv_set (pTHX_ SV *var, MAGIC *mg)
+{
+       int *iv = (int *)mg->mg_ptr;
+       *iv = (int)SvIV (var);
+       return 0;
+} /* static int g_iv_set (pTHX_ SV *, MAGIC *) */
+
+static MGVTBL g_pv_vtbl = { g_pv_get, g_pv_set, NULL, NULL, NULL, NULL, NULL };
+static MGVTBL g_iv_vtbl = { g_iv_get, g_iv_set, NULL, NULL, NULL, NULL, NULL };
+
 /* bootstrap the Collectd module */
 static void xs_init (pTHX)
 {
        HV   *stash = NULL;
+       SV   *tmp   = NULL;
        char *file  = __FILE__;
 
        int i = 0;
@@ -927,6 +1403,25 @@ static void xs_init (pTHX)
        /* export "constants" */
        for (i = 0; '\0' != constants[i].name[0]; ++i)
                newCONSTSUB (stash, constants[i].name, newSViv (constants[i].value));
+
+       /* export global variables
+        * by adding "magic" to the SV's representing the globale variables
+        * perl is able to automagically call the get/set function when
+        * accessing any such variable (this is basically the same as using
+        * tie() in Perl) */
+       /* global strings */
+       for (i = 0; '\0' != g_strings[i].name[0]; ++i) {
+               tmp = get_sv (g_strings[i].name, 1);
+               sv_magicext (tmp, NULL, PERL_MAGIC_ext, &g_pv_vtbl,
+                               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);
+       }
        return;
 } /* static void xs_init (pTHX) */
 
@@ -948,6 +1443,18 @@ static int init_pi (int argc, char **argv)
        }
 #endif /* COLLECT_DEBUG */
 
+       if (0 != pthread_key_create (&perl_thr_key, c_ithread_destructor)) {
+               log_err ("init_pi: pthread_key_create failed");
+
+               /* this must not happen - cowardly giving up if it does */
+               return -1;
+       }
+
+#ifdef __FreeBSD__
+       /* On FreeBSD, PERL_SYS_INIT3 expands to some expression which
+        * triggers a "value computed is not used" warning by gcc. */
+       (void)
+#endif
        PERL_SYS_INIT3 (&argc, &argv, &environ);
 
        perl_threads = (c_ithread_list_t *)smalloc (sizeof (c_ithread_list_t));
@@ -962,7 +1469,7 @@ static int init_pi (int argc, char **argv)
        perl_threads->tail = perl_threads->head;
 
        if (NULL == (perl_threads->head->interp = perl_alloc ())) {
-               log_err ("module_register: Not enough memory.");
+               log_err ("init_pi: Not enough memory.");
                exit (3);
        }
 
@@ -974,8 +1481,14 @@ static int init_pi (int argc, char **argv)
        PL_exit_flags |= PERL_EXIT_DESTRUCT_END;
 
        if (0 != perl_parse (aTHX_ xs_init, argc, argv, NULL)) {
-               log_err ("module_register: Unable to bootstrap Collectd.");
-               exit (1);
+               log_err ("init_pi: Unable to bootstrap Collectd.");
+
+               perl_destruct (perl_threads->head->interp);
+               perl_free (perl_threads->head->interp);
+               sfree (perl_threads);
+
+               pthread_key_delete (perl_thr_key);
+               return -1;
        }
 
        /* Set $0 to "collectd" because perl_parse() has to set it to "-e". */
@@ -984,11 +1497,13 @@ static int init_pi (int argc, char **argv)
        perl_run (aTHX);
 
        plugin_register_log ("perl", perl_log);
+       plugin_register_notification ("perl", perl_notify);
        plugin_register_init ("perl", perl_init);
 
        plugin_register_read ("perl", perl_read);
 
        plugin_register_write ("perl", perl_write);
+       plugin_register_flush ("perl", perl_flush);
        plugin_register_shutdown ("perl", perl_shutdown);
        return 0;
 } /* static int init_pi (const char **, const int) */
@@ -1003,8 +1518,10 @@ static int perl_config_loadplugin (pTHX_ oconfig_item_t *ci)
        char *value = NULL;
 
        if ((0 != ci->children_num) || (1 != ci->values_num)
-                       || (OCONFIG_TYPE_STRING != ci->values[0].type))
+                       || (OCONFIG_TYPE_STRING != ci->values[0].type)) {
+               log_err ("LoadPlugin expects a single string argument.");
                return 1;
+       }
 
        value = ci->values[0].value.string;
 
@@ -1013,7 +1530,9 @@ static int perl_config_loadplugin (pTHX_ oconfig_item_t *ci)
                return (1);
        }
 
-       init_pi (perl_argc, perl_argv);
+       if (0 != init_pi (perl_argc, perl_argv))
+               return -1;
+
        assert (NULL != perl_threads);
        assert (NULL != perl_threads->head);
 
@@ -1033,8 +1552,10 @@ static int perl_config_basename (pTHX_ oconfig_item_t *ci)
        char *value = NULL;
 
        if ((0 != ci->children_num) || (1 != ci->values_num)
-                       || (OCONFIG_TYPE_STRING != ci->values[0].type))
+                       || (OCONFIG_TYPE_STRING != ci->values[0].type)) {
+               log_err ("BaseName expects a single string argument.");
                return 1;
+       }
 
        value = ci->values[0].value.string;
 
@@ -1052,8 +1573,15 @@ static int perl_config_enabledebugger (pTHX_ oconfig_item_t *ci)
        char *value = NULL;
 
        if ((0 != ci->children_num) || (1 != ci->values_num)
-                       || (OCONFIG_TYPE_STRING != ci->values[0].type))
+                       || (OCONFIG_TYPE_STRING != ci->values[0].type)) {
+               log_err ("EnableDebugger expects a single string argument.");
                return 1;
+       }
+
+       if (NULL != perl_threads) {
+               log_warn ("EnableDebugger has no effects if used after LoadPlugin.");
+               return 1;
+       }
 
        value = ci->values[0].value.string;
 
@@ -1086,8 +1614,10 @@ static int perl_config_includedir (pTHX_ oconfig_item_t *ci)
        char *value = NULL;
 
        if ((0 != ci->children_num) || (1 != ci->values_num)
-                       || (OCONFIG_TYPE_STRING != ci->values[0].type))
+                       || (OCONFIG_TYPE_STRING != ci->values[0].type)) {
+               log_err ("IncludeDir expects a single string argument.");
                return 1;
+       }
 
        value = ci->values[0].value.string;
 
@@ -1118,16 +1648,14 @@ static int perl_config (oconfig_item_t *ci)
 {
        int i = 0;
 
-       dTHX;
-
-       /* dTHX does not get any valid values in case Perl
-        * has not been initialized */
-       if (NULL == perl_threads)
-               aTHX = NULL;
+       dTHXa (NULL);
 
        for (i = 0; i < ci->children_num; ++i) {
                oconfig_item_t *c = ci->children + i;
 
+               if (NULL != perl_threads)
+                       aTHX = PERL_GET_CONTEXT;
+
                if (0 == strcasecmp (c->key, "LoadPlugin"))
                        perl_config_loadplugin (aTHX_ c);
                else if (0 == strcasecmp (c->key, "BaseName"))