src/perl.c

   1 /**
   2  * collectd - src/perl.c
   3  * Copyright (C) 2007  Sebastian Harl
   4  *
   5  * This program is free software; you can redistribute it and/or modify it
   6  * under the terms of the GNU General Public License as published by the
   7  * Free Software Foundation; only version 2 of the License is applicable.
   8  *
   9  * This program is distributed in the hope that it will be useful, but
  10  * WITHOUT ANY WARRANTY; without even the implied warranty of
  11  * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  12  * General Public License for more details.
  13  *
  14  * You should have received a copy of the GNU General Public License along
  15  * with this program; if not, write to the Free Software Foundation, Inc.,
  16  * 51 Franklin St, Fifth Floor, Boston, MA  02110-1301 USA
  17  *
  18  * Author:
  19  *   Sebastian Harl <sh at tokkee.org>
  20  **/
  21
  22 /*
  23  * This plugin embeds a Perl interpreter into collectd and provides an
  24  * interface for collectd plugins written in perl.
  25  */
  26
  27 #include "collectd.h"
  28 #include "common.h"
  29 #include "plugin.h"
  30
  31 #include "configfile.h"
  32
  33 #include <EXTERN.h>
  34 #include <perl.h>
  35
  36 #include <XSUB.h>
  37
  38 #define PLUGIN_INIT     0
  39 #define PLUGIN_READ     1
  40 #define PLUGIN_WRITE    2
  41 #define PLUGIN_SHUTDOWN 3
  42 #define PLUGIN_LOG      4
  43
  44 #define PLUGIN_TYPES    5
  45
  46 #define PLUGIN_DATASET  255
  47
  48 #define log_debug(...) DEBUG ("perl: " __VA_ARGS__)
  49 #define log_warn(...) WARNING ("perl: " __VA_ARGS__)
  50 #define log_err(...) ERROR ("perl: " __VA_ARGS__)
  51
  52
  53 /* this is defined in DynaLoader.a */
  54 void boot_DynaLoader (PerlInterpreter *, CV *);
  55
  56 static XS (Collectd_plugin_register);
  57 static XS (Collectd_plugin_unregister);
  58 static XS (Collectd_plugin_dispatch_values);
  59 static XS (Collectd_plugin_log);
  60
  61
  62 /*
  63  * private data types
  64  */
  65
  66 typedef struct {
  67         int len;
  68         int *values;
  69 } ds_types_t;
  70
  71 typedef struct {
  72         int wait_time;
  73         int wait_left;
  74
  75         SV  *sub;
  76 } pplugin_t;
  77
  78
  79 /*
  80  * private variables
  81  */
  82
  83 /* valid configuration file keys */
  84 static const char *config_keys[] =
  85 {
  86         "LoadPlugin",
  87         NULL
  88 };
  89 static int config_keys_num = 1;
  90
  91 static PerlInterpreter *perl = NULL;
  92
  93 static char *plugin_types[] = { "init", "read", "write", "shutdown" };
  94 static HV   *plugins[PLUGIN_TYPES];
  95 static HV   *data_sets;
  96
  97 static struct {
  98         char name[64];
  99         XS ((*f));
 100 } api[] =
 101 {
 102         { "Collectd::plugin_register",        Collectd_plugin_register },
 103         { "Collectd::plugin_unregister",      Collectd_plugin_unregister },
 104         { "Collectd::plugin_dispatch_values", Collectd_plugin_dispatch_values },
 105         { "Collectd::plugin_log",             Collectd_plugin_log },
 106         { "", NULL }
 107 };
 108
 109
 110 /*
 111  * Helper functions for data type conversion.
 112  */
 113
 114 /*
 115  * data source:
 116  * [
 117  *   {
 118  *     name => $ds_name,
 119  *     type => $ds_type,
 120  *     min  => $ds_min,
 121  *     max  => $ds_max
 122  *   },
 123  *   ...
 124  * ]
 125  */
 126 static int hv2data_source (HV *hash, data_source_t *ds)
 127 {
 128         SV **tmp = NULL;
 129
 130         if ((NULL == hash) || (NULL == ds))
 131                 return -1;
 132
 133         if (NULL != (tmp = Perl_hv_fetch (perl, hash, "name", 4, 0))) {
 134                 strncpy (ds->name, SvPV_nolen (*tmp), DATA_MAX_NAME_LEN);
 135                 ds->name[DATA_MAX_NAME_LEN - 1] = '\0';
 136         }
 137         else {
 138                 log_err ("hv2data_source: No DS name given.");
 139                 return -1;
 140         }
 141
 142         if (NULL != (tmp = Perl_hv_fetch (perl, hash, "type", 4, 0))) {
 143                 ds->type = SvIV (*tmp);
 144
 145                 if ((DS_TYPE_COUNTER != ds->type) && (DS_TYPE_GAUGE != ds->type)) {
 146                         log_err ("hv2data_source: Invalid DS type.");
 147                         return -1;
 148                 }
 149         }
 150         else {
 151                 ds->type = DS_TYPE_COUNTER;
 152         }
 153
 154         if (NULL != (tmp = Perl_hv_fetch (perl, hash, "min", 3, 0)))
 155                 ds->min = SvNV (*tmp);
 156         else
 157                 ds->min = NAN;
 158
 159         if (NULL != (tmp = Perl_hv_fetch (perl, hash, "max", 3, 0)))
 160                 ds->max = SvNV (*tmp);
 161         else
 162                 ds->max = NAN;
 163         return 0;
 164 } /* static data_source_t *hv2data_source (HV *) */
 165
 166 static int av2value (char *name, AV *array, value_t *value, int len)
 167 {
 168         SV **tmp = NULL;
 169
 170         ds_types_t *ds = NULL;
 171
 172         int i = 0;
 173
 174         if ((NULL == name) || (NULL == array) || (NULL == value))
 175                 return -1;
 176
 177         if (Perl_av_len (perl, array) < len - 1)
 178                 len = Perl_av_len (perl, array) + 1;
 179
 180         if (0 >= len)
 181                 return -1;
 182
 183         tmp = Perl_hv_fetch (perl, data_sets, name, strlen (name), 0);
 184         if (NULL == tmp) {
 185                 log_err ("av2value: No dataset for \"%s\".", name);
 186                 return -1;
 187         }
 188         ds = (ds_types_t *)SvIV ((SV *)SvRV (*tmp));
 189
 190         if (ds->len < len) {
 191                 log_warn ("av2value: Value length exceeds data set length.");
 192                 len = ds->len;
 193         }
 194
 195         for (i = 0; i < len; ++i) {
 196                 SV **tmp = Perl_av_fetch (perl, array, i, 0);
 197
 198                 if (NULL != tmp) {
 199                         if (DS_TYPE_COUNTER == ds->values[i])
 200                                 value[i].counter = SvIV (*tmp);
 201                         else
 202                                 value[i].gauge = SvNV (*tmp);
 203                 }
 204                 else {
 205                         return -1;
 206                 }
 207         }
 208         return len;
 209 } /* static int av2value (char *, AV *, value_t *, int) */
 210
 211 static int data_set2av (data_set_t *ds, AV *array)
 212 {
 213         int i = 0;
 214
 215         if ((NULL == ds) || (NULL == array))
 216                 return -1;
 217
 218         Perl_av_extend (perl, array, ds->ds_num);
 219
 220         for (i = 0; i < ds->ds_num; ++i) {
 221                 HV *source = Perl_newHV (perl);
 222
 223                 if (NULL == Perl_hv_store (perl, source, "name", 4,
 224                                 Perl_newSVpv (perl, ds->ds[i].name, 0), 0))
 225                         return -1;
 226
 227                 if (NULL == Perl_hv_store (perl, source, "type", 4,
 228                                 Perl_newSViv (perl, ds->ds[i].type), 0))
 229                         return -1;
 230
 231                 if (! isnan (ds->ds[i].min))
 232                         if (NULL == Perl_hv_store (perl, source, "min", 3,
 233                                         Perl_newSVnv (perl, ds->ds[i].min), 0))
 234                                 return -1;
 235
 236                 if (! isnan (ds->ds[i].max))
 237                         if (NULL == Perl_hv_store (perl, source, "max", 3,
 238                                         Perl_newSVnv (perl, ds->ds[i].max), 0))
 239                                 return -1;
 240
 241                 if (NULL == Perl_av_store (perl, array, i,
 242                                 Perl_newRV_noinc (perl, (SV *)source)))
 243                         return -1;
 244         }
 245         return 0;
 246 } /* static int data_set2av (data_set_t *, AV *) */
 247
 248 static int value_list2hv (value_list_t *vl, data_set_t *ds, HV *hash)
 249 {
 250         AV *values = NULL;
 251
 252         int i   = 0;
 253         int len = 0;
 254
 255         if ((NULL == vl) || (NULL == ds) || (NULL == hash))
 256                 return -1;
 257
 258         len = vl->values_len;
 259
 260         if (ds->ds_num < len) {
 261                 log_warn ("value2av: Value length exceeds data set length.");
 262                 len = ds->ds_num;
 263         }
 264
 265         values = Perl_newAV (perl);
 266         Perl_av_extend (perl, values, len - 1);
 267
 268         for (i = 0; i < len; ++i) {
 269                 SV *val = NULL;
 270
 271                 if (DS_TYPE_COUNTER == ds->ds[i].type)
 272                         val = Perl_newSViv (perl, vl->values[i].counter);
 273                 else
 274                         val = Perl_newSVnv (perl, vl->values[i].gauge);
 275
 276                 if (NULL == Perl_av_store (perl, values, i, val)) {
 277                         Perl_av_undef (perl, values);
 278                         return -1;
 279                 }
 280         }
 281
 282         if (NULL == Perl_hv_store (perl, hash, "values", 6,
 283                         Perl_newRV_noinc (perl, (SV *)values), 0))
 284                 return -1;
 285
 286         if (0 != vl->time)
 287                 if (NULL == Perl_hv_store (perl, hash, "time", 4,
 288                                 Perl_newSViv (perl, vl->time), 0))
 289                         return -1;
 290
 291         if ('\0' != vl->host[0])
 292                 if (NULL == Perl_hv_store (perl, hash, "host", 4,
 293                                 Perl_newSVpv (perl, vl->host, 0), 0))
 294                         return -1;
 295
 296         if ('\0' != vl->plugin[0])
 297                 if (NULL == Perl_hv_store (perl, hash, "plugin", 6,
 298                                 Perl_newSVpv (perl, vl->plugin, 0), 0))
 299                         return -1;
 300
 301         if ('\0' != vl->plugin_instance[0])
 302                 if (NULL == Perl_hv_store (perl, hash, "plugin_instance", 15,
 303                                 Perl_newSVpv (perl, vl->plugin_instance, 0), 0))
 304                         return -1;
 305
 306         if ('\0' != vl->type_instance[0])
 307                 if (NULL == Perl_hv_store (perl, hash, "type_instance", 13,
 308                                 Perl_newSVpv (perl, vl->type_instance, 0), 0))
 309                         return -1;
 310         return 0;
 311 } /* static int value2av (value_list_t *, data_set_t *, HV *) */
 312
 313
 314 /*
 315  * Internal functions.
 316  */
 317
 318 /*
 319  * Add a new plugin with the given name.
 320  */
 321 static int pplugin_register (int type, const char *name, SV *sub)
 322 {
 323         pplugin_t *p = NULL;
 324
 325         if ((type < 0) || (type >= PLUGIN_TYPES))
 326                 return -1;
 327
 328         if (NULL == name)
 329                 return -1;
 330
 331         p = (pplugin_t *)smalloc (sizeof (pplugin_t));
 332         /* this happens during parsing of config file,
 333          * thus interval_g is not set correctly */
 334         p->wait_time = 10;
 335         p->wait_left = 0;
 336         p->sub = Perl_newSVsv (perl, sub);
 337
 338         if (NULL == Perl_hv_store (perl, plugins[type], name, strlen (name),
 339                                 Perl_sv_setref_pv (perl, Perl_newSV (perl, 0), 0, p), 0)) {
 340                 log_debug ("pplugin_register: Failed to add plugin \"%s\" (\"%s\")",
 341                                 name, SvPV_nolen (sub));
 342                 Perl_sv_free (perl, p->sub);
 343                 sfree (p);
 344                 return -1;
 345         }
 346         return 0;
 347 } /* static int pplugin_register (int, char *, SV *) */
 348
 349 /*
 350  * Removes the plugin with the given name and frees any ressources.
 351  */
 352 static int pplugin_unregister (int type, char *name)
 353 {
 354         SV *tmp = NULL;
 355
 356         if ((type < 0) || (type >= PLUGIN_TYPES))
 357                 return -1;
 358
 359         if (NULL == name)
 360                 return -1;
 361
 362         /* freeing the allocated memory of the element itself (pplugin_t *) causes
 363          * a segfault during perl_destruct () thus I assume perl somehow takes
 364          * care of this... */
 365
 366         tmp = Perl_hv_delete (perl, plugins[type], name, strlen (name), 0);
 367         if (NULL != tmp) {
 368                 pplugin_t *p = (pplugin_t *)SvIV ((SV *)SvRV (tmp));
 369                 Perl_sv_free (perl, p->sub);
 370         }
 371         return 0;
 372 } /* static int pplugin_unregister (char *) */
 373
 374 /*
 375  * Add a plugin's data set definition.
 376  */
 377 static int pplugin_register_data_set (char *name, AV *dataset)
 378 {
 379         int len = -1;
 380         int i   = 0;
 381
 382         data_source_t *ds  = NULL;
 383         data_set_t    *set = NULL;
 384
 385         ds_types_t *types = NULL;
 386
 387         if ((NULL == name) || (NULL == dataset))
 388                 return -1;
 389
 390         len = Perl_av_len (perl, dataset);
 391
 392         if (-1 == len)
 393                 return -1;
 394
 395         ds  = (data_source_t *)smalloc ((len + 1) * sizeof (data_source_t));
 396         set = (data_set_t *)smalloc (sizeof (data_set_t));
 397
 398         types = (ds_types_t *)smalloc (sizeof (ds_types_t));
 399         types->len = len + 1;
 400         types->values = (int *)smalloc ((types->len) * sizeof (int));
 401
 402         for (i = 0; i <= len; ++i) {
 403                 SV **elem = Perl_av_fetch (perl, dataset, i, 0);
 404
 405                 if (NULL == elem)
 406                         return -1;
 407
 408                 if (! (SvROK (*elem) && (SVt_PVHV == SvTYPE (SvRV (*elem))))) {
 409                         log_err ("pplugin_register_data_set: Invalid data source.");
 410                         return -1;
 411                 }
 412
 413                 if (-1 == hv2data_source ((HV *)SvRV (*elem), &ds[i]))
 414                         return -1;
 415
 416                 types->values[i] = ds[i].type;
 417                 log_debug ("pplugin_register_data_set: "
 418                                 "DS.name = \"%s\", DS.type = %i, DS.min = %f, DS.max = %f",
 419                                 ds[i].name, ds[i].type, ds[i].min, ds[i].max);
 420         }
 421
 422         if (NULL == Perl_hv_store (perl, data_sets, name, strlen (name),
 423                         Perl_sv_setref_pv (perl, Perl_newSV (perl, 0), 0, types), 0))
 424                 return -1;
 425
 426         strncpy (set->type, name, DATA_MAX_NAME_LEN);
 427         set->type[DATA_MAX_NAME_LEN - 1] = '\0';
 428
 429         set->ds_num = len + 1;
 430         set->ds = ds;
 431         return plugin_register_data_set (set);
 432 } /* static int pplugin_register_data_set (char *, SV *) */
 433
 434 /*
 435  * Remove a plugin's data set definition.
 436  */
 437 static int pplugin_unregister_data_set (char *name)
 438 {
 439         SV *tmp = NULL;
 440
 441         if (NULL == name)
 442                 return 0;
 443
 444         /* freeing the allocated memory of the element itself (ds_types_t *)
 445          * causes a segfault during perl_destruct () thus I assume perl somehow
 446          * takes care of this... */
 447
 448         tmp = Perl_hv_delete (perl, data_sets, name, strlen (name), 0);
 449         if (NULL != tmp) {
 450                 ds_types_t *ds = (ds_types_t *)SvIV ((SV *)SvRV (tmp));
 451                 sfree (ds->values);
 452         }
 453         return plugin_unregister_data_set (name);
 454 } /* static int pplugin_unregister_data_set (char *) */
 455
 456 /*
 457  * Submit the values to the write functions.
 458  *
 459  * value list:
 460  * {
 461  *   values => [ @values ],
 462  *   time   => $time,
 463  *   host   => $host,
 464  *   plugin => $plugin,
 465  *   plugin_instance => $pinstance,
 466  *   type_instance   => $tinstance,
 467  * }
 468  */
 469 static int pplugin_dispatch_values (char *name, HV *values)
 470 {
 471         value_list_t list = VALUE_LIST_INIT;
 472         value_t      *val = NULL;
 473
 474         SV **tmp = NULL;
 475
 476         int ret = 0;
 477
 478         if ((NULL == name) || (NULL == values))
 479                 return -1;
 480
 481         if ((NULL == (tmp = Perl_hv_fetch (perl, values, "values", 6, 0)))
 482                         || (! (SvROK (*tmp) && (SVt_PVAV == SvTYPE (SvRV (*tmp)))))) {
 483                 log_err ("pplugin_dispatch_values: No valid values given.");
 484                 return -1;
 485         }
 486
 487         {
 488                 AV  *array = (AV *)SvRV (*tmp);
 489                 int len    = Perl_av_len (perl, array) + 1;
 490
 491                 val = (value_t *)smalloc (len * sizeof (value_t));
 492
 493                 list.values_len = av2value (name, (AV *)SvRV (*tmp), val, len);
 494                 list.values = val;
 495
 496                 if (-1 == list.values_len) {
 497                         sfree (val);
 498                         return -1;
 499                 }
 500         }
 501
 502         if (NULL != (tmp = Perl_hv_fetch (perl, values, "time", 4, 0))) {
 503                 list.time = (time_t)SvIV (*tmp);
 504         }
 505         else {
 506                 list.time = time (NULL);
 507         }
 508
 509         if (NULL != (tmp = Perl_hv_fetch (perl, values, "host", 4, 0))) {
 510                 strncpy (list.host, SvPV_nolen (*tmp), DATA_MAX_NAME_LEN);
 511         }
 512         else {
 513                 strcpy (list.host, hostname_g);
 514         }
 515
 516         if (NULL != (tmp = Perl_hv_fetch (perl, values, "plugin", 6, 0))) {
 517                 strncpy (list.plugin, SvPV_nolen (*tmp), DATA_MAX_NAME_LEN);
 518                 list.plugin[DATA_MAX_NAME_LEN - 1] = '\0';
 519         }
 520
 521         if (NULL != (tmp = Perl_hv_fetch (perl, values,
 522                         "plugin_instance", 15, 0))) {
 523                 strncpy (list.plugin_instance, SvPV_nolen (*tmp), DATA_MAX_NAME_LEN);
 524                 list.plugin_instance[DATA_MAX_NAME_LEN - 1] = '\0';
 525         }
 526
 527         if (NULL != (tmp = Perl_hv_fetch (perl, values, "type_instance", 13, 0))) {
 528                 strncpy (list.type_instance, SvPV_nolen (*tmp), DATA_MAX_NAME_LEN);
 529                 list.type_instance[DATA_MAX_NAME_LEN - 1] = '\0';
 530         }
 531
 532         ret = plugin_dispatch_values (name, &list);
 533
 534         sfree (val);
 535         return ret;
 536 } /* static int pplugin_dispatch_values (char *, HV *) */
 537
 538 /*
 539  * Call a plugin's working function.
 540  */
 541 static int pplugin_call (int type, char *name, SV *sub, va_list ap)
 542 {
 543         int retvals = 0;
 544         I32 xflags  = G_NOARGS;
 545
 546         int ret = 0;
 547
 548         dSP;
 549
 550         if ((type < 0) || (type >= PLUGIN_TYPES))
 551                 return -1;
 552
 553         ENTER;
 554         SAVETMPS;
 555
 556         PUSHMARK (SP);
 557
 558         if (PLUGIN_WRITE == type) {
 559                 /*
 560                  * $_[0] = $plugin_type;
 561                  *
 562                  * $_[1] =
 563                  * [
 564                  *   {
 565                  *     name => $ds_name,
 566                  *     type => $ds_type,
 567                  *     min  => $ds_min,
 568                  *     max  => $ds_max
 569                  *   },
 570                  *   ...
 571                  * ];
 572                  *
 573                  * $_[2] =
 574                  * {
 575                  *   values => [ $v1, ... ],
 576                  *   time   => $time,
 577                  *   host   => $hostname,
 578                  *   plugin => $plugin,
 579                  *   plugin_instance => $instance,
 580                  *   type_instance   => $type_instance
 581                  * };
 582                  */
 583                 data_set_t   *ds;
 584                 value_list_t *vl;
 585
 586                 AV *pds = Perl_newAV (perl);
 587                 HV *pvl = Perl_newHV (perl);
 588
 589                 ds = va_arg (ap, data_set_t *);
 590                 vl = va_arg (ap, value_list_t *);
 591
 592                 if (-1 == data_set2av (ds, pds))
 593                         return -1;
 594
 595                 if (-1 == value_list2hv (vl, ds, pvl))
 596                         return -1;
 597
 598                 XPUSHs (sv_2mortal (Perl_newSVpv (perl, ds->type, 0)));
 599                 XPUSHs (sv_2mortal (Perl_newRV_noinc (perl, (SV *)pds)));
 600                 XPUSHs (sv_2mortal (Perl_newRV_noinc (perl, (SV *)pvl)));
 601
 602                 xflags = 0;
 603         }
 604         else if (PLUGIN_LOG == type) {
 605                 /*
 606                  * $_[0] = $level;
 607                  *
 608                  * $_[1] = $message;
 609                  */
 610                 XPUSHs (sv_2mortal (Perl_newSViv (perl, va_arg (ap, int))));
 611                 XPUSHs (sv_2mortal (Perl_newSVpv (perl, va_arg (ap, char *), 0)));
 612
 613                 xflags = 0;
 614         }
 615
 616         PUTBACK;
 617
 618         /* prevent an endless loop */
 619         if (PLUGIN_LOG != type)
 620                 log_debug ("pplugin_call: executing Collectd::plugin::%s->%s()",
 621                                 name, plugin_types[type]);
 622
 623         retvals = Perl_call_sv (perl, sub, G_SCALAR | xflags);
 624
 625         SPAGAIN;
 626         if (1 > retvals) {
 627                 if (PLUGIN_LOG != type)
 628                         log_warn ("pplugin_call: "
 629                                         "Collectd::plugin::%s->%s() returned void - assuming true",
 630                                         name, plugin_types[type]);
 631         }
 632         else {
 633                 SV *tmp = POPs;
 634                 if (! SvTRUE (tmp))
 635                         ret = -1;
 636         }
 637
 638         PUTBACK;
 639         FREETMPS;
 640         LEAVE;
 641         return ret;
 642 } /* static int pplugin_call (int, char *, SV *, va_list) */
 643
 644 /*
 645  * Call all working functions of the given type.
 646  */
 647 static int pplugin_call_all (int type, ...)
 648 {
 649         SV *tmp = NULL;
 650
 651         char *plugin;
 652         I32  len;
 653
 654         if ((type < 0) || (type >= PLUGIN_TYPES))
 655                 return -1;
 656
 657         if (0 == Perl_hv_iterinit (perl, plugins[type]))
 658                 return 0;
 659
 660         while (NULL != (tmp = Perl_hv_iternextsv (perl, plugins[type],
 661                         &plugin, &len))) {
 662                 pplugin_t *p;
 663                 va_list   ap;
 664
 665                 int status;
 666
 667                 va_start (ap, type);
 668
 669                 p = (pplugin_t *)SvIV ((SV *)SvRV (tmp));
 670
 671                 if (p->wait_left > 0)
 672                         p->wait_left -= interval_g;
 673
 674                 if (p->wait_left > 0)
 675                         continue;
 676
 677                 if (0 == (status = pplugin_call (type, plugin, p->sub, ap))) {
 678                         p->wait_left = 0;
 679                         p->wait_time = interval_g;
 680                 }
 681                 else if (PLUGIN_READ == type) {
 682                         p->wait_left = p->wait_time;
 683                         p->wait_time <<= 1;
 684
 685                         if (p->wait_time > 86400)
 686                                 p->wait_time = 86400;
 687
 688                         log_warn ("Collectd::plugin::%s->read() failed. "
 689                                         "Will suspend it for %i seconds.",
 690                                         plugin, p->wait_left);
 691                 }
 692                 else if (PLUGIN_INIT == type) {
 693                         int i = 0;
 694
 695                         log_err ("Collectd::plugin::%s->init() failed. "
 696                                         "Plugin will be disabled.", plugin, status);
 697
 698                         for (i = 0; i < PLUGIN_TYPES; ++i)
 699                                 pplugin_unregister (i, plugin);
 700                 }
 701                 else if (PLUGIN_LOG != type) {
 702                         log_warn ("Collectd::plugin::%s->%s() failed with status %i.",
 703                                         plugin, plugin_types[type], status);
 704                 }
 705
 706                 va_end (ap);
 707         }
 708         return 0;
 709 } /* static int pplugin_call_all (int, ...) */
 710
 711
 712 /*
 713  * Exported Perl API.
 714  */
 715
 716 /*
 717  * Collectd::plugin_register (type, name, data).
 718  *
 719  * type:
 720  *   init, read, write, shutdown, data set
 721  *
 722  * name:
 723  *   name of the plugin
 724  *
 725  * data:
 726  *   reference to the plugin's subroutine that does the work or the data set
 727  *   definition
 728  */
 729 static XS (Collectd_plugin_register)
 730 {
 731         int type  = 0;
 732         SV  *data = NULL;
 733
 734         int ret = 0;
 735
 736         dXSARGS;
 737
 738         if (3 != items) {
 739                 log_err ("Usage: Collectd::plugin_register(type, name, data)");
 740                 XSRETURN_EMPTY;
 741         }
 742
 743         log_debug ("Collectd::plugin_register: "
 744                         "type = \"%i\", name = \"%s\", \"%s\"",
 745                         (int)SvIV (ST (0)), SvPV_nolen (ST (1)), SvPV_nolen (ST (2)));
 746
 747         type = (int)SvIV (ST (0));
 748         data = ST (2);
 749
 750         if ((type >= 0) && (type < PLUGIN_TYPES)
 751                         && SvROK (data) && (SVt_PVCV == SvTYPE (SvRV (data)))) {
 752                 ret = pplugin_register (type, SvPV_nolen (ST (1)), data);
 753         }
 754         else if ((type == PLUGIN_DATASET)
 755                         && SvROK (data) && (SVt_PVAV == SvTYPE (SvRV (data)))) {
 756                 ret = pplugin_register_data_set (SvPV_nolen (ST (1)),
 757                                 (AV *)SvRV (data));
 758         }
 759         else {
 760                 log_err ("Collectd::plugin_register: Invalid data.");
 761                 XSRETURN_EMPTY;
 762         }
 763
 764         if (0 == ret)
 765                 XSRETURN_YES;
 766         else
 767                 XSRETURN_EMPTY;
 768 } /* static XS (Collectd_plugin_register) */
 769
 770 /*
 771  * Collectd::plugin_unregister (type, name).
 772  *
 773  * type:
 774  *   init, read, write, shutdown, data set
 775  *
 776  * name:
 777  *   name of the plugin
 778  */
 779 static XS (Collectd_plugin_unregister)
 780 {
 781         int type = 0;
 782         int ret  = 0;
 783
 784         dXSARGS;
 785
 786         if (2 != items) {
 787                 log_err ("Usage: Collectd::plugin_unregister(type, name)");
 788                 XSRETURN_EMPTY;
 789         }
 790
 791         log_debug ("Collectd::plugin_unregister: type = \"%i\", name = \"%s\"",
 792                         (int)SvIV (ST (0)), SvPV_nolen (ST (1)));
 793
 794         type = (int)SvIV (ST (0));
 795
 796         if ((type >= 0) && (type < PLUGIN_TYPES)) {
 797                 ret = pplugin_unregister (type, SvPV_nolen (ST (1)));
 798         }
 799         else if (type == PLUGIN_DATASET) {
 800                 ret = pplugin_unregister_data_set (SvPV_nolen (ST (1)));
 801         }
 802         else {
 803                 log_err ("Collectd::plugin_unregister: Invalid type.");
 804                 XSRETURN_EMPTY;
 805         }
 806
 807         if (0 == ret)
 808                 XSRETURN_YES;
 809         else
 810                 XSRETURN_EMPTY;
 811 } /* static XS (Collectd_plugin_unregister) */
 812
 813 /*
 814  * Collectd::plugin_dispatch_values (name, values).
 815  *
 816  * name:
 817  *   name of the plugin
 818  *
 819  * values:
 820  *   value list to submit
 821  */
 822 static XS (Collectd_plugin_dispatch_values)
 823 {
 824         SV *values = NULL;
 825
 826         int ret = 0;
 827
 828         dXSARGS;
 829
 830         if (2 != items) {
 831                 log_err ("Usage: Collectd::plugin_dispatch_values(name, values)");
 832                 XSRETURN_EMPTY;
 833         }
 834
 835         log_debug ("Collectd::plugin_dispatch_values: "
 836                         "name = \"%s\", values=\"%s\"",
 837                         SvPV_nolen (ST (0)), SvPV_nolen (ST (1)));
 838
 839         values = ST (1);
 840
 841         if (! (SvROK (values) && (SVt_PVHV == SvTYPE (SvRV (values))))) {
 842                 log_err ("Collectd::plugin_dispatch_values: Invalid values.");
 843                 XSRETURN_EMPTY;
 844         }
 845
 846         if ((NULL == ST (0)) || (NULL == values))
 847                 XSRETURN_EMPTY;
 848
 849         ret = pplugin_dispatch_values (SvPV_nolen (ST (0)), (HV *)SvRV (values));
 850
 851         if (0 == ret)
 852                 XSRETURN_YES;
 853         else
 854                 XSRETURN_EMPTY;
 855 } /* static XS (Collectd_plugin_dispatch_values) */
 856
 857 /*
 858  * Collectd::plugin_log (level, message).
 859  *
 860  * level:
 861  *   log level (LOG_DEBUG, ... LOG_ERR)
 862  *
 863  * message:
 864  *   log message
 865  */
 866 static XS (Collectd_plugin_log)
 867 {
 868         dXSARGS;
 869
 870         if (2 != items) {
 871                 log_err ("Usage: Collectd::plugin_log(level, message)");
 872                 XSRETURN_EMPTY;
 873         }
 874
 875         log_debug ("Collectd::plugin_log: level = %i, message = \"%s\"",
 876                         SvIV (ST (0)), SvPV_nolen (ST (1)));
 877         plugin_log (SvIV (ST (0)), SvPV_nolen (ST (1)));
 878         XSRETURN_YES;
 879 } /* static XS (Collectd_plugin_log) */
 880
 881 /*
 882  * Collectd::bootstrap ().
 883  */
 884 static XS (boot_Collectd)
 885 {
 886         HV   *stash = NULL;
 887         char *file  = __FILE__;
 888
 889         struct {
 890                 char name[64];
 891                 SV   *value;
 892         } consts[] =
 893         {
 894                 { "Collectd::TYPE_INIT",       Perl_newSViv (perl, PLUGIN_INIT) },
 895                 { "Collectd::TYPE_READ",       Perl_newSViv (perl, PLUGIN_READ) },
 896                 { "Collectd::TYPE_WRITE",      Perl_newSViv (perl, PLUGIN_WRITE) },
 897                 { "Collectd::TYPE_SHUTDOWN",   Perl_newSViv (perl, PLUGIN_SHUTDOWN) },
 898                 { "Collectd::TYPE_LOG",        Perl_newSViv (perl, PLUGIN_LOG) },
 899                 { "Collectd::TYPE_DATASET",    Perl_newSViv (perl, PLUGIN_DATASET) },
 900                 { "Collectd::DS_TYPE_COUNTER", Perl_newSViv (perl, DS_TYPE_COUNTER) },
 901                 { "Collectd::DS_TYPE_GAUGE",   Perl_newSViv (perl, DS_TYPE_GAUGE) },
 902                 { "Collectd::LOG_ERR",         Perl_newSViv (perl, LOG_ERR) },
 903                 { "Collectd::LOG_WARNING",     Perl_newSViv (perl, LOG_WARNING) },
 904                 { "Collectd::LOG_NOTICE",      Perl_newSViv (perl, LOG_NOTICE) },
 905                 { "Collectd::LOG_INFO",        Perl_newSViv (perl, LOG_INFO) },
 906                 { "Collectd::LOG_DEBUG",       Perl_newSViv (perl, LOG_DEBUG) },
 907                 { "", NULL }
 908         };
 909
 910         int i = 0;
 911
 912         dXSARGS;
 913
 914         if ((1 > items) || (2 < items)) {
 915                 log_err ("Usage: Collectd::bootstrap(name[, version])");
 916                 XSRETURN_EMPTY;
 917         }
 918
 919         XS_VERSION_BOOTCHECK;
 920
 921         /* register API */
 922         for (i = 0; NULL != api[i].f; ++i)
 923                 Perl_newXS (perl, api[i].name, api[i].f, file);
 924
 925         stash = Perl_gv_stashpv (perl, "Collectd", 1);
 926
 927         /* export "constants" */
 928         for (i = 0; NULL != consts[i].value; ++i)
 929                 Perl_newCONSTSUB (perl, stash, consts[i].name, consts[i].value);
 930         XSRETURN_YES;
 931 } /* static XS (boot_Collectd) */
 932
 933
 934 /*
 935  * Interface to collectd.
 936  */
 937
 938 static int perl_config (const char *key, const char *value)
 939 {
 940         log_debug ("perl_config: key = \"%s\", value=\"%s\"", key, value);
 941
 942         if (0 == strcasecmp (key, "LoadPlugin")) {
 943                 log_debug ("perl_config: loading perl plugin \"%s\"", value);
 944
 945                 Perl_load_module (perl, PERL_LOADMOD_NOIMPORT,
 946                                 Perl_newSVpvf (perl, "Collectd::plugin::%s", value),
 947                                 Nullsv);
 948         }
 949         else {
 950                 return -1;
 951         }
 952         return 0;
 953 } /* static int perl_config (char *, char *) */
 954
 955 static int perl_init (void)
 956 {
 957         PERL_SET_CONTEXT (perl);
 958         return pplugin_call_all (PLUGIN_INIT);
 959 } /* static int perl_init (void) */
 960
 961 static int perl_read (void)
 962 {
 963         PERL_SET_CONTEXT (perl);
 964         return pplugin_call_all (PLUGIN_READ);
 965 } /* static int perl_read (void) */
 966
 967 static int perl_write (const data_set_t *ds, const value_list_t *vl)
 968 {
 969         PERL_SET_CONTEXT (perl);
 970         return pplugin_call_all (PLUGIN_WRITE, ds, vl);
 971 } /* static int perl_write (const data_set_t *, const value_list_t *) */
 972
 973 static void perl_log (int level, const char *msg)
 974 {
 975         PERL_SET_CONTEXT (perl);
 976         pplugin_call_all (PLUGIN_LOG, level, msg);
 977         return;
 978 } /* static void perl_log (int, const char *) */
 979
 980 static int perl_shutdown (void)
 981 {
 982         int i   = 0;
 983         int ret = 0;
 984
 985         PERL_SET_CONTEXT (perl);
 986         ret = pplugin_call_all (PLUGIN_SHUTDOWN);
 987
 988         for (i = 0; i < PLUGIN_TYPES; ++i) {
 989                 if (0 < Perl_hv_iterinit (perl, plugins[i])) {
 990                         char *k = NULL;
 991                         I32  l  = 0;
 992
 993                         while (NULL != Perl_hv_iternextsv (perl, plugins[i], &k, &l)) {
 994                                 pplugin_unregister (i, k);
 995                         }
 996                 }
 997
 998                 Perl_hv_undef (perl, plugins[i]);
 999         }
1000
1001         if (0 < Perl_hv_iterinit (perl, data_sets)) {
1002                 char *k = NULL;
1003                 I32  l  = 0;
1004
1005                 while (NULL != Perl_hv_iternextsv (perl, data_sets, &k, &l)) {
1006                         pplugin_unregister_data_set (k);
1007                 }
1008         }
1009
1010         Perl_hv_undef (perl, data_sets);
1011
1012 #if COLLECT_DEBUG
1013         Perl_sv_report_used (perl);
1014 #endif /* COLLECT_DEBUG */
1015
1016         perl_destruct (perl);
1017         perl_free (perl);
1018
1019         PERL_SYS_TERM ();
1020         return ret;
1021 } /* static void perl_shutdown (void) */
1022
1023 static void xs_init (pTHX)
1024 {
1025         char *file = __FILE__;
1026
1027         dXSUB_SYS;
1028
1029         /* build the Collectd module into the perl interpreter */
1030         Perl_newXS (perl, "Collectd::bootstrap", boot_Collectd, file);
1031
1032         /* enable usage of Perl modules using shared libraries */
1033         Perl_newXS (perl, "DynaLoader::boot_DynaLoader", boot_DynaLoader, file);
1034         return;
1035 } /* static void xs_init (pTHX) */
1036
1037 /*
1038  * Create the perl interpreter and register it with collectd.
1039  */
1040 void module_register (void)
1041 {
1042         char *embed_argv[] = { "", "-e", "bootstrap Collectd \""VERSION"\"", NULL };
1043         int  embed_argc    = 3;
1044
1045         int i = 0;
1046
1047         log_debug ("module_register: Registering perl plugin...");
1048
1049         PERL_SYS_INIT3 (&argc, &argv, &environ);
1050
1051         if (NULL == (perl = perl_alloc ())) {
1052                 log_err ("module_register: Not enough memory.");
1053                 exit (3);
1054         }
1055         perl_construct (perl);
1056
1057         PL_exit_flags |= PERL_EXIT_DESTRUCT_END;
1058
1059         if (0 != perl_parse (perl, xs_init, embed_argc, embed_argv, NULL)) {
1060                 log_err ("module_register: Unable to bootstrap Collectd.");
1061                 exit (1);
1062         }
1063         perl_run (perl);
1064
1065         for (i = 0; i < PLUGIN_TYPES; ++i)
1066                 plugins[i] = Perl_newHV (perl);
1067
1068         data_sets = Perl_newHV (perl);
1069
1070         plugin_register_log ("perl", perl_log);
1071         plugin_register_config ("perl", perl_config, config_keys, config_keys_num);
1072         plugin_register_init ("perl", perl_init);
1073         plugin_register_read ("perl", perl_read);
1074         plugin_register_write ("perl", perl_write);
1075         plugin_register_shutdown ("perl", perl_shutdown);
1076         return;
1077 } /* void module_register (void) */
1078
1079 /* vim: set sw=4 ts=4 tw=78 noexpandtab : */
1080