perl plugin: Added a plugin to embed a Perl interpreter into collectd.

This is the long awaited plugin that makes it possible to write plugins in
plain Perl. This is my first glance at using Perl's C API, so I'm pretty sure
there are some things that could habe been done better. Much of the plugin
could have been written in Perl as well, but I decided not to do so mainly for
exercise reasons ;-)

This plugin still needs a lot of testing. Also comments on the API, code, etc.
are very welcome.

Basically, the plugin is just the glue that's required for Perl plugins to
access collectd's internals. The following API is currently available:

Collectd::plugin_register:
  register working functions or data sets with collectd

  arguments:
  type - type of the registered data
  name - name of the plugin
  data - reference to the plugin's working subroutine or the data set

Collectd::plugin_unregister:
  unregister working functions or data sets from collectd

  arguments:
  type - type of the data to be unregistered
  name - name of the plugin

Collectd::plugin_dispatch_values:
  dispatch the collected values to the write functions

  arguments:
  name - name of the plugin
  values - list of values to submit

The plugin type may be any of the following:
  Collectd::TYPE_INIT
  Collectd::TYPE_READ
  Collectd::TYPE_WRITE
  Collectd::TYPE_LOG
  Collectd::TYPE_SHUTDOWN
  Collectd::TYPE_DATASET

A data set is represented as a reference to an array containing hashes with the
following elements:
  name => $ds_name (required)
  type => $ds_type (default: COUNTER)
  min  => $ds_min (default: NAN)
  max  => $ds_max (default: NAN)

A value list is represented as a reference to a hash with the following
elements:
  values => [ @values ] (required)
  time   => $time (default: time(NULL))
  host   => $hostname (default: hostname_g)
  plugin => $plugin (default: "")
  plugin_instance => $plugin_instance (default: "")
  type_instance   => $type_instance (default: "")

The default value is used whenever the element is not defined.

Three arguments are passed to write functions: the plugin's type, the plugin's
data set and the value list.

Two arguments are passed to log functions: the log level and the log message.

In case a function returns false (as interpreted by Perl) the following actions
are taken depending on the function type:
  read: the function will be disabled for an increasing amount of time
  init: the plugin will be disabled completely
  anything else: a warning is logged

In addition to the ones listed above the following constants are also exported:
  Collectd::DS_TYPE_COUNTER
  Collectd::DS_TYPE_GAUGE
  Collectd::LOG_ERR
  Collectd::LOG_WARNING
  Collectd::LOG_NOTICE
  Collectd::LOG_INFO
  Collectd::LOG_DEBUG

There is no need to load any Collectd modules - everything is completely
integrated into collectd.

TODO:
  add support for accessing the config file
  write documentation
  add checks for perl to configure

Signed-off-by: Sebastian Harl <sh@tokkee.org>

diff --git a/AUTHORS b/AUTHORS
index 253910807de979a30f328e65ca622450ef1ca493..0c1b3225868db4d32fa85a9f7d17be50760f8af2 100644 (file)
--- a/AUTHORS
+++ b/AUTHORS
@@ -19,6 +19,9 @@ mbmon plugin by:
 nfs module by:
   Jason Pepas <cell at ices.utexas.edu>
 
+perl module by:
+  Sebastian Harl <sh at tokkee.org>
+
 processes module by:
   Lyonel Vincent <lyonel at ezix.org>
 

diff --git a/configure.in b/configure.in
index 7a21b077da17a7d7210ed9535b27a915bf2a95dc..ebbf8a761dba07d3312e04e3a6f2e4e00c658d8a 100644 (file)
--- a/configure.in
+++ b/configure.in
@@ -1237,6 +1237,7 @@ AC_COLLECTD([network],   [disable], [module], [network functionality])
 AC_COLLECTD([nfs],       [disable], [module], [nfs statistics])
 AC_COLLECTD([ntpd],      [disable], [module], [ntpd statistics])
 AC_COLLECTD([nut],       [disable], [module], [network UPS tools statistics])
+AC_COLLECTD([perl],      [disable], [module], [embedded perl interpreter])
 AC_COLLECTD([ping],      [disable], [module], [ping statistics])
 AC_COLLECTD([processes], [disable], [module], [processes statistics])
 AC_COLLECTD([sensors],   [disable], [module], [lm_sensors statistics])
@@ -1301,6 +1302,7 @@ Configuration:
     nfs . . . . . . . . $enable_nfs
     ntpd  . . . . . . . $enable_ntpd
     nut . . . . . . . . $enable_nut
+    perl  . . . . . . . $enable_perl
     ping  . . . . . . . $enable_ping
     processes . . . . . $enable_processes
     sensors . . . . . . $enable_sensors

diff --git a/src/Makefile.am b/src/Makefile.am
index 23d82aa5e563f57ddd0a1ebac1d255f11941a389..01673e0eb33de5e368c475c2fb0f16c6ebf57054 100644 (file)
--- a/src/Makefile.am
+++ b/src/Makefile.am
@@ -396,6 +396,18 @@ collectd_LDADD += "-dlopen" nut.la
 collectd_DEPENDENCIES += nut.la
 endif
 
+if BUILD_MODULE_PERL
+pkglib_LTLIBRARIES += perl.la
+perl_la_SOURCES = perl.c
+perl_la_CFLAGS  = $(AM_CFLAGS) \
+                 $(shell perl -MExtUtils::Embed -e ccopts) \
+                 -DXS_VERSION=\"$(VERSION)\" -DVERSION=\"$(VERSION)\"
+perl_la_LDFLAGS = -module -avoid-version \
+                 $(shell perl -MExtUtils::Embed -e ldopts)
+collectd_LDADD += "-dlopen" perl.la
+collectd_DEPENDENCIES += perl.la
+endif
+
 if BUILD_MODULE_PING
 pkglib_LTLIBRARIES += ping.la
 ping_la_SOURCES = ping.c

diff --git a/src/collectd.conf.in b/src/collectd.conf.in
index 020bdebed534ed9d6186d62562c5e90269bd2e32..3aa1306587edbbb9ef25b6a863db1a03f8319560 100644 (file)
--- a/src/collectd.conf.in
+++ b/src/collectd.conf.in
@@ -37,6 +37,7 @@
 @BUILD_MODULE_NFS_TRUE@LoadPlugin nfs
 @BUILD_MODULE_NTPD_TRUE@LoadPlugin ntpd
 @BUILD_MODULE_NUT_TRUE@LoadPlugin nut
+@BUILD_MODULE_PERL_TRUE@LoadPlugin perl
 @BUILD_MODULE_PING_TRUE@LoadPlugin ping
 @BUILD_MODULE_PROCESSES_TRUE@LoadPlugin processes
 @BUILD_WITH_RRDTOOL_TRUE@LoadPlugin rrdtool
@@ -146,6 +147,10 @@
 #      UPS "upsname@hostname:port"
 #</Plugin>
 
+#<Plugin perl>
+#      LoadPlugin foo
+#</Plugin>
+
 #<Plugin ping>
 #      Host "host.foo.bar"
 #</Plugin>

diff --git a/src/perl.c b/src/perl.c
new file mode 100644 (file)
index 0000000..0c5e882
--- /dev/null
+++ b/src/perl.c
@@ -0,0 +1,1055 @@
+/**
+ * collectd - src/perl.c
+ * Copyright (C) 2007  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
+ * Free Software Foundation; only version 2 of the License is applicable.
+ *
+ * This program is distributed in the hope that it will be useful, but
+ * WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+ * General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License along
+ * with this program; if not, write to the Free Software Foundation, Inc.,
+ * 51 Franklin St, Fifth Floor, Boston, MA  02110-1301 USA
+ *
+ * Author:
+ *   Sebastian Harl <sh at tokkee.org>
+ **/
+
+/*
+ * This plugin embeds a Perl interpreter into collectd and provides an
+ * interface for collectd plugins written in perl.
+ */
+
+#include "collectd.h"
+#include "common.h"
+#include "plugin.h"
+
+#include "configfile.h"
+
+#include <EXTERN.h>
+#include <perl.h>
+
+#include <XSUB.h>
+
+#define PLUGIN_INIT     0
+#define PLUGIN_READ     1
+#define PLUGIN_WRITE    2
+#define PLUGIN_SHUTDOWN 3
+#define PLUGIN_LOG      4
+
+#define PLUGIN_TYPES    5
+
+#define PLUGIN_DATASET  255
+
+#define log_debug(...) DEBUG ("perl: " __VA_ARGS__)
+#define log_warn(...) WARNING ("perl: " __VA_ARGS__)
+#define log_err(...) ERROR ("perl: " __VA_ARGS__)
+
+
+/* this is defined in DynaLoader.a */
+void boot_DynaLoader (PerlInterpreter *, CV *);
+
+static XS (Collectd_plugin_register);
+static XS (Collectd_plugin_unregister);
+static XS (Collectd_plugin_dispatch_values);
+
+
+/*
+ * private data types
+ */
+
+typedef struct {
+       int len;
+       int *values;
+} ds_types_t;
+
+typedef struct {
+       int wait_time;
+       int wait_left;
+
+       SV  *sub;
+} pplugin_t;
+
+
+/*
+ * private variables
+ */
+
+/* valid configuration file keys */
+static const char *config_keys[] =
+{
+       "LoadPlugin",
+       NULL
+};
+static int config_keys_num = 1;
+
+static PerlInterpreter *perl = NULL;
+
+static char *plugin_types[] = { "init", "read", "write", "shutdown" };
+static HV   *plugins[PLUGIN_TYPES];
+static HV   *data_sets;
+
+static struct {
+       char name[64];
+       XS ((*f));
+} api[] =
+{
+       { "Collectd::plugin_register",        Collectd_plugin_register },
+       { "Collectd::plugin_unregister",      Collectd_plugin_unregister },
+       { "Collectd::plugin_dispatch_values", Collectd_plugin_dispatch_values },
+       { "", NULL }
+};
+
+
+/*
+ * Helper functions for data type conversion.
+ */
+
+/*
+ * data source:
+ * [
+ *   {
+ *     name => $ds_name,
+ *     type => $ds_type,
+ *     min  => $ds_min,
+ *     max  => $ds_max
+ *   },
+ *   ...
+ * ]
+ */
+static int hv2data_source (HV *hash, data_source_t *ds)
+{
+       SV **tmp = NULL;
+
+       if ((NULL == hash) || (NULL == ds))
+               return -1;
+
+       if (NULL != (tmp = Perl_hv_fetch (perl, hash, "name", 4, 0))) {
+               strncpy (ds->name, SvPV_nolen (*tmp), DATA_MAX_NAME_LEN);
+               ds->name[DATA_MAX_NAME_LEN - 1] = '\0';
+       }
+       else {
+               log_err ("hv2data_source: No DS name given.");
+               return -1;
+       }
+
+       if (NULL != (tmp = Perl_hv_fetch (perl, hash, "type", 4, 0))) {
+               ds->type = SvIV (*tmp);
+
+               if ((DS_TYPE_COUNTER != ds->type) && (DS_TYPE_GAUGE != ds->type)) {
+                       log_err ("hv2data_source: Invalid DS type.");
+                       return -1;
+               }
+       }
+       else {
+               ds->type = DS_TYPE_COUNTER;
+       }
+
+       if (NULL != (tmp = Perl_hv_fetch (perl, hash, "min", 3, 0)))
+               ds->min = SvNV (*tmp);
+       else
+               ds->min = NAN;
+
+       if (NULL != (tmp = Perl_hv_fetch (perl, hash, "max", 3, 0)))
+               ds->max = SvNV (*tmp);
+       else
+               ds->max = NAN;
+       return 0;
+} /* static data_source_t *hv2data_source (HV *) */
+
+static int av2value (char *name, AV *array, value_t *value, int len)
+{
+       SV **tmp = NULL;
+
+       ds_types_t *ds = NULL;
+
+       int i = 0;
+
+       if ((NULL == name) || (NULL == array) || (NULL == value))
+               return -1;
+
+       if (Perl_av_len (perl, array) < len - 1)
+               len = Perl_av_len (perl, array) + 1;
+
+       if (0 >= len)
+               return -1;
+
+       tmp = Perl_hv_fetch (perl, data_sets, name, strlen (name), 0);
+       if (NULL == tmp) {
+               log_err ("av2value: No dataset for \"%s\".", name);
+               return -1;
+       }
+       ds = (ds_types_t *)SvIV ((SV *)SvRV (*tmp));
+
+       if (ds->len < len) {
+               log_warn ("av2value: Value length exceeds data set length.");
+               len = ds->len;
+       }
+
+       for (i = 0; i < len; ++i) {
+               SV **tmp = Perl_av_fetch (perl, array, i, 0);
+
+               if (NULL != tmp) {
+                       if (DS_TYPE_COUNTER == ds->values[i])
+                               value[i].counter = SvIV (*tmp);
+                       else
+                               value[i].gauge = SvNV (*tmp);
+               }
+               else {
+                       return -1;
+               }
+       }
+       return len;
+} /* static int av2value (char *, AV *, value_t *, int) */
+
+static int data_set2av (data_set_t *ds, AV *array)
+{
+       int i = 0;
+
+       if ((NULL == ds) || (NULL == array))
+               return -1;
+
+       Perl_av_extend (perl, array, ds->ds_num);
+
+       for (i = 0; i < ds->ds_num; ++i) {
+               HV *source = Perl_newHV (perl);
+
+               if (NULL == Perl_hv_store (perl, source, "name", 4,
+                               Perl_newSVpv (perl, ds->ds[i].name, 0), 0))
+                       return -1;
+
+               if (NULL == Perl_hv_store (perl, source, "type", 4,
+                               Perl_newSViv (perl, ds->ds[i].type), 0))
+                       return -1;
+
+               if (! isnan (ds->ds[i].min))
+                       if (NULL == Perl_hv_store (perl, source, "min", 3,
+                                       Perl_newSVnv (perl, ds->ds[i].min), 0))
+                               return -1;
+
+               if (! isnan (ds->ds[i].max))
+                       if (NULL == Perl_hv_store (perl, source, "max", 3,
+                                       Perl_newSVnv (perl, ds->ds[i].max), 0))
+                               return -1;
+
+               if (NULL == Perl_av_store (perl, array, i,
+                               Perl_newRV_noinc (perl, (SV *)source)))
+                       return -1;
+       }
+       return 0;
+} /* static int data_set2av (data_set_t *, AV *) */
+
+static int value_list2hv (value_list_t *vl, data_set_t *ds, HV *hash)
+{
+       AV *values = NULL;
+
+       int i   = 0;
+       int len = 0;
+
+       if ((NULL == vl) || (NULL == ds) || (NULL == hash))
+               return -1;
+
+       len = vl->values_len;
+
+       if (ds->ds_num < len) {
+               log_warn ("value2av: Value length exceeds data set length.");
+               len = ds->ds_num;
+       }
+
+       values = Perl_newAV (perl);
+       Perl_av_extend (perl, values, len - 1);
+
+       for (i = 0; i < len; ++i) {
+               SV *val = NULL;
+
+               if (DS_TYPE_COUNTER == ds->ds[i].type)
+                       val = Perl_newSViv (perl, vl->values[i].counter);
+               else
+                       val = Perl_newSVnv (perl, vl->values[i].gauge);
+
+               if (NULL == Perl_av_store (perl, values, i, val)) {
+                       Perl_av_undef (perl, values);
+                       return -1;
+               }
+       }
+
+       if (NULL == Perl_hv_store (perl, hash, "values", 6,
+                       Perl_newRV_noinc (perl, (SV *)values), 0))
+               return -1;
+
+       if (0 != vl->time)
+               if (NULL == Perl_hv_store (perl, hash, "time", 4,
+                               Perl_newSViv (perl, vl->time), 0))
+                       return -1;
+
+       if ('\0' != vl->host[0])
+               if (NULL == Perl_hv_store (perl, hash, "host", 4,
+                               Perl_newSVpv (perl, vl->host, 0), 0))
+                       return -1;
+
+       if ('\0' != vl->plugin[0])
+               if (NULL == Perl_hv_store (perl, hash, "plugin", 6,
+                               Perl_newSVpv (perl, vl->plugin, 0), 0))
+                       return -1;
+
+       if ('\0' != vl->plugin_instance[0])
+               if (NULL == Perl_hv_store (perl, hash, "plugin_instance", 15,
+                               Perl_newSVpv (perl, vl->plugin_instance, 0), 0))
+                       return -1;
+
+       if ('\0' != vl->type_instance[0])
+               if (NULL == Perl_hv_store (perl, hash, "type_instance", 13,
+                               Perl_newSVpv (perl, vl->type_instance, 0), 0))
+                       return -1;
+       return 0;
+} /* static int value2av (value_list_t *, data_set_t *, HV *) */
+
+
+/*
+ * Internal functions.
+ */
+
+/*
+ * Add a new plugin with the given name.
+ */
+static int pplugin_register (int type, const char *name, SV *sub)
+{
+       pplugin_t *p = NULL;
+
+       if ((type < 0) || (type >= PLUGIN_TYPES))
+               return -1;
+
+       if (NULL == name)
+               return -1;
+
+       p = (pplugin_t *)smalloc (sizeof (pplugin_t));
+       /* this happens during parsing of config file,
+        * thus interval_g is not set correctly */
+       p->wait_time = 10;
+       p->wait_left = 0;
+       p->sub = Perl_newSVsv (perl, sub);
+
+       if (NULL == Perl_hv_store (perl, plugins[type], name, strlen (name),
+                               Perl_sv_setref_pv (perl, Perl_newSV (perl, 0), 0, p), 0)) {
+               log_debug ("pplugin_register: Failed to add plugin \"%s\" (\"%s\")",
+                               name, SvPV_nolen (sub));
+               Perl_sv_free (perl, p->sub);
+               sfree (p);
+               return -1;
+       }
+       return 0;
+} /* static int pplugin_register (int, char *, SV *) */
+
+/*
+ * Removes the plugin with the given name and frees any ressources.
+ */
+static int pplugin_unregister (int type, char *name)
+{
+       SV *tmp = NULL;
+
+       if ((type < 0) || (type >= PLUGIN_TYPES))
+               return -1;
+
+       if (NULL == name)
+               return -1;
+
+       /* freeing the allocated memory of the element itself (pplugin_t *) causes
+        * a segfault during perl_destruct () thus I assume perl somehow takes
+        * care of this... */
+
+       tmp = Perl_hv_delete (perl, plugins[type], name, strlen (name), 0);
+       if (NULL != tmp) {
+               pplugin_t *p = (pplugin_t *)SvIV ((SV *)SvRV (tmp));
+               Perl_sv_free (perl, p->sub);
+       }
+       return 0;
+} /* static int pplugin_unregister (char *) */
+
+/*
+ * Add a plugin's data set definition.
+ */
+static int pplugin_register_data_set (char *name, AV *dataset)
+{
+       int len = -1;
+       int i   = 0;
+
+       data_source_t *ds  = NULL;
+       data_set_t    *set = NULL;
+
+       ds_types_t *types = NULL;
+
+       if ((NULL == name) || (NULL == dataset))
+               return -1;
+
+       len = Perl_av_len (perl, dataset);
+
+       if (-1 == len)
+               return -1;
+
+       ds  = (data_source_t *)smalloc ((len + 1) * sizeof (data_source_t));
+       set = (data_set_t *)smalloc (sizeof (data_set_t));
+
+       types = (ds_types_t *)smalloc (sizeof (ds_types_t));
+       types->len = len + 1;
+       types->values = (int *)smalloc ((types->len) * sizeof (int));
+
+       for (i = 0; i <= len; ++i) {
+               SV **elem = Perl_av_fetch (perl, dataset, i, 0);
+
+               if (NULL == elem)
+                       return -1;
+
+               if (! (SvROK (*elem) && (SVt_PVHV == SvTYPE (SvRV (*elem))))) {
+                       log_err ("pplugin_register_data_set: Invalid data source.");
+                       return -1;
+               }
+
+               if (-1 == hv2data_source ((HV *)SvRV (*elem), &ds[i]))
+                       return -1;
+
+               types->values[i] = ds[i].type;
+               log_debug ("pplugin_register_data_set: "
+                               "DS.name = \"%s\", DS.type = %i, DS.min = %f, DS.max = %f",
+                               ds[i].name, ds[i].type, ds[i].min, ds[i].max);
+       }
+
+       if (NULL == Perl_hv_store (perl, data_sets, name, strlen (name),
+                       Perl_sv_setref_pv (perl, Perl_newSV (perl, 0), 0, types), 0))
+               return -1;
+
+       strncpy (set->type, name, DATA_MAX_NAME_LEN);
+       set->type[DATA_MAX_NAME_LEN - 1] = '\0';
+
+       set->ds_num = len + 1;
+       set->ds = ds;
+       return plugin_register_data_set (set);
+} /* static int pplugin_register_data_set (char *, SV *) */
+
+/*
+ * Remove a plugin's data set definition.
+ */
+static int pplugin_unregister_data_set (char *name)
+{
+       SV *tmp = NULL;
+
+       if (NULL == name)
+               return 0;
+
+       /* freeing the allocated memory of the element itself (ds_types_t *)
+        * causes a segfault during perl_destruct () thus I assume perl somehow
+        * takes care of this... */
+
+       tmp = Perl_hv_delete (perl, data_sets, name, strlen (name), 0);
+       if (NULL != tmp) {
+               ds_types_t *ds = (ds_types_t *)SvIV ((SV *)SvRV (tmp));
+               sfree (ds->values);
+       }
+       return plugin_unregister_data_set (name);
+} /* static int pplugin_unregister_data_set (char *) */
+
+/*
+ * Submit the values to the write functions.
+ *
+ * value list:
+ * {
+ *   values => [ @values ],
+ *   time   => $time,
+ *   host   => $host,
+ *   plugin => $plugin,
+ *   plugin_instance => $pinstance,
+ *   type_instance   => $tinstance,
+ * }
+ */
+static int pplugin_dispatch_values (char *name, HV *values)
+{
+       value_list_t list = VALUE_LIST_INIT;
+       value_t      *val = NULL;
+
+       SV **tmp = NULL;
+
+       int ret = 0;
+
+       if ((NULL == name) || (NULL == values))
+               return -1;
+
+       if ((NULL == (tmp = Perl_hv_fetch (perl, values, "values", 6, 0)))
+                       || (! (SvROK (*tmp) && (SVt_PVAV == SvTYPE (SvRV (*tmp)))))) {
+               log_err ("pplugin_dispatch_values: No valid values given.");
+               return -1;
+       }
+
+       {
+               AV  *array = (AV *)SvRV (*tmp);
+               int len    = Perl_av_len (perl, array) + 1;
+
+               val = (value_t *)smalloc (len * sizeof (value_t));
+
+               list.values_len = av2value (name, (AV *)SvRV (*tmp), val, len);
+               list.values = val;
+
+               if (-1 == list.values_len) {
+                       sfree (val);
+                       return -1;
+               }
+       }
+
+       if (NULL != (tmp = Perl_hv_fetch (perl, values, "time", 4, 0))) {
+               list.time = (time_t)SvIV (*tmp);
+       }
+       else {
+               list.time = time (NULL);
+       }
+
+       if (NULL != (tmp = Perl_hv_fetch (perl, values, "host", 4, 0))) {
+               strncpy (list.host, SvPV_nolen (*tmp), DATA_MAX_NAME_LEN);
+       }
+       else {
+               strcpy (list.host, hostname_g);
+       }
+
+       if (NULL != (tmp = Perl_hv_fetch (perl, values, "plugin", 6, 0))) {
+               strncpy (list.plugin, SvPV_nolen (*tmp), DATA_MAX_NAME_LEN);
+               list.plugin[DATA_MAX_NAME_LEN - 1] = '\0';
+       }
+
+       if (NULL != (tmp = Perl_hv_fetch (perl, 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';
+       }
+
+       if (NULL != (tmp = Perl_hv_fetch (perl, values, "type_instance", 13, 0))) {
+               strncpy (list.type_instance, SvPV_nolen (*tmp), DATA_MAX_NAME_LEN);
+               list.type_instance[DATA_MAX_NAME_LEN - 1] = '\0';
+       }
+
+       ret = plugin_dispatch_values (name, &list);
+
+       sfree (val);
+       return ret;
+} /* static int pplugin_dispatch_values (char *, HV *) */
+
+/*
+ * Call a plugin's working function.
+ */
+static int pplugin_call (int type, char *name, SV *sub, va_list ap)
+{
+       int retvals = 0;
+       I32 xflags  = G_NOARGS;
+
+       int ret = 0;
+
+       dSP;
+
+       if ((type < 0) || (type >= PLUGIN_TYPES))
+               return -1;
+
+       ENTER;
+       SAVETMPS;
+
+       PUSHMARK (SP);
+
+       if (PLUGIN_WRITE == type) {
+               /*
+                * $_[0] = $plugin_type;
+                *
+                * $_[1] =
+                * [
+                *   {
+                *     name => $ds_name,
+                *     type => $ds_type,
+                *     min  => $ds_min,
+                *     max  => $ds_max
+                *   },
+                *   ...
+                * ];
+                *
+                * $_[2] =
+                * {
+                *   values => [ $v1, ... ],
+                *   time   => $time,
+                *   host   => $hostname,
+                *   plugin => $plugin,
+                *   plugin_instance => $instance,
+                *   type_instance   => $type_instance
+                * };
+                */
+               data_set_t   *ds;
+               value_list_t *vl;
+
+               AV *pds = Perl_newAV (perl);
+               HV *pvl = Perl_newHV (perl);
+
+               ds = va_arg (ap, data_set_t *);
+               vl = va_arg (ap, value_list_t *);
+
+               if (-1 == data_set2av (ds, pds))
+                       return -1;
+
+               if (-1 == value_list2hv (vl, ds, pvl))
+                       return -1;
+
+               XPUSHs (sv_2mortal (Perl_newSVpv (perl, ds->type, 0)));
+               XPUSHs (sv_2mortal (Perl_newRV_noinc (perl, (SV *)pds)));
+               XPUSHs (sv_2mortal (Perl_newRV_noinc (perl, (SV *)pvl)));
+
+               xflags = 0;
+       }
+       else if (PLUGIN_LOG == type) {
+               /*
+                * $_[0] = $level;
+                *
+                * $_[1] = $message;
+                */
+               XPUSHs (sv_2mortal (Perl_newSViv (perl, va_arg (ap, int))));
+               XPUSHs (sv_2mortal (Perl_newSVpv (perl, va_arg (ap, char *), 0)));
+
+               xflags = 0;
+       }
+
+       PUTBACK;
+
+       /* prevent an endless loop */
+       if (PLUGIN_LOG != type)
+               log_debug ("pplugin_call: executing Collectd::plugin::%s->%s()",
+                               name, plugin_types[type]);
+
+       retvals = Perl_call_sv (perl, sub, G_SCALAR | xflags);
+
+       SPAGAIN;
+       if (1 > retvals) {
+               if (PLUGIN_LOG != type)
+                       log_warn ("pplugin_call: "
+                                       "Collectd::plugin::%s->%s() returned void - assuming true",
+                                       name, plugin_types[type]);
+       }
+       else {
+               SV *tmp = POPs;
+               if (! SvTRUE (tmp))
+                       ret = -1;
+       }
+
+       PUTBACK;
+       FREETMPS;
+       LEAVE;
+       return ret;
+} /* static int pplugin_call (int, char *, SV *, va_list) */
+
+/*
+ * Call all working functions of the given type.
+ */
+static int pplugin_call_all (int type, ...)
+{
+       SV *tmp = NULL;
+
+       char *plugin;
+       I32  len;
+
+       if ((type < 0) || (type >= PLUGIN_TYPES))
+               return -1;
+
+       if (0 == Perl_hv_iterinit (perl, plugins[type]))
+               return 0;
+
+       while (NULL != (tmp = Perl_hv_iternextsv (perl, plugins[type],
+                       &plugin, &len))) {
+               pplugin_t *p;
+               va_list   ap;
+
+               int status;
+
+               va_start (ap, type);
+
+               p = (pplugin_t *)SvIV ((SV *)SvRV (tmp));
+
+               if (p->wait_left > 0)
+                       p->wait_left -= interval_g;
+
+               if (p->wait_left > 0)
+                       continue;
+
+               if (0 == (status = pplugin_call (type, plugin, p->sub, ap))) {
+                       p->wait_left = 0;
+                       p->wait_time = interval_g;
+               }
+               else if (PLUGIN_READ == type) {
+                       p->wait_left = p->wait_time;
+                       p->wait_time <<= 1;
+
+                       if (p->wait_time > 86400)
+                               p->wait_time = 86400;
+
+                       log_warn ("Collectd::plugin::%s->read() failed. "
+                                       "Will suspend it for %i seconds.",
+                                       plugin, p->wait_left);
+               }
+               else if (PLUGIN_INIT == type) {
+                       int i = 0;
+
+                       log_err ("Collectd::plugin::%s->init() failed. "
+                                       "Plugin will be disabled.", plugin, status);
+
+                       for (i = 0; i < PLUGIN_TYPES; ++i)
+                               pplugin_unregister (i, plugin);
+               }
+               else if (PLUGIN_LOG != type) {
+                       log_warn ("Collectd::plugin::%s->%s() failed with status %i.",
+                                       plugin, plugin_types[type], status);
+               }
+
+               va_end (ap);
+       }
+       return 0;
+} /* static int pplugin_call_all (int, ...) */
+
+
+/*
+ * Exported Perl API.
+ */
+
+/*
+ * Collectd::plugin_register (type, name, data).
+ *
+ * type:
+ *   init, read, write, shutdown, data set
+ *
+ * name:
+ *   name of the plugin
+ *
+ * data:
+ *   reference to the plugin's subroutine that does the work or the data set
+ *   definition
+ */
+static XS (Collectd_plugin_register)
+{
+       int type  = 0;
+       SV  *data = NULL;
+
+       int ret = 0;
+
+       dXSARGS;
+
+       if (3 != items) {
+               log_err ("Usage: Collectd::plugin_register(type, name, data)");
+               XSRETURN_EMPTY;
+       }
+
+       log_debug ("Collectd::plugin_register: "
+                       "type = \"%i\", name = \"%s\", \"%s\"",
+                       (int)SvIV (ST (0)), SvPV_nolen (ST (1)), SvPV_nolen (ST (2)));
+
+       type = (int)SvIV (ST (0));
+       data = ST (2);
+
+       if ((type >= 0) && (type < PLUGIN_TYPES)
+                       && SvROK (data) && (SVt_PVCV == SvTYPE (SvRV (data)))) {
+               ret = pplugin_register (type, SvPV_nolen (ST (1)), data);
+       }
+       else if ((type == PLUGIN_DATASET)
+                       && SvROK (data) && (SVt_PVAV == SvTYPE (SvRV (data)))) {
+               ret = pplugin_register_data_set (SvPV_nolen (ST (1)),
+                               (AV *)SvRV (data));
+       }
+       else {
+               log_err ("Collectd::plugin_register: Invalid data.");
+               XSRETURN_EMPTY;
+       }
+
+       if (0 == ret)
+               XSRETURN_YES;
+       else
+               XSRETURN_EMPTY;
+} /* static XS (Collectd_plugin_register) */
+
+/*
+ * Collectd::plugin_unregister (type, name).
+ *
+ * type:
+ *   init, read, write, shutdown, data set
+ *
+ * name:
+ *   name of the plugin
+ */
+static XS (Collectd_plugin_unregister)
+{
+       int type = 0;
+       int ret  = 0;
+
+       dXSARGS;
+
+       if (2 != items) {
+               log_err ("Usage: Collectd::plugin_unregister(type, name)");
+               XSRETURN_EMPTY;
+       }
+
+       log_debug ("Collectd::plugin_unregister: type = \"%i\", name = \"%s\"",
+                       (int)SvIV (ST (0)), SvPV_nolen (ST (1)));
+
+       type = (int)SvIV (ST (0));
+
+       if ((type >= 0) && (type < PLUGIN_TYPES)) {
+               ret = pplugin_unregister (type, SvPV_nolen (ST (1)));
+       }
+       else if (type == PLUGIN_DATASET) {
+               ret = pplugin_unregister_data_set (SvPV_nolen (ST (1)));
+       }
+       else {
+               log_err ("Collectd::plugin_unregister: Invalid type.");
+               XSRETURN_EMPTY;
+       }
+
+       if (0 == ret)
+               XSRETURN_YES;
+       else
+               XSRETURN_EMPTY;
+} /* static XS (Collectd_plugin_unregister) */
+
+/*
+ * Collectd::plugin_dispatch_values (name, values).
+ *
+ * name:
+ *   name of the plugin
+ *
+ * values:
+ *   value list to submit
+ */
+static XS (Collectd_plugin_dispatch_values)
+{
+       SV *values = NULL;
+
+       int ret = 0;
+
+       dXSARGS;
+
+       items = 2;
+       if (2 != items) {
+               log_err ("Usage: Collectd::plugin_dispatch_values(name, values)");
+               XSRETURN_EMPTY;
+       }
+
+       log_debug ("Collectd::plugin_dispatch_values: "
+                       "name = \"%s\", values=\"%s\"",
+                       SvPV_nolen (ST (0)), SvPV_nolen (ST (1)));
+
+       values = ST (1);
+
+       if (! (SvROK (values) && (SVt_PVHV == SvTYPE (SvRV (values))))) {
+               log_err ("Collectd::plugin_dispatch_values: Invalid values.");
+               XSRETURN_EMPTY;
+       }
+
+       if ((NULL == ST (0)) || (NULL == values))
+               XSRETURN_EMPTY;
+
+       ret = pplugin_dispatch_values (SvPV_nolen (ST (0)), (HV *)SvRV (values));
+
+       if (0 == ret)
+               XSRETURN_YES;
+       else
+               XSRETURN_EMPTY;
+} /* static XS (Collectd_plugin_dispatch_values) */
+
+/*
+ * Collectd::bootstrap ().
+ */
+static XS (boot_Collectd)
+{
+       HV   *stash = NULL;
+       char *file  = __FILE__;
+
+       struct {
+               char name[64];
+               SV   *value;
+       } consts[] =
+       {
+               { "Collectd::TYPE_INIT",       Perl_newSViv (perl, PLUGIN_INIT) },
+               { "Collectd::TYPE_READ",       Perl_newSViv (perl, PLUGIN_READ) },
+               { "Collectd::TYPE_WRITE",      Perl_newSViv (perl, PLUGIN_WRITE) },
+               { "Collectd::TYPE_SHUTDOWN",   Perl_newSViv (perl, PLUGIN_SHUTDOWN) },
+               { "Collectd::TYPE_LOG",        Perl_newSViv (perl, PLUGIN_LOG) },
+               { "Collectd::TYPE_DATASET",    Perl_newSViv (perl, PLUGIN_DATASET) },
+               { "Collectd::DS_TYPE_COUNTER", Perl_newSViv (perl, DS_TYPE_COUNTER) },
+               { "Collectd::DS_TYPE_GAUGE",   Perl_newSViv (perl, DS_TYPE_GAUGE) },
+               { "Collectd::LOG_ERR",         Perl_newSViv (perl, LOG_ERR) },
+               { "Collectd::LOG_WARNING",     Perl_newSViv (perl, LOG_WARNING) },
+               { "Collectd::LOG_NOTICE",      Perl_newSViv (perl, LOG_NOTICE) },
+               { "Collectd::LOG_INFO",        Perl_newSViv (perl, LOG_INFO) },
+               { "Collectd::LOG_DEBUG",       Perl_newSViv (perl, LOG_DEBUG) },
+               { "", NULL }
+       };
+
+       int i = 0;
+
+       dXSARGS;
+
+       if ((1 > items) || (2 < items)) {
+               log_err ("Usage: Collectd::bootstrap(name[, version])");
+               XSRETURN_EMPTY;
+       }
+
+       XS_VERSION_BOOTCHECK;
+
+       /* register API */
+       for (i = 0; NULL != api[i].f; ++i)
+               Perl_newXS (perl, api[i].name, api[i].f, file);
+
+       stash = Perl_gv_stashpv (perl, "Collectd", 1);
+
+       /* export "constants" */
+       for (i = 0; NULL != consts[i].value; ++i)
+               Perl_newCONSTSUB (perl, stash, consts[i].name, consts[i].value);
+       XSRETURN_YES;
+} /* static XS (boot_Collectd) */
+
+
+/*
+ * Interface to collectd.
+ */
+
+static int perl_config (const char *key, const char *value)
+{
+       log_debug ("perl_config: key = \"%s\", value=\"%s\"", key, value);
+
+       if (0 == strcasecmp (key, "LoadPlugin")) {
+               log_debug ("perl_config: loading perl plugin \"%s\"", value);
+
+               Perl_load_module (perl, PERL_LOADMOD_NOIMPORT,
+                               Perl_newSVpvf (perl, "Collectd::plugin::%s", value),
+                               Nullsv);
+       }
+       else {
+               return -1;
+       }
+       return 0;
+} /* static int perl_config (char *, char *) */
+
+static int perl_init (void)
+{
+       PERL_SET_CONTEXT (perl);
+       return pplugin_call_all (PLUGIN_INIT);
+} /* static int perl_init (void) */
+
+static int perl_read (void)
+{
+       PERL_SET_CONTEXT (perl);
+       return pplugin_call_all (PLUGIN_READ);
+} /* static int perl_read (void) */
+
+static int perl_write (const data_set_t *ds, const value_list_t *vl)
+{
+       PERL_SET_CONTEXT (perl);
+       return pplugin_call_all (PLUGIN_WRITE, ds, vl);
+} /* static int perl_write (const data_set_t *, const value_list_t *) */
+
+static void perl_log (int level, const char *msg)
+{
+       PERL_SET_CONTEXT (perl);
+       pplugin_call_all (PLUGIN_LOG, level, msg);
+       return;
+} /* static void perl_log (int, const char *) */
+
+static int perl_shutdown (void)
+{
+       int i   = 0;
+       int ret = 0;
+
+       PERL_SET_CONTEXT (perl);
+       ret = pplugin_call_all (PLUGIN_SHUTDOWN);
+
+       for (i = 0; i < PLUGIN_TYPES; ++i) {
+               if (0 < Perl_hv_iterinit (perl, plugins[i])) {
+                       char *k = NULL;
+                       I32  l  = 0;
+
+                       while (NULL != Perl_hv_iternextsv (perl, plugins[i], &k, &l)) {
+                               pplugin_unregister (i, k);
+                       }
+               }
+
+               Perl_hv_undef (perl, plugins[i]);
+       }
+
+       if (0 < Perl_hv_iterinit (perl, data_sets)) {
+               char *k = NULL;
+               I32  l  = 0;
+
+               while (NULL != Perl_hv_iternextsv (perl, data_sets, &k, &l)) {
+                       pplugin_unregister_data_set (k);
+               }
+       }
+
+       Perl_hv_undef (perl, data_sets);
+
+#if COLLECT_DEBUG
+       Perl_sv_report_used (perl);
+#endif /* COLLECT_DEBUG */
+
+       perl_destruct (perl);
+       perl_free (perl);
+
+       PERL_SYS_TERM ();
+       return ret;
+} /* static void perl_shutdown (void) */
+
+static void xs_init (pTHX)
+{
+       char *file = __FILE__;
+
+       dXSUB_SYS;
+
+       /* build the Collectd module into the perl interpreter */
+       Perl_newXS (perl, "Collectd::bootstrap", boot_Collectd, file);
+
+       /* enable usage of Perl modules using shared libraries */
+       Perl_newXS (perl, "DynaLoader::boot_DynaLoader", boot_DynaLoader, file);
+       return;
+} /* static void xs_init (pTHX) */
+
+/*
+ * Create the perl interpreter and register it with collectd.
+ */
+void module_register (void)
+{
+       char *embed_argv[] = { "", "-e", "bootstrap Collectd \""VERSION"\"", NULL };
+       int  embed_argc    = 3;
+
+       int i = 0;
+
+       log_debug ("module_register: Registering perl plugin...");
+
+       PERL_SYS_INIT3 (&argc, &argv, &environ);
+
+       if (NULL == (perl = perl_alloc ())) {
+               log_err ("module_register: Not enough memory.");
+               exit (3);
+       }
+       perl_construct (perl);
+
+       PL_exit_flags |= PERL_EXIT_DESTRUCT_END;
+
+       if (0 != perl_parse (perl, xs_init, embed_argc, embed_argv, NULL)) {
+               log_err ("module_register: Unable to bootstrap Collectd.");
+               exit (1);
+       }
+       perl_run (perl);
+
+       for (i = 0; i < PLUGIN_TYPES; ++i)
+               plugins[i] = Perl_newHV (perl);
+
+       data_sets = Perl_newHV (perl);
+
+       plugin_register_log ("perl", perl_log);
+       plugin_register_config ("perl", perl_config, config_keys, config_keys_num);
+       plugin_register_init ("perl", perl_init);
+       plugin_register_read ("perl", perl_read);
+       plugin_register_write ("perl", perl_write);
+       plugin_register_shutdown ("perl", perl_shutdown);
+       return;
+} /* void module_register (void) */
+
+/* vim: set sw=4 ts=4 tw=78 noexpandtab : */
+