From 3f0a64bdf677571a791988a934f43516246f9a0e Mon Sep 17 00:00:00 2001 From: Sebastian Harl Date: Mon, 9 Apr 2007 18:26:48 +0200 Subject: [PATCH] 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 --- AUTHORS | 3 + configure.in | 2 + src/Makefile.am | 12 + src/collectd.conf.in | 5 + src/perl.c | 1055 ++++++++++++++++++++++++++++++++++++++++++ 5 files changed, 1077 insertions(+) create mode 100644 src/perl.c diff --git a/AUTHORS b/AUTHORS index 25391080..0c1b3225 100644 --- a/AUTHORS +++ b/AUTHORS @@ -19,6 +19,9 @@ mbmon plugin by: nfs module by: Jason Pepas +perl module by: + Sebastian Harl + processes module by: Lyonel Vincent diff --git a/configure.in b/configure.in index 7a21b077..ebbf8a76 100644 --- 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 23d82aa5..01673e0e 100644 --- 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 020bdebe..3aa13065 100644 --- 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" # +# +# LoadPlugin foo +# + # # Host "host.foo.bar" # diff --git a/src/perl.c b/src/perl.c new file mode 100644 index 00000000..0c5e8829 --- /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 + **/ + +/* + * 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 +#include + +#include + +#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 : */ + -- 2.30.2