src/perl.c

   1 /**
   2  * collectd - src/perl.c
   3  * Copyright (C) 2007, 2008  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 /* do not automatically get the thread specific perl interpreter */
  28 #define PERL_NO_GET_CONTEXT
  29
  30 #define DONT_POISON_SPRINTF_YET 1
  31 #include "collectd.h"
  32 #undef DONT_POISON_SPRINTF_YET
  33
  34 #include "configfile.h"
  35
  36 #include <EXTERN.h>
  37 #include <perl.h>
  38
  39 #if defined(COLLECT_DEBUG) && COLLECT_DEBUG && defined(__GNUC__) && __GNUC__
  40 # pragma GCC poison sprintf
  41 #endif
  42
  43 #include <XSUB.h>
  44
  45 /* Some versions of Perl define their own version of DEBUG... :-/ */
  46 #ifdef DEBUG
  47 # undef DEBUG
  48 #endif /* DEBUG */
  49
  50 /* ... while we want the definition found in plugin.h. */
  51 #include "plugin.h"
  52 #include "common.h"
  53
  54 #include <pthread.h>
  55
  56 #if !defined(USE_ITHREADS)
  57 # error "Perl does not support ithreads!"
  58 #endif /* !defined(USE_ITHREADS) */
  59
  60 /* clear the Perl sub's stack frame
  61  * (this should only be used inside an XSUB) */
  62 #define CLEAR_STACK_FRAME PL_stack_sp = PL_stack_base + *PL_markstack_ptr
  63
  64 #define PLUGIN_INIT     0
  65 #define PLUGIN_READ     1
  66 #define PLUGIN_WRITE    2
  67 #define PLUGIN_SHUTDOWN 3
  68 #define PLUGIN_LOG      4
  69 #define PLUGIN_NOTIF    5
  70 #define PLUGIN_FLUSH    6
  71
  72 #define PLUGIN_TYPES    7
  73
  74 #define PLUGIN_CONFIG   254
  75 #define PLUGIN_DATASET  255
  76
  77 #define log_debug(...) DEBUG ("perl: " __VA_ARGS__)
  78 #define log_info(...) INFO ("perl: " __VA_ARGS__)
  79 #define log_warn(...) WARNING ("perl: " __VA_ARGS__)
  80 #define log_err(...) ERROR ("perl: " __VA_ARGS__)
  81
  82 /* this is defined in DynaLoader.a */
  83 void boot_DynaLoader (PerlInterpreter *, CV *);
  84
  85 static XS (Collectd_plugin_register_ds);
  86 static XS (Collectd_plugin_unregister_ds);
  87 static XS (Collectd_plugin_dispatch_values);
  88 static XS (Collectd__plugin_flush);
  89 static XS (Collectd_plugin_dispatch_notification);
  90 static XS (Collectd_plugin_log);
  91 static XS (Collectd_call_by_name);
  92
  93 /*
  94  * private data types
  95  */
  96
  97 typedef struct c_ithread_s {
  98         /* the thread's Perl interpreter */
  99         PerlInterpreter *interp;
 100
 101         /* double linked list of threads */
 102         struct c_ithread_s *prev;
 103         struct c_ithread_s *next;
 104 } c_ithread_t;
 105
 106 typedef struct {
 107         c_ithread_t *head;
 108         c_ithread_t *tail;
 109
 110 #if COLLECT_DEBUG
 111         /* some usage stats */
 112         int number_of_threads;
 113 #endif /* COLLECT_DEBUG */
 114
 115         pthread_mutex_t mutex;
 116 } c_ithread_list_t;
 117
 118 /*
 119  * private variables
 120  */
 121
 122 /* if perl_threads != NULL perl_threads->head must
 123  * point to the "base" thread */
 124 static c_ithread_list_t *perl_threads = NULL;
 125
 126 /* the key used to store each pthread's ithread */
 127 static pthread_key_t perl_thr_key;
 128
 129 static int    perl_argc = 0;
 130 static char **perl_argv = NULL;
 131
 132 static char base_name[DATA_MAX_NAME_LEN] = "";
 133
 134 static struct {
 135         char name[64];
 136         XS ((*f));
 137 } api[] =
 138 {
 139         { "Collectd::plugin_register_data_set",   Collectd_plugin_register_ds },
 140         { "Collectd::plugin_unregister_data_set", Collectd_plugin_unregister_ds },
 141         { "Collectd::plugin_dispatch_values",     Collectd_plugin_dispatch_values },
 142         { "Collectd::_plugin_flush",              Collectd__plugin_flush },
 143         { "Collectd::plugin_dispatch_notification",
 144                 Collectd_plugin_dispatch_notification },
 145         { "Collectd::plugin_log",                 Collectd_plugin_log },
 146         { "Collectd::call_by_name",               Collectd_call_by_name },
 147         { "", NULL }
 148 };
 149
 150 struct {
 151         char name[64];
 152         int  value;
 153 } constants[] =
 154 {
 155         { "Collectd::TYPE_INIT",       PLUGIN_INIT },
 156         { "Collectd::TYPE_READ",       PLUGIN_READ },
 157         { "Collectd::TYPE_WRITE",      PLUGIN_WRITE },
 158         { "Collectd::TYPE_SHUTDOWN",   PLUGIN_SHUTDOWN },
 159         { "Collectd::TYPE_LOG",        PLUGIN_LOG },
 160         { "Collectd::TYPE_NOTIF",      PLUGIN_NOTIF },
 161         { "Collectd::TYPE_FLUSH",      PLUGIN_FLUSH },
 162         { "Collectd::TYPE_CONFIG",     PLUGIN_CONFIG },
 163         { "Collectd::TYPE_DATASET",    PLUGIN_DATASET },
 164         { "Collectd::DS_TYPE_COUNTER", DS_TYPE_COUNTER },
 165         { "Collectd::DS_TYPE_GAUGE",   DS_TYPE_GAUGE },
 166         { "Collectd::LOG_ERR",         LOG_ERR },
 167         { "Collectd::LOG_WARNING",     LOG_WARNING },
 168         { "Collectd::LOG_NOTICE",      LOG_NOTICE },
 169         { "Collectd::LOG_INFO",        LOG_INFO },
 170         { "Collectd::LOG_DEBUG",       LOG_DEBUG },
 171         { "Collectd::NOTIF_FAILURE",   NOTIF_FAILURE },
 172         { "Collectd::NOTIF_WARNING",   NOTIF_WARNING },
 173         { "Collectd::NOTIF_OKAY",      NOTIF_OKAY },
 174         { "", 0 }
 175 };
 176
 177 struct {
 178         char  name[64];
 179         char *var;
 180 } g_strings[] =
 181 {
 182         { "Collectd::hostname_g", hostname_g },
 183         { "", NULL }
 184 };
 185
 186 struct {
 187         char  name[64];
 188         int  *var;
 189 } g_integers[] =
 190 {
 191         { "Collectd::interval_g", &interval_g },
 192         { "", NULL }
 193 };
 194
 195 /*
 196  * Helper functions for data type conversion.
 197  */
 198
 199 /*
 200  * data source:
 201  * [
 202  *   {
 203  *     name => $ds_name,
 204  *     type => $ds_type,
 205  *     min  => $ds_min,
 206  *     max  => $ds_max
 207  *   },
 208  *   ...
 209  * ]
 210  */
 211 static int hv2data_source (pTHX_ HV *hash, data_source_t *ds)
 212 {
 213         SV **tmp = NULL;
 214
 215         if ((NULL == hash) || (NULL == ds))
 216                 return -1;
 217
 218         if (NULL != (tmp = hv_fetch (hash, "name", 4, 0))) {
 219                 sstrncpy (ds->name, SvPV_nolen (*tmp), sizeof (ds->name));
 220         }
 221         else {
 222                 log_err ("hv2data_source: No DS name given.");
 223                 return -1;
 224         }
 225
 226         if (NULL != (tmp = hv_fetch (hash, "type", 4, 0))) {
 227                 ds->type = SvIV (*tmp);
 228
 229                 if ((DS_TYPE_COUNTER != ds->type) && (DS_TYPE_GAUGE != ds->type)) {
 230                         log_err ("hv2data_source: Invalid DS type.");
 231                         return -1;
 232                 }
 233         }
 234         else {
 235                 ds->type = DS_TYPE_COUNTER;
 236         }
 237
 238         if (NULL != (tmp = hv_fetch (hash, "min", 3, 0)))
 239                 ds->min = SvNV (*tmp);
 240         else
 241                 ds->min = NAN;
 242
 243         if (NULL != (tmp = hv_fetch (hash, "max", 3, 0)))
 244                 ds->max = SvNV (*tmp);
 245         else
 246                 ds->max = NAN;
 247         return 0;
 248 } /* static int hv2data_source (HV *, data_source_t *) */
 249
 250 static int av2value (pTHX_ char *name, AV *array, value_t *value, int len)
 251 {
 252         const data_set_t *ds;
 253
 254         int i = 0;
 255
 256         if ((NULL == name) || (NULL == array) || (NULL == value))
 257                 return -1;
 258
 259         if (av_len (array) < len - 1)
 260                 len = av_len (array) + 1;
 261
 262         if (0 >= len)
 263                 return -1;
 264
 265         ds = plugin_get_ds (name);
 266         if (NULL == ds) {
 267                 log_err ("av2value: Unknown dataset \"%s\"", name);
 268                 return -1;
 269         }
 270
 271         if (ds->ds_num < len) {
 272                 log_warn ("av2value: Value length exceeds data set length.");
 273                 len = ds->ds_num;
 274         }
 275
 276         for (i = 0; i < len; ++i) {
 277                 SV **tmp = av_fetch (array, i, 0);
 278
 279                 if (NULL != tmp) {
 280                         if (DS_TYPE_COUNTER == ds->ds[i].type)
 281                                 value[i].counter = SvIV (*tmp);
 282                         else
 283                                 value[i].gauge = SvNV (*tmp);
 284                 }
 285                 else {
 286                         return -1;
 287                 }
 288         }
 289         return len;
 290 } /* static int av2value (char *, AV *, value_t *, int) */
 291
 292 /*
 293  * value list:
 294  * {
 295  *   values => [ @values ],
 296  *   time   => $time,
 297  *   host   => $host,
 298  *   plugin => $plugin,
 299  *   plugin_instance => $pinstance,
 300  *   type_instance   => $tinstance,
 301  * }
 302  */
 303 static int hv2value_list (pTHX_ HV *hash, value_list_t *vl)
 304 {
 305         SV **tmp;
 306
 307         if ((NULL == hash) || (NULL == vl))
 308                 return -1;
 309
 310         if (NULL == (tmp = hv_fetch (hash, "type", 4, 0))) {
 311                 log_err ("hv2value_list: No type given.");
 312                 return -1;
 313         }
 314
 315         sstrncpy (vl->type, SvPV_nolen (*tmp), sizeof (vl->type));
 316
 317         if ((NULL == (tmp = hv_fetch (hash, "values", 6, 0)))
 318                         || (! (SvROK (*tmp) && (SVt_PVAV == SvTYPE (SvRV (*tmp)))))) {
 319                 log_err ("hv2value_list: No valid values given.");
 320                 return -1;
 321         }
 322
 323         {
 324                 AV  *array = (AV *)SvRV (*tmp);
 325                 int len    = av_len (array) + 1;
 326
 327                 if (len <= 0)
 328                         return -1;
 329
 330                 vl->values     = (value_t *)smalloc (len * sizeof (value_t));
 331                 vl->values_len = av2value (aTHX_ vl->type, (AV *)SvRV (*tmp),
 332                                 vl->values, len);
 333
 334                 if (-1 == vl->values_len) {
 335                         sfree (vl->values);
 336                         return -1;
 337                 }
 338         }
 339
 340         if (NULL != (tmp = hv_fetch (hash, "time", 4, 0))) {
 341                 vl->time = (time_t)SvIV (*tmp);
 342         }
 343
 344         if (NULL != (tmp = hv_fetch (hash, "host", 4, 0))) {
 345                 sstrncpy (vl->host, SvPV_nolen (*tmp), sizeof (vl->host));
 346         }
 347         else {
 348                 sstrncpy (vl->host, hostname_g, sizeof (vl->host));
 349         }
 350
 351         if (NULL != (tmp = hv_fetch (hash, "plugin", 6, 0)))
 352                 sstrncpy (vl->plugin, SvPV_nolen (*tmp), sizeof (vl->plugin));
 353
 354         if (NULL != (tmp = hv_fetch (hash, "plugin_instance", 15, 0)))
 355                 sstrncpy (vl->plugin_instance, SvPV_nolen (*tmp),
 356                                 sizeof (vl->plugin_instance));
 357
 358         if (NULL != (tmp = hv_fetch (hash, "type_instance", 13, 0)))
 359                 sstrncpy (vl->type_instance, SvPV_nolen (*tmp),
 360                                 sizeof (vl->type_instance));
 361         return 0;
 362 } /* static int hv2value_list (pTHX_ HV *, value_list_t *) */
 363
 364 static int av2data_set (pTHX_ AV *array, char *name, data_set_t *ds)
 365 {
 366         int len, i;
 367
 368         if ((NULL == array) || (NULL == name) || (NULL == ds))
 369                 return -1;
 370
 371         len = av_len (array);
 372
 373         if (-1 == len) {
 374                 log_err ("av2data_set: Invalid data set.");
 375                 return -1;
 376         }
 377
 378         ds->ds = (data_source_t *)smalloc ((len + 1) * sizeof (data_source_t));
 379         ds->ds_num = len + 1;
 380
 381         for (i = 0; i <= len; ++i) {
 382                 SV **elem = av_fetch (array, i, 0);
 383
 384                 if (NULL == elem) {
 385                         log_err ("av2data_set: Failed to fetch data source %i.", i);
 386                         return -1;
 387                 }
 388
 389                 if (! (SvROK (*elem) && (SVt_PVHV == SvTYPE (SvRV (*elem))))) {
 390                         log_err ("av2data_set: Invalid data source.");
 391                         return -1;
 392                 }
 393
 394                 if (-1 == hv2data_source (aTHX_ (HV *)SvRV (*elem), &ds->ds[i]))
 395                         return -1;
 396
 397                 log_debug ("av2data_set: "
 398                                 "DS.name = \"%s\", DS.type = %i, DS.min = %f, DS.max = %f",
 399                                 ds->ds[i].name, ds->ds[i].type, ds->ds[i].min, ds->ds[i].max);
 400         }
 401
 402         sstrncpy (ds->type, name, sizeof (ds->type));
 403         return 0;
 404 } /* static int av2data_set (pTHX_ AV *, data_set_t *) */
 405
 406 static int data_set2av (pTHX_ data_set_t *ds, AV *array)
 407 {
 408         int i = 0;
 409
 410         if ((NULL == ds) || (NULL == array))
 411                 return -1;
 412
 413         av_extend (array, ds->ds_num);
 414
 415         for (i = 0; i < ds->ds_num; ++i) {
 416                 HV *source = newHV ();
 417
 418                 if (NULL == hv_store (source, "name", 4,
 419                                 newSVpv (ds->ds[i].name, 0), 0))
 420                         return -1;
 421
 422                 if (NULL == hv_store (source, "type", 4, newSViv (ds->ds[i].type), 0))
 423                         return -1;
 424
 425                 if (! isnan (ds->ds[i].min))
 426                         if (NULL == hv_store (source, "min", 3,
 427                                         newSVnv (ds->ds[i].min), 0))
 428                                 return -1;
 429
 430                 if (! isnan (ds->ds[i].max))
 431                         if (NULL == hv_store (source, "max", 3,
 432                                         newSVnv (ds->ds[i].max), 0))
 433                                 return -1;
 434
 435                 if (NULL == av_store (array, i, newRV_noinc ((SV *)source)))
 436                         return -1;
 437         }
 438         return 0;
 439 } /* static int data_set2av (data_set_t *, AV *) */
 440
 441 static int value_list2hv (pTHX_ value_list_t *vl, data_set_t *ds, HV *hash)
 442 {
 443         AV *values = NULL;
 444
 445         int i   = 0;
 446         int len = 0;
 447
 448         if ((NULL == vl) || (NULL == ds) || (NULL == hash))
 449                 return -1;
 450
 451         len = vl->values_len;
 452
 453         if (ds->ds_num < len) {
 454                 log_warn ("value2av: Value length exceeds data set length.");
 455                 len = ds->ds_num;
 456         }
 457
 458         values = newAV ();
 459         av_extend (values, len - 1);
 460
 461         for (i = 0; i < len; ++i) {
 462                 SV *val = NULL;
 463
 464                 if (DS_TYPE_COUNTER == ds->ds[i].type)
 465                         val = newSViv (vl->values[i].counter);
 466                 else
 467                         val = newSVnv (vl->values[i].gauge);
 468
 469                 if (NULL == av_store (values, i, val)) {
 470                         av_undef (values);
 471                         return -1;
 472                 }
 473         }
 474
 475         if (NULL == hv_store (hash, "values", 6, newRV_noinc ((SV *)values), 0))
 476                 return -1;
 477
 478         if (0 != vl->time)
 479                 if (NULL == hv_store (hash, "time", 4, newSViv (vl->time), 0))
 480                         return -1;
 481
 482         if ('\0' != vl->host[0])
 483                 if (NULL == hv_store (hash, "host", 4, newSVpv (vl->host, 0), 0))
 484                         return -1;
 485
 486         if ('\0' != vl->plugin[0])
 487                 if (NULL == hv_store (hash, "plugin", 6, newSVpv (vl->plugin, 0), 0))
 488                         return -1;
 489
 490         if ('\0' != vl->plugin_instance[0])
 491                 if (NULL == hv_store (hash, "plugin_instance", 15,
 492                                 newSVpv (vl->plugin_instance, 0), 0))
 493                         return -1;
 494
 495         if ('\0' != vl->type[0])
 496                 if (NULL == hv_store (hash, "type", 4, newSVpv (vl->type, 0), 0))
 497                         return -1;
 498
 499         if ('\0' != vl->type_instance[0])
 500                 if (NULL == hv_store (hash, "type_instance", 13,
 501                                 newSVpv (vl->type_instance, 0), 0))
 502                         return -1;
 503         return 0;
 504 } /* static int value2av (value_list_t *, data_set_t *, HV *) */
 505
 506 static int notification2hv (pTHX_ notification_t *n, HV *hash)
 507 {
 508         if (NULL == hv_store (hash, "severity", 8, newSViv (n->severity), 0))
 509                 return -1;
 510
 511         if (0 != n->time)
 512                 if (NULL == hv_store (hash, "time", 4, newSViv (n->time), 0))
 513                         return -1;
 514
 515         if ('\0' != *n->message)
 516                 if (NULL == hv_store (hash, "message", 7, newSVpv (n->message, 0), 0))
 517                         return -1;
 518
 519         if ('\0' != *n->host)
 520                 if (NULL == hv_store (hash, "host", 4, newSVpv (n->host, 0), 0))
 521                         return -1;
 522
 523         if ('\0' != *n->plugin)
 524                 if (NULL == hv_store (hash, "plugin", 6, newSVpv (n->plugin, 0), 0))
 525                         return -1;
 526
 527         if ('\0' != *n->plugin_instance)
 528                 if (NULL == hv_store (hash, "plugin_instance", 15,
 529                                 newSVpv (n->plugin_instance, 0), 0))
 530                         return -1;
 531
 532         if ('\0' != *n->type)
 533                 if (NULL == hv_store (hash, "type", 4, newSVpv (n->type, 0), 0))
 534                         return -1;
 535
 536         if ('\0' != *n->type_instance)
 537                 if (NULL == hv_store (hash, "type_instance", 13,
 538                                 newSVpv (n->type_instance, 0), 0))
 539                         return -1;
 540         return 0;
 541 } /* static int notification2hv (notification_t *, HV *) */
 542
 543 static int oconfig_item2hv (pTHX_ oconfig_item_t *ci, HV *hash)
 544 {
 545         int i;
 546
 547         AV *values;
 548         AV *children;
 549
 550         if (NULL == hv_store (hash, "key", 3, newSVpv (ci->key, 0), 0))
 551                 return -1;
 552
 553         values = newAV ();
 554         if (0 < ci->values_num)
 555                 av_extend (values, ci->values_num);
 556
 557         if (NULL == hv_store (hash, "values", 6, newRV_noinc ((SV *)values), 0)) {
 558                 av_clear (values);
 559                 av_undef (values);
 560                 return -1;
 561         }
 562
 563         for (i = 0; i < ci->values_num; ++i) {
 564                 SV *value;
 565
 566                 switch (ci->values[i].type) {
 567                         case OCONFIG_TYPE_STRING:
 568                                 value = newSVpv (ci->values[i].value.string, 0);
 569                                 break;
 570                         case OCONFIG_TYPE_NUMBER:
 571                                 value = newSVnv ((NV)ci->values[i].value.number);
 572                                 break;
 573                         case OCONFIG_TYPE_BOOLEAN:
 574                                 value = ci->values[i].value.boolean ? &PL_sv_yes : &PL_sv_no;
 575                                 break;
 576                         default:
 577                                 log_err ("oconfig_item2hv: Invalid value type %i.",
 578                                                 ci->values[i].type);
 579                                 value = &PL_sv_undef;
 580                 }
 581
 582                 if (NULL == av_store (values, i, value)) {
 583                         sv_free (value);
 584                         return -1;
 585                 }
 586         }
 587
 588         /* ignoring 'parent' member which is uninteresting in this case */
 589
 590         children = newAV ();
 591         if (0 < ci->children_num)
 592                 av_extend (children, ci->children_num);
 593
 594         if (NULL == hv_store (hash, "children", 8, newRV_noinc ((SV *)children), 0)) {
 595                 av_clear (children);
 596                 av_undef (children);
 597                 return -1;
 598         }
 599
 600         for (i = 0; i < ci->children_num; ++i) {
 601                 HV *child = newHV ();
 602
 603                 if (0 != oconfig_item2hv (aTHX_ ci->children + i, child)) {
 604                         hv_clear (child);
 605                         hv_undef (child);
 606                         return -1;
 607                 }
 608
 609                 if (NULL == av_store (children, i, newRV_noinc ((SV *)child))) {
 610                         hv_clear (child);
 611                         hv_undef (child);
 612                         return -1;
 613                 }
 614         }
 615         return 0;
 616 } /* static int oconfig_item2hv (pTHX_ oconfig_item_t *, HV *) */
 617
 618 /*
 619  * Internal functions.
 620  */
 621
 622 static char *get_module_name (char *buf, size_t buf_len, const char *module) {
 623         int status = 0;
 624         if (base_name[0] == '\0')
 625                 status = ssnprintf (buf, buf_len, "%s", module);
 626         else
 627                 status = ssnprintf (buf, buf_len, "%s::%s", base_name, module);
 628         if ((status < 0) || ((unsigned int)status >= buf_len))
 629                 return (NULL);
 630         return (buf);
 631 } /* char *get_module_name */
 632
 633 /*
 634  * Add a plugin's data set definition.
 635  */
 636 static int pplugin_register_data_set (pTHX_ char *name, AV *dataset)
 637 {
 638         int ret = 0;
 639
 640         data_set_t ds;
 641
 642         if ((NULL == name) || (NULL == dataset))
 643                 return -1;
 644
 645         if (0 != av2data_set (aTHX_ dataset, name, &ds))
 646                 return -1;
 647
 648         ret = plugin_register_data_set (&ds);
 649
 650         free (ds.ds);
 651         return ret;
 652 } /* static int pplugin_register_data_set (char *, SV *) */
 653
 654 /*
 655  * Remove a plugin's data set definition.
 656  */
 657 static int pplugin_unregister_data_set (char *name)
 658 {
 659         if (NULL == name)
 660                 return 0;
 661         return plugin_unregister_data_set (name);
 662 } /* static int pplugin_unregister_data_set (char *) */
 663
 664 /*
 665  * Submit the values to the write functions.
 666  */
 667 static int pplugin_dispatch_values (pTHX_ HV *values)
 668 {
 669         value_list_t vl = VALUE_LIST_INIT;
 670
 671         int ret = 0;
 672
 673         if (NULL == values)
 674                 return -1;
 675
 676         if (0 != hv2value_list (aTHX_ values, &vl))
 677                 return -1;
 678
 679         ret = plugin_dispatch_values (&vl);
 680
 681         sfree (vl.values);
 682         return ret;
 683 } /* static int pplugin_dispatch_values (char *, HV *) */
 684
 685 /*
 686  * Dispatch a notification.
 687  *
 688  * notification:
 689  * {
 690  *   severity => $severity,
 691  *   time     => $time,
 692  *   message  => $msg,
 693  *   host     => $host,
 694  *   plugin   => $plugin,
 695  *   type     => $type,
 696  *   plugin_instance => $instance,
 697  *   type_instance   => $type_instance
 698  * }
 699  */
 700 static int pplugin_dispatch_notification (pTHX_ HV *notif)
 701 {
 702         notification_t n;
 703
 704         SV **tmp = NULL;
 705
 706         if (NULL == notif)
 707                 return -1;
 708
 709         memset (&n, 0, sizeof (n));
 710
 711         if (NULL != (tmp = hv_fetch (notif, "severity", 8, 0)))
 712                 n.severity = SvIV (*tmp);
 713         else
 714                 n.severity = NOTIF_FAILURE;
 715
 716         if (NULL != (tmp = hv_fetch (notif, "time", 4, 0)))
 717                 n.time = (time_t)SvIV (*tmp);
 718         else
 719                 n.time = time (NULL);
 720
 721         if (NULL != (tmp = hv_fetch (notif, "message", 7, 0)))
 722                 sstrncpy (n.message, SvPV_nolen (*tmp), sizeof (n.message));
 723
 724         if (NULL != (tmp = hv_fetch (notif, "host", 4, 0)))
 725                 sstrncpy (n.host, SvPV_nolen (*tmp), sizeof (n.host));
 726         else
 727                 sstrncpy (n.host, hostname_g, sizeof (n.host));
 728
 729         if (NULL != (tmp = hv_fetch (notif, "plugin", 6, 0)))
 730                 sstrncpy (n.plugin, SvPV_nolen (*tmp), sizeof (n.plugin));
 731
 732         if (NULL != (tmp = hv_fetch (notif, "plugin_instance", 15, 0)))
 733                 sstrncpy (n.plugin_instance, SvPV_nolen (*tmp),
 734                                 sizeof (n.plugin_instance));
 735
 736         if (NULL != (tmp = hv_fetch (notif, "type", 4, 0)))
 737                 sstrncpy (n.type, SvPV_nolen (*tmp), sizeof (n.type));
 738
 739         if (NULL != (tmp = hv_fetch (notif, "type_instance", 13, 0)))
 740                 sstrncpy (n.type_instance, SvPV_nolen (*tmp), sizeof (n.type_instance));
 741         return plugin_dispatch_notification (&n);
 742 } /* static int pplugin_dispatch_notification (HV *) */
 743
 744 /*
 745  * Call all working functions of the given type.
 746  */
 747 static int pplugin_call_all (pTHX_ int type, ...)
 748 {
 749         int retvals = 0;
 750
 751         va_list ap;
 752         int ret = 0;
 753
 754         dSP;
 755
 756         if ((type < 0) || (type >= PLUGIN_TYPES))
 757                 return -1;
 758
 759         va_start (ap, type);
 760
 761         ENTER;
 762         SAVETMPS;
 763
 764         PUSHMARK (SP);
 765
 766         XPUSHs (sv_2mortal (newSViv ((IV)type)));
 767
 768         if (PLUGIN_WRITE == type) {
 769                 /*
 770                  * $_[0] = $plugin_type;
 771                  *
 772                  * $_[1] =
 773                  * [
 774                  *   {
 775                  *     name => $ds_name,
 776                  *     type => $ds_type,
 777                  *     min  => $ds_min,
 778                  *     max  => $ds_max
 779                  *   },
 780                  *   ...
 781                  * ];
 782                  *
 783                  * $_[2] =
 784                  * {
 785                  *   values => [ $v1, ... ],
 786                  *   time   => $time,
 787                  *   host   => $hostname,
 788                  *   plugin => $plugin,
 789                  *   type   => $type,
 790                  *   plugin_instance => $instance,
 791                  *   type_instance   => $type_instance
 792                  * };
 793                  */
 794                 data_set_t   *ds;
 795                 value_list_t *vl;
 796
 797                 AV *pds = newAV ();
 798                 HV *pvl = newHV ();
 799
 800                 ds = va_arg (ap, data_set_t *);
 801                 vl = va_arg (ap, value_list_t *);
 802
 803                 if (-1 == data_set2av (aTHX_ ds, pds)) {
 804                         av_clear (pds);
 805                         av_undef (pds);
 806                         pds = Nullav;
 807                         ret = -1;
 808                 }
 809
 810                 if (-1 == value_list2hv (aTHX_ vl, ds, pvl)) {
 811                         hv_clear (pvl);
 812                         hv_undef (pvl);
 813                         pvl = Nullhv;
 814                         ret = -1;
 815                 }
 816
 817                 XPUSHs (sv_2mortal (newSVpv (ds->type, 0)));
 818                 XPUSHs (sv_2mortal (newRV_noinc ((SV *)pds)));
 819                 XPUSHs (sv_2mortal (newRV_noinc ((SV *)pvl)));
 820         }
 821         else if (PLUGIN_LOG == type) {
 822                 /*
 823                  * $_[0] = $level;
 824                  *
 825                  * $_[1] = $message;
 826                  */
 827                 XPUSHs (sv_2mortal (newSViv (va_arg (ap, int))));
 828                 XPUSHs (sv_2mortal (newSVpv (va_arg (ap, char *), 0)));
 829         }
 830         else if (PLUGIN_NOTIF == type) {
 831                 /*
 832                  * $_[0] =
 833                  * {
 834                  *   severity => $severity,
 835                  *   time     => $time,
 836                  *   message  => $msg,
 837                  *   host     => $host,
 838                  *   plugin   => $plugin,
 839                  *   type     => $type,
 840                  *   plugin_instance => $instance,
 841                  *   type_instance   => $type_instance
 842                  * };
 843                  */
 844                 notification_t *n;
 845                 HV *notif = newHV ();
 846
 847                 n = va_arg (ap, notification_t *);
 848
 849                 if (-1 == notification2hv (aTHX_ n, notif)) {
 850                         hv_clear (notif);
 851                         hv_undef (notif);
 852                         notif = Nullhv;
 853                         ret = -1;
 854                 }
 855
 856                 XPUSHs (sv_2mortal (newRV_noinc ((SV *)notif)));
 857         }
 858         else if (PLUGIN_FLUSH == type) {
 859                 /*
 860                  * $_[0] = $timeout;
 861                  * $_[1] = $identifier;
 862                  */
 863                 XPUSHs (sv_2mortal (newSViv (va_arg (ap, int))));
 864                 XPUSHs (sv_2mortal (newSVpv (va_arg (ap, char *), 0)));
 865         }
 866
 867         PUTBACK;
 868
 869         retvals = call_pv ("Collectd::plugin_call_all", G_SCALAR);
 870
 871         SPAGAIN;
 872         if (0 < retvals) {
 873                 SV *tmp = POPs;
 874                 if (! SvTRUE (tmp))
 875                         ret = -1;
 876         }
 877
 878         PUTBACK;
 879         FREETMPS;
 880         LEAVE;
 881
 882         va_end (ap);
 883         return ret;
 884 } /* static int pplugin_call_all (int, ...) */
 885
 886 /*
 887  * Exported Perl API.
 888  */
 889
 890 /*
 891  * Collectd::plugin_register_data_set (type, dataset).
 892  *
 893  * type:
 894  *   type of the dataset
 895  *
 896  * dataset:
 897  *   dataset to be registered
 898  */
 899 static XS (Collectd_plugin_register_ds)
 900 {
 901         SV  *data = NULL;
 902         int ret   = 0;
 903
 904         dXSARGS;
 905
 906         if (2 != items) {
 907                 log_err ("Usage: Collectd::plugin_register_data_set(type, dataset)");
 908                 XSRETURN_EMPTY;
 909         }
 910
 911         log_debug ("Collectd::plugin_register_data_set: "
 912                         "type = \"%s\", dataset = \"%s\"",
 913                         SvPV_nolen (ST (0)), SvPV_nolen (ST (1)));
 914
 915         data = ST (1);
 916
 917         if (SvROK (data) && (SVt_PVAV == SvTYPE (SvRV (data)))) {
 918                 ret = pplugin_register_data_set (aTHX_ SvPV_nolen (ST (0)),
 919                                 (AV *)SvRV (data));
 920         }
 921         else {
 922                 log_err ("Collectd::plugin_register_data_set: Invalid data.");
 923                 XSRETURN_EMPTY;
 924         }
 925
 926         if (0 == ret)
 927                 XSRETURN_YES;
 928         else
 929                 XSRETURN_EMPTY;
 930 } /* static XS (Collectd_plugin_register_ds) */
 931
 932 /*
 933  * Collectd::plugin_unregister_data_set (type).
 934  *
 935  * type:
 936  *   type of the dataset
 937  */
 938 static XS (Collectd_plugin_unregister_ds)
 939 {
 940         dXSARGS;
 941
 942         if (1 != items) {
 943                 log_err ("Usage: Collectd::plugin_unregister_data_set(type)");
 944                 XSRETURN_EMPTY;
 945         }
 946
 947         log_debug ("Collectd::plugin_unregister_data_set: type = \"%s\"",
 948                         SvPV_nolen (ST (0)));
 949
 950         if (0 == pplugin_unregister_data_set (SvPV_nolen (ST (0))))
 951                 XSRETURN_YES;
 952         else
 953                 XSRETURN_EMPTY;
 954 } /* static XS (Collectd_plugin_register_ds) */
 955
 956 /*
 957  * Collectd::plugin_dispatch_values (name, values).
 958  *
 959  * name:
 960  *   name of the plugin
 961  *
 962  * values:
 963  *   value list to submit
 964  */
 965 static XS (Collectd_plugin_dispatch_values)
 966 {
 967         SV *values     = NULL;
 968         int values_idx = 0;
 969
 970         int ret = 0;
 971
 972         dXSARGS;
 973
 974         if (2 == items) {
 975                 log_warn ("Collectd::plugin_dispatch_values with two arguments "
 976                                 "is deprecated - pass the type through values->{type}.");
 977                 values_idx = 1;
 978         }
 979         else if (1 != items) {
 980                 log_err ("Usage: Collectd::plugin_dispatch_values(values)");
 981                 XSRETURN_EMPTY;
 982         }
 983
 984         log_debug ("Collectd::plugin_dispatch_values: values=\"%s\"",
 985                         SvPV_nolen (ST (values_idx)));
 986
 987         values = ST (values_idx);
 988
 989         if (! (SvROK (values) && (SVt_PVHV == SvTYPE (SvRV (values))))) {
 990                 log_err ("Collectd::plugin_dispatch_values: Invalid values.");
 991                 XSRETURN_EMPTY;
 992         }
 993
 994         if (((2 == items) && (NULL == ST (0))) || (NULL == values))
 995                 XSRETURN_EMPTY;
 996
 997         if ((2 == items) && (NULL == hv_store ((HV *)SvRV (values), "type", 4,
 998                         newSVsv (ST (0)), 0))) {
 999                 log_err ("Collectd::plugin_dispatch_values: Could not store type.");
1000                 XSRETURN_EMPTY;
1001         }
1002
1003         ret = pplugin_dispatch_values (aTHX_ (HV *)SvRV (values));
1004
1005         if (0 == ret)
1006                 XSRETURN_YES;
1007         else
1008                 XSRETURN_EMPTY;
1009 } /* static XS (Collectd_plugin_dispatch_values) */
1010
1011 /*
1012  * Collectd::_plugin_flush (plugin, timeout, identifier).
1013  *
1014  * plugin:
1015  *   name of the plugin to flush
1016  *
1017  * timeout:
1018  *   timeout to use when flushing the data
1019  *
1020  * identifier:
1021  *   data-set identifier to flush
1022  */
1023 static XS (Collectd__plugin_flush)
1024 {
1025         char *plugin  = NULL;
1026         int   timeout = -1;
1027         char *id      = NULL;
1028
1029         dXSARGS;
1030
1031         if (3 != items) {
1032                 log_err ("Usage: Collectd::_plugin_flush(plugin, timeout, id)");
1033                 XSRETURN_EMPTY;
1034         }
1035
1036         if (SvOK (ST (0)))
1037                 plugin = SvPV_nolen (ST (0));
1038
1039         if (SvOK (ST (1)))
1040                 timeout = (int)SvIV (ST (1));
1041
1042         if (SvOK (ST (2)))
1043                 id = SvPV_nolen (ST (2));
1044
1045         log_debug ("Collectd::_plugin_flush: plugin = \"%s\", timeout = %i, "
1046                         "id = \"%s\"", plugin, timeout, id);
1047
1048         if (0 == plugin_flush (plugin, timeout, id))
1049                 XSRETURN_YES;
1050         else
1051                 XSRETURN_EMPTY;
1052 } /* static XS (Collectd__plugin_flush) */
1053
1054 /*
1055  * Collectd::plugin_dispatch_notification (notif).
1056  *
1057  * notif:
1058  *   notification to dispatch
1059  */
1060 static XS (Collectd_plugin_dispatch_notification)
1061 {
1062         SV *notif = NULL;
1063
1064         int ret = 0;
1065
1066         dXSARGS;
1067
1068         if (1 != items) {
1069                 log_err ("Usage: Collectd::plugin_dispatch_notification(notif)");
1070                 XSRETURN_EMPTY;
1071         }
1072
1073         log_debug ("Collectd::plugin_dispatch_notification: notif = \"%s\"",
1074                         SvPV_nolen (ST (0)));
1075
1076         notif = ST (0);
1077
1078         if (! (SvROK (notif) && (SVt_PVHV == SvTYPE (SvRV (notif))))) {
1079                 log_err ("Collectd::plugin_dispatch_notification: Invalid notif.");
1080                 XSRETURN_EMPTY;
1081         }
1082
1083         ret = pplugin_dispatch_notification (aTHX_ (HV *)SvRV (notif));
1084
1085         if (0 == ret)
1086                 XSRETURN_YES;
1087         else
1088                 XSRETURN_EMPTY;
1089 } /* static XS (Collectd_plugin_dispatch_notification) */
1090
1091 /*
1092  * Collectd::plugin_log (level, message).
1093  *
1094  * level:
1095  *   log level (LOG_DEBUG, ... LOG_ERR)
1096  *
1097  * message:
1098  *   log message
1099  */
1100 static XS (Collectd_plugin_log)
1101 {
1102         dXSARGS;
1103
1104         if (2 != items) {
1105                 log_err ("Usage: Collectd::plugin_log(level, message)");
1106                 XSRETURN_EMPTY;
1107         }
1108
1109         plugin_log (SvIV (ST (0)), "%s", SvPV_nolen (ST (1)));
1110         XSRETURN_YES;
1111 } /* static XS (Collectd_plugin_log) */
1112
1113 /*
1114  * Collectd::call_by_name (...).
1115  *
1116  * Call a Perl sub identified by its name passed through $Collectd::cb_name.
1117  */
1118 static XS (Collectd_call_by_name)
1119 {
1120         SV   *tmp  = NULL;
1121         char *name = NULL;
1122
1123         if (NULL == (tmp = get_sv ("Collectd::cb_name", 0))) {
1124                 sv_setpv (get_sv ("@", 1), "cb_name has not been set");
1125                 CLEAR_STACK_FRAME;
1126                 return;
1127         }
1128
1129         name = SvPV_nolen (tmp);
1130
1131         if (NULL == get_cv (name, 0)) {
1132                 sv_setpvf (get_sv ("@", 1), "unknown callback \"%s\"", name);
1133                 CLEAR_STACK_FRAME;
1134                 return;
1135         }
1136
1137         /* simply pass on the subroutine call without touching the stack,
1138          * thus leaving any arguments and return values in place */
1139         call_pv (name, 0);
1140 } /* static XS (Collectd_call_by_name) */
1141
1142 /*
1143  * collectd's perl interpreter based thread implementation.
1144  *
1145  * This has been inspired by Perl's ithreads introduced in version 5.6.0.
1146  */
1147
1148 /* must be called with perl_threads->mutex locked */
1149 static void c_ithread_destroy (c_ithread_t *ithread)
1150 {
1151         dTHXa (ithread->interp);
1152
1153         assert (NULL != perl_threads);
1154
1155         PERL_SET_CONTEXT (aTHX);
1156         log_debug ("Shutting down Perl interpreter %p...", aTHX);
1157
1158 #if COLLECT_DEBUG
1159         sv_report_used ();
1160
1161         --perl_threads->number_of_threads;
1162 #endif /* COLLECT_DEBUG */
1163
1164         perl_destruct (aTHX);
1165         perl_free (aTHX);
1166
1167         if (NULL == ithread->prev)
1168                 perl_threads->head = ithread->next;
1169         else
1170                 ithread->prev->next = ithread->next;
1171
1172         if (NULL == ithread->next)
1173                 perl_threads->tail = ithread->prev;
1174         else
1175                 ithread->next->prev = ithread->prev;
1176
1177         sfree (ithread);
1178         return;
1179 } /* static void c_ithread_destroy (c_ithread_t *) */
1180
1181 static void c_ithread_destructor (void *arg)
1182 {
1183         c_ithread_t *ithread = (c_ithread_t *)arg;
1184         c_ithread_t *t = NULL;
1185
1186         if (NULL == perl_threads)
1187                 return;
1188
1189         pthread_mutex_lock (&perl_threads->mutex);
1190
1191         for (t = perl_threads->head; NULL != t; t = t->next)
1192                 if (t == ithread)
1193                         break;
1194
1195         /* the ithread no longer exists */
1196         if (NULL == t)
1197                 return;
1198
1199         c_ithread_destroy (ithread);
1200
1201         pthread_mutex_unlock (&perl_threads->mutex);
1202         return;
1203 } /* static void c_ithread_destructor (void *) */
1204
1205 /* must be called with perl_threads->mutex locked */
1206 static c_ithread_t *c_ithread_create (PerlInterpreter *base)
1207 {
1208         c_ithread_t *t = NULL;
1209         dTHXa (NULL);
1210
1211         assert (NULL != perl_threads);
1212
1213         t = (c_ithread_t *)smalloc (sizeof (c_ithread_t));
1214         memset (t, 0, sizeof (c_ithread_t));
1215
1216         t->interp = (NULL == base)
1217                 ? NULL
1218                 : perl_clone (base, CLONEf_KEEP_PTR_TABLE);
1219
1220         aTHX = t->interp;
1221
1222         if ((NULL != base) && (NULL != PL_endav)) {
1223                 av_clear (PL_endav);
1224                 av_undef (PL_endav);
1225                 PL_endav = Nullav;
1226         }
1227
1228 #if COLLECT_DEBUG
1229         ++perl_threads->number_of_threads;
1230 #endif /* COLLECT_DEBUG */
1231
1232         t->next = NULL;
1233
1234         if (NULL == perl_threads->tail) {
1235                 perl_threads->head = t;
1236                 t->prev = NULL;
1237         }
1238         else {
1239                 perl_threads->tail->next = t;
1240                 t->prev = perl_threads->tail;
1241         }
1242
1243         perl_threads->tail = t;
1244
1245         pthread_setspecific (perl_thr_key, (const void *)t);
1246         return t;
1247 } /* static c_ithread_t *c_ithread_create (PerlInterpreter *) */
1248
1249 /*
1250  * Interface to collectd.
1251  */
1252
1253 static int perl_init (void)
1254 {
1255         dTHX;
1256
1257         if (NULL == perl_threads)
1258                 return 0;
1259
1260         if (NULL == aTHX) {
1261                 c_ithread_t *t = NULL;
1262
1263                 pthread_mutex_lock (&perl_threads->mutex);
1264                 t = c_ithread_create (perl_threads->head->interp);
1265                 pthread_mutex_unlock (&perl_threads->mutex);
1266
1267                 aTHX = t->interp;
1268         }
1269
1270         log_debug ("perl_init: c_ithread: interp = %p (active threads: %i)",
1271                         aTHX, perl_threads->number_of_threads);
1272         return pplugin_call_all (aTHX_ PLUGIN_INIT);
1273 } /* static int perl_init (void) */
1274
1275 static int perl_read (void)
1276 {
1277         dTHX;
1278
1279         if (NULL == perl_threads)
1280                 return 0;
1281
1282         if (NULL == aTHX) {
1283                 c_ithread_t *t = NULL;
1284
1285                 pthread_mutex_lock (&perl_threads->mutex);
1286                 t = c_ithread_create (perl_threads->head->interp);
1287                 pthread_mutex_unlock (&perl_threads->mutex);
1288
1289                 aTHX = t->interp;
1290         }
1291
1292         log_debug ("perl_read: c_ithread: interp = %p (active threads: %i)",
1293                         aTHX, perl_threads->number_of_threads);
1294         return pplugin_call_all (aTHX_ PLUGIN_READ);
1295 } /* static int perl_read (void) */
1296
1297 static int perl_write (const data_set_t *ds, const value_list_t *vl)
1298 {
1299         dTHX;
1300
1301         if (NULL == perl_threads)
1302                 return 0;
1303
1304         if (NULL == aTHX) {
1305                 c_ithread_t *t = NULL;
1306
1307                 pthread_mutex_lock (&perl_threads->mutex);
1308                 t = c_ithread_create (perl_threads->head->interp);
1309                 pthread_mutex_unlock (&perl_threads->mutex);
1310
1311                 aTHX = t->interp;
1312         }
1313
1314         log_debug ("perl_write: c_ithread: interp = %p (active threads: %i)",
1315                         aTHX, perl_threads->number_of_threads);
1316         return pplugin_call_all (aTHX_ PLUGIN_WRITE, ds, vl);
1317 } /* static int perl_write (const data_set_t *, const value_list_t *) */
1318
1319 static void perl_log (int level, const char *msg)
1320 {
1321         dTHX;
1322
1323         if (NULL == perl_threads)
1324                 return;
1325
1326         if (NULL == aTHX) {
1327                 c_ithread_t *t = NULL;
1328
1329                 pthread_mutex_lock (&perl_threads->mutex);
1330                 t = c_ithread_create (perl_threads->head->interp);
1331                 pthread_mutex_unlock (&perl_threads->mutex);
1332
1333                 aTHX = t->interp;
1334         }
1335
1336         pplugin_call_all (aTHX_ PLUGIN_LOG, level, msg);
1337         return;
1338 } /* static void perl_log (int, const char *) */
1339
1340 static int perl_notify (const notification_t *notif)
1341 {
1342         dTHX;
1343
1344         if (NULL == perl_threads)
1345                 return 0;
1346
1347         if (NULL == aTHX) {
1348                 c_ithread_t *t = NULL;
1349
1350                 pthread_mutex_lock (&perl_threads->mutex);
1351                 t = c_ithread_create (perl_threads->head->interp);
1352                 pthread_mutex_unlock (&perl_threads->mutex);
1353
1354                 aTHX = t->interp;
1355         }
1356         return pplugin_call_all (aTHX_ PLUGIN_NOTIF, notif);
1357 } /* static int perl_notify (const notification_t *) */
1358
1359 static int perl_flush (int timeout, const char *identifier)
1360 {
1361         dTHX;
1362
1363         if (NULL == perl_threads)
1364                 return 0;
1365
1366         if (NULL == aTHX) {
1367                 c_ithread_t *t = NULL;
1368
1369                 pthread_mutex_lock (&perl_threads->mutex);
1370                 t = c_ithread_create (perl_threads->head->interp);
1371                 pthread_mutex_unlock (&perl_threads->mutex);
1372
1373                 aTHX = t->interp;
1374         }
1375         return pplugin_call_all (aTHX_ PLUGIN_FLUSH, timeout, identifier);
1376 } /* static int perl_flush (const int) */
1377
1378 static int perl_shutdown (void)
1379 {
1380         c_ithread_t *t = NULL;
1381
1382         int ret = 0;
1383
1384         dTHX;
1385
1386         plugin_unregister_complex_config ("perl");
1387
1388         if (NULL == perl_threads)
1389                 return 0;
1390
1391         if (NULL == aTHX) {
1392                 c_ithread_t *t = NULL;
1393
1394                 pthread_mutex_lock (&perl_threads->mutex);
1395                 t = c_ithread_create (perl_threads->head->interp);
1396                 pthread_mutex_unlock (&perl_threads->mutex);
1397
1398                 aTHX = t->interp;
1399         }
1400
1401         log_debug ("perl_shutdown: c_ithread: interp = %p (active threads: %i)",
1402                         aTHX, perl_threads->number_of_threads);
1403
1404         plugin_unregister_log ("perl");
1405         plugin_unregister_notification ("perl");
1406         plugin_unregister_init ("perl");
1407         plugin_unregister_read ("perl");
1408         plugin_unregister_write ("perl");
1409         plugin_unregister_flush ("perl");
1410
1411         ret = pplugin_call_all (aTHX_ PLUGIN_SHUTDOWN);
1412
1413         pthread_mutex_lock (&perl_threads->mutex);
1414         t = perl_threads->tail;
1415
1416         while (NULL != t) {
1417                 c_ithread_t *thr = t;
1418
1419                 /* the pointer has to be advanced before destroying
1420                  * the thread as this will free the memory */
1421                 t = t->prev;
1422
1423                 c_ithread_destroy (thr);
1424         }
1425
1426         pthread_mutex_unlock (&perl_threads->mutex);
1427         pthread_mutex_destroy (&perl_threads->mutex);
1428
1429         sfree (perl_threads);
1430
1431         pthread_key_delete (perl_thr_key);
1432
1433         PERL_SYS_TERM ();
1434
1435         plugin_unregister_shutdown ("perl");
1436         return ret;
1437 } /* static void perl_shutdown (void) */
1438
1439 /*
1440  * Access functions for global variables.
1441  *
1442  * These functions implement the "magic" used to access
1443  * the global variables from Perl.
1444  */
1445
1446 static int g_pv_get (pTHX_ SV *var, MAGIC *mg)
1447 {
1448         char *pv = mg->mg_ptr;
1449         sv_setpv (var, pv);
1450         return 0;
1451 } /* static int g_pv_get (pTHX_ SV *, MAGIC *) */
1452
1453 static int g_pv_set (pTHX_ SV *var, MAGIC *mg)
1454 {
1455         char *pv = mg->mg_ptr;
1456         sstrncpy (pv, SvPV_nolen (var), DATA_MAX_NAME_LEN);
1457         return 0;
1458 } /* static int g_pv_set (pTHX_ SV *, MAGIC *) */
1459
1460 static int g_iv_get (pTHX_ SV *var, MAGIC *mg)
1461 {
1462         int *iv = (int *)mg->mg_ptr;
1463         sv_setiv (var, *iv);
1464         return 0;
1465 } /* static int g_iv_get (pTHX_ SV *, MAGIC *) */
1466
1467 static int g_iv_set (pTHX_ SV *var, MAGIC *mg)
1468 {
1469         int *iv = (int *)mg->mg_ptr;
1470         *iv = (int)SvIV (var);
1471         return 0;
1472 } /* static int g_iv_set (pTHX_ SV *, MAGIC *) */
1473
1474 static MGVTBL g_pv_vtbl = { g_pv_get, g_pv_set, NULL, NULL, NULL, NULL, NULL };
1475 static MGVTBL g_iv_vtbl = { g_iv_get, g_iv_set, NULL, NULL, NULL, NULL, NULL };
1476
1477 /* bootstrap the Collectd module */
1478 static void xs_init (pTHX)
1479 {
1480         HV   *stash = NULL;
1481         SV   *tmp   = NULL;
1482         char *file  = __FILE__;
1483
1484         int i = 0;
1485
1486         dXSUB_SYS;
1487
1488         /* enable usage of Perl modules using shared libraries */
1489         newXS ("DynaLoader::boot_DynaLoader", boot_DynaLoader, file);
1490
1491         /* register API */
1492         for (i = 0; NULL != api[i].f; ++i)
1493                 newXS (api[i].name, api[i].f, file);
1494
1495         stash = gv_stashpv ("Collectd", 1);
1496
1497         /* export "constants" */
1498         for (i = 0; '\0' != constants[i].name[0]; ++i)
1499                 newCONSTSUB (stash, constants[i].name, newSViv (constants[i].value));
1500
1501         /* export global variables
1502          * by adding "magic" to the SV's representing the globale variables
1503          * perl is able to automagically call the get/set function when
1504          * accessing any such variable (this is basically the same as using
1505          * tie() in Perl) */
1506         /* global strings */
1507         for (i = 0; '\0' != g_strings[i].name[0]; ++i) {
1508                 tmp = get_sv (g_strings[i].name, 1);
1509                 sv_magicext (tmp, NULL, PERL_MAGIC_ext, &g_pv_vtbl,
1510                                 g_strings[i].var, 0);
1511         }
1512
1513         /* global integers */
1514         for (i = 0; '\0' != g_integers[i].name[0]; ++i) {
1515                 tmp = get_sv (g_integers[i].name, 1);
1516                 sv_magicext (tmp, NULL, PERL_MAGIC_ext, &g_iv_vtbl,
1517                                 (char *)g_integers[i].var, 0);
1518         }
1519         return;
1520 } /* static void xs_init (pTHX) */
1521
1522 /* Initialize the global Perl interpreter. */
1523 static int init_pi (int argc, char **argv)
1524 {
1525         dTHXa (NULL);
1526
1527         if (NULL != perl_threads)
1528                 return 0;
1529
1530         log_info ("Initializing Perl interpreter...");
1531 #if COLLECT_DEBUG
1532         {
1533                 int i = 0;
1534
1535                 for (i = 0; i < argc; ++i)
1536                         log_debug ("argv[%i] = \"%s\"", i, argv[i]);
1537         }
1538 #endif /* COLLECT_DEBUG */
1539
1540         if (0 != pthread_key_create (&perl_thr_key, c_ithread_destructor)) {
1541                 log_err ("init_pi: pthread_key_create failed");
1542
1543                 /* this must not happen - cowardly giving up if it does */
1544                 return -1;
1545         }
1546
1547 #ifdef __FreeBSD__
1548         /* On FreeBSD, PERL_SYS_INIT3 expands to some expression which
1549          * triggers a "value computed is not used" warning by gcc. */
1550         (void)
1551 #endif
1552         PERL_SYS_INIT3 (&argc, &argv, &environ);
1553
1554         perl_threads = (c_ithread_list_t *)smalloc (sizeof (c_ithread_list_t));
1555         memset (perl_threads, 0, sizeof (c_ithread_list_t));
1556
1557         pthread_mutex_init (&perl_threads->mutex, NULL);
1558         /* locking the mutex should not be necessary at this point
1559          * but let's just do it for the sake of completeness */
1560         pthread_mutex_lock (&perl_threads->mutex);
1561
1562         perl_threads->head = c_ithread_create (NULL);
1563         perl_threads->tail = perl_threads->head;
1564
1565         if (NULL == (perl_threads->head->interp = perl_alloc ())) {
1566                 log_err ("init_pi: Not enough memory.");
1567                 exit (3);
1568         }
1569
1570         aTHX = perl_threads->head->interp;
1571         pthread_mutex_unlock (&perl_threads->mutex);
1572
1573         perl_construct (aTHX);
1574
1575         PL_exit_flags |= PERL_EXIT_DESTRUCT_END;
1576
1577         if (0 != perl_parse (aTHX_ xs_init, argc, argv, NULL)) {
1578                 SV *err = get_sv ("@", 1);
1579                 log_err ("init_pi: Unable to bootstrap Collectd: %s",
1580                                 SvPV_nolen (err));
1581
1582                 perl_destruct (perl_threads->head->interp);
1583                 perl_free (perl_threads->head->interp);
1584                 sfree (perl_threads);
1585
1586                 pthread_key_delete (perl_thr_key);
1587                 return -1;
1588         }
1589
1590         /* Set $0 to "collectd" because perl_parse() has to set it to "-e". */
1591         sv_setpv (get_sv ("0", 0), "collectd");
1592
1593         perl_run (aTHX);
1594
1595         plugin_register_log ("perl", perl_log);
1596         plugin_register_notification ("perl", perl_notify);
1597         plugin_register_init ("perl", perl_init);
1598
1599         plugin_register_read ("perl", perl_read);
1600
1601         plugin_register_write ("perl", perl_write);
1602         plugin_register_flush ("perl", perl_flush);
1603         plugin_register_shutdown ("perl", perl_shutdown);
1604         return 0;
1605 } /* static int init_pi (const char **, const int) */
1606
1607 /*
1608  * LoadPlugin "<Plugin>"
1609  */
1610 static int perl_config_loadplugin (pTHX_ oconfig_item_t *ci)
1611 {
1612         char module_name[DATA_MAX_NAME_LEN];
1613
1614         char *value = NULL;
1615
1616         if ((0 != ci->children_num) || (1 != ci->values_num)
1617                         || (OCONFIG_TYPE_STRING != ci->values[0].type)) {
1618                 log_err ("LoadPlugin expects a single string argument.");
1619                 return 1;
1620         }
1621
1622         value = ci->values[0].value.string;
1623
1624         if (NULL == get_module_name (module_name, sizeof (module_name), value)) {
1625                 log_err ("Invalid module name %s", value);
1626                 return (1);
1627         }
1628
1629         if (0 != init_pi (perl_argc, perl_argv))
1630                 return -1;
1631
1632         assert (NULL != perl_threads);
1633         assert (NULL != perl_threads->head);
1634
1635         aTHX = perl_threads->head->interp;
1636
1637         log_debug ("perl_config: loading perl plugin \"%s\"", value);
1638         load_module (PERL_LOADMOD_NOIMPORT,
1639                         newSVpv (module_name, strlen (module_name)), Nullsv);
1640         return 0;
1641 } /* static int perl_config_loadplugin (oconfig_item_it *) */
1642
1643 /*
1644  * BaseName "<Name>"
1645  */
1646 static int perl_config_basename (pTHX_ oconfig_item_t *ci)
1647 {
1648         char *value = NULL;
1649
1650         if ((0 != ci->children_num) || (1 != ci->values_num)
1651                         || (OCONFIG_TYPE_STRING != ci->values[0].type)) {
1652                 log_err ("BaseName expects a single string argument.");
1653                 return 1;
1654         }
1655
1656         value = ci->values[0].value.string;
1657
1658         log_debug ("perl_config: Setting plugin basename to \"%s\"", value);
1659         sstrncpy (base_name, value, sizeof (base_name));
1660         return 0;
1661 } /* static int perl_config_basename (oconfig_item_it *) */
1662
1663 /*
1664  * EnableDebugger "<Package>"|""
1665  */
1666 static int perl_config_enabledebugger (pTHX_ oconfig_item_t *ci)
1667 {
1668         char *value = NULL;
1669
1670         if ((0 != ci->children_num) || (1 != ci->values_num)
1671                         || (OCONFIG_TYPE_STRING != ci->values[0].type)) {
1672                 log_err ("EnableDebugger expects a single string argument.");
1673                 return 1;
1674         }
1675
1676         if (NULL != perl_threads) {
1677                 log_warn ("EnableDebugger has no effects if used after LoadPlugin.");
1678                 return 1;
1679         }
1680
1681         value = ci->values[0].value.string;
1682
1683         perl_argv = (char **)realloc (perl_argv,
1684                         (++perl_argc + 1) * sizeof (char *));
1685
1686         if (NULL == perl_argv) {
1687                 log_err ("perl_config: Not enough memory.");
1688                 exit (3);
1689         }
1690
1691         if ('\0' == value[0]) {
1692                 perl_argv[perl_argc - 1] = "-d";
1693         }
1694         else {
1695                 perl_argv[perl_argc - 1] = (char *)smalloc (strlen (value) + 4);
1696                 sstrncpy (perl_argv[perl_argc - 1], "-d:", 4);
1697                 sstrncpy (perl_argv[perl_argc - 1] + 3, value, strlen (value) + 1);
1698         }
1699
1700         perl_argv[perl_argc] = NULL;
1701         return 0;
1702 } /* static int perl_config_enabledebugger (oconfig_item_it *) */
1703
1704 /*
1705  * IncludeDir "<Dir>"
1706  */
1707 static int perl_config_includedir (pTHX_ oconfig_item_t *ci)
1708 {
1709         char *value = NULL;
1710
1711         if ((0 != ci->children_num) || (1 != ci->values_num)
1712                         || (OCONFIG_TYPE_STRING != ci->values[0].type)) {
1713                 log_err ("IncludeDir expects a single string argument.");
1714                 return 1;
1715         }
1716
1717         value = ci->values[0].value.string;
1718
1719         if (NULL == aTHX) {
1720                 perl_argv = (char **)realloc (perl_argv,
1721                                 (++perl_argc + 1) * sizeof (char *));
1722
1723                 if (NULL == perl_argv) {
1724                         log_err ("perl_config: Not enough memory.");
1725                         exit (3);
1726                 }
1727
1728                 perl_argv[perl_argc - 1] = (char *)smalloc (strlen (value) + 3);
1729                 sstrncpy(perl_argv[perl_argc - 1], "-I", 3);
1730                 sstrncpy(perl_argv[perl_argc - 1] + 2, value, strlen (value) + 1);
1731
1732                 perl_argv[perl_argc] = NULL;
1733         }
1734         else {
1735                 /* prepend the directory to @INC */
1736                 av_unshift (GvAVn (PL_incgv), 1);
1737                 av_store (GvAVn (PL_incgv), 0, newSVpv (value, strlen (value)));
1738         }
1739         return 0;
1740 } /* static int perl_config_includedir (oconfig_item_it *) */
1741
1742 /*
1743  * <Plugin> block
1744  */
1745 static int perl_config_plugin (pTHX_ oconfig_item_t *ci)
1746 {
1747         int retvals = 0;
1748         int ret     = 0;
1749
1750         char *plugin;
1751         HV   *config;
1752
1753         dSP;
1754
1755         if ((1 != ci->values_num) || (OCONFIG_TYPE_STRING != ci->values[0].type)) {
1756                 log_err ("LoadPlugin expects a single string argument.");
1757                 return 1;
1758         }
1759
1760         plugin = ci->values[0].value.string;
1761         config = newHV ();
1762
1763         if (0 != oconfig_item2hv (aTHX_ ci, config)) {
1764                 hv_clear (config);
1765                 hv_undef (config);
1766
1767                 log_err ("Unable to convert configuration to a Perl hash value.");
1768                 config = Nullhv;
1769         }
1770
1771         ENTER;
1772         SAVETMPS;
1773
1774         PUSHMARK (SP);
1775
1776         XPUSHs (sv_2mortal (newSVpv (plugin, 0)));
1777         XPUSHs (sv_2mortal (newRV_noinc ((SV *)config)));
1778
1779         PUTBACK;
1780
1781         retvals = call_pv ("Collectd::_plugin_dispatch_config", G_SCALAR);
1782
1783         SPAGAIN;
1784         if (0 < retvals) {
1785                 SV *tmp = POPs;
1786                 if (! SvTRUE (tmp))
1787                         ret = 1;
1788         }
1789         else
1790                 ret = 1;
1791
1792         PUTBACK;
1793         FREETMPS;
1794         LEAVE;
1795         return ret;
1796 } /* static int perl_config_plugin (oconfig_item_it *) */
1797
1798 static int perl_config (oconfig_item_t *ci)
1799 {
1800         int status = 0;
1801         int i = 0;
1802
1803         dTHXa (NULL);
1804
1805         for (i = 0; i < ci->children_num; ++i) {
1806                 oconfig_item_t *c = ci->children + i;
1807                 int current_status = 0;
1808
1809                 if (NULL != perl_threads)
1810                         aTHX = PERL_GET_CONTEXT;
1811
1812                 if (0 == strcasecmp (c->key, "LoadPlugin"))
1813                         current_status = perl_config_loadplugin (aTHX_ c);
1814                 else if (0 == strcasecmp (c->key, "BaseName"))
1815                         current_status = perl_config_basename (aTHX_ c);
1816                 else if (0 == strcasecmp (c->key, "EnableDebugger"))
1817                         current_status = perl_config_enabledebugger (aTHX_ c);
1818                 else if (0 == strcasecmp (c->key, "IncludeDir"))
1819                         current_status = perl_config_includedir (aTHX_ c);
1820                 else if (0 == strcasecmp (c->key, "Plugin"))
1821                         current_status = perl_config_plugin (aTHX_ c);
1822                 else
1823                 {
1824                         log_warn ("Ignoring unknown config key \"%s\".", c->key);
1825                         current_status = 0;
1826                 }
1827
1828                 /* fatal error - it's up to perl_config_* to clean up */
1829                 if (0 > current_status) {
1830                         log_err ("Configuration failed with a fatal error - "
1831                                         "plugin disabled!");
1832                         return current_status;
1833                 }
1834
1835                 status += current_status;
1836         }
1837         return status;
1838 } /* static int perl_config (oconfig_item_t *) */
1839
1840 void module_register (void)
1841 {
1842         perl_argc = 4;
1843         perl_argv = (char **)smalloc ((perl_argc + 1) * sizeof (char *));
1844
1845         /* default options for the Perl interpreter */
1846         perl_argv[0] = "";
1847         perl_argv[1] = "-MCollectd";
1848         perl_argv[2] = "-e";
1849         perl_argv[3] = "1";
1850         perl_argv[4] = NULL;
1851
1852         plugin_register_complex_config ("perl", perl_config);
1853         return;
1854 } /* void module_register (void) */
1855
1856 /* vim: set sw=4 ts=4 tw=78 noexpandtab : */
1857