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 /* do not automatically get the thread specific perl interpreter */
  28 #define PERL_NO_GET_CONTEXT
  29
  30 #include "collectd.h"
  31
  32 #include "configfile.h"
  33
  34 #include <EXTERN.h>
  35 #include <perl.h>
  36
  37 #include <XSUB.h>
  38
  39 /* Some versions of Perl define their own version of DEBUG... :-/ */
  40 #ifdef DEBUG
  41 # undef DEBUG
  42 #endif /* DEBUG */
  43
  44 /* ... while we want the definition found in plugin.h. */
  45 #include "plugin.h"
  46 #include "common.h"
  47
  48 #include <pthread.h>
  49
  50 #if !defined(USE_ITHREADS)
  51 # error "Perl does not support ithreads!"
  52 #endif /* !defined(USE_ITHREADS) */
  53
  54 #define PLUGIN_INIT     0
  55 #define PLUGIN_READ     1
  56 #define PLUGIN_WRITE    2
  57 #define PLUGIN_SHUTDOWN 3
  58 #define PLUGIN_LOG      4
  59
  60 #define PLUGIN_TYPES    5
  61
  62 #define PLUGIN_DATASET  255
  63
  64 #define log_debug(...) DEBUG ("perl: " __VA_ARGS__)
  65 #define log_info(...) INFO ("perl: " __VA_ARGS__)
  66 #define log_warn(...) WARNING ("perl: " __VA_ARGS__)
  67 #define log_err(...) ERROR ("perl: " __VA_ARGS__)
  68
  69 /* this is defined in DynaLoader.a */
  70 void boot_DynaLoader (PerlInterpreter *, CV *);
  71
  72 static XS (Collectd_plugin_register_ds);
  73 static XS (Collectd_plugin_unregister_ds);
  74 static XS (Collectd_plugin_dispatch_values);
  75 static XS (Collectd_plugin_log);
  76
  77 /*
  78  * private data types
  79  */
  80
  81 typedef struct c_ithread_s {
  82         /* the thread's Perl interpreter */
  83         PerlInterpreter *interp;
  84
  85         /* double linked list of threads */
  86         struct c_ithread_s *prev;
  87         struct c_ithread_s *next;
  88 } c_ithread_t;
  89
  90 typedef struct {
  91         c_ithread_t *head;
  92         c_ithread_t *tail;
  93
  94 #if COLLECT_DEBUG
  95         /* some usage stats */
  96         int number_of_threads;
  97 #endif /* COLLECT_DEBUG */
  98
  99         pthread_mutex_t mutex;
 100 } c_ithread_list_t;
 101
 102 /*
 103  * private variables
 104  */
 105
 106 /* if perl_threads != NULL perl_threads->head must
 107  * point to the "base" thread */
 108 static c_ithread_list_t *perl_threads = NULL;
 109
 110 static int    perl_argc = 0;
 111 static char **perl_argv = NULL;
 112
 113 static char base_name[DATA_MAX_NAME_LEN] = "";
 114
 115 static struct {
 116         char name[64];
 117         XS ((*f));
 118 } api[] =
 119 {
 120         { "Collectd::plugin_register_data_set",   Collectd_plugin_register_ds },
 121         { "Collectd::plugin_unregister_data_set", Collectd_plugin_unregister_ds },
 122         { "Collectd::plugin_dispatch_values",     Collectd_plugin_dispatch_values },
 123         { "Collectd::plugin_log",                 Collectd_plugin_log },
 124         { "", NULL }
 125 };
 126
 127 struct {
 128         char name[64];
 129         int  value;
 130 } constants[] =
 131 {
 132         { "Collectd::TYPE_INIT",       PLUGIN_INIT },
 133         { "Collectd::TYPE_READ",       PLUGIN_READ },
 134         { "Collectd::TYPE_WRITE",      PLUGIN_WRITE },
 135         { "Collectd::TYPE_SHUTDOWN",   PLUGIN_SHUTDOWN },
 136         { "Collectd::TYPE_LOG",        PLUGIN_LOG },
 137         { "Collectd::TYPE_DATASET",    PLUGIN_DATASET },
 138         { "Collectd::DS_TYPE_COUNTER", DS_TYPE_COUNTER },
 139         { "Collectd::DS_TYPE_GAUGE",   DS_TYPE_GAUGE },
 140         { "Collectd::LOG_ERR",         LOG_ERR },
 141         { "Collectd::LOG_WARNING",     LOG_WARNING },
 142         { "Collectd::LOG_NOTICE",      LOG_NOTICE },
 143         { "Collectd::LOG_INFO",        LOG_INFO },
 144         { "Collectd::LOG_DEBUG",       LOG_DEBUG },
 145         { "", 0 }
 146 };
 147
 148 /*
 149  * Helper functions for data type conversion.
 150  */
 151
 152 /*
 153  * data source:
 154  * [
 155  *   {
 156  *     name => $ds_name,
 157  *     type => $ds_type,
 158  *     min  => $ds_min,
 159  *     max  => $ds_max
 160  *   },
 161  *   ...
 162  * ]
 163  */
 164 static int hv2data_source (pTHX_ HV *hash, data_source_t *ds)
 165 {
 166         SV **tmp = NULL;
 167
 168         if ((NULL == hash) || (NULL == ds))
 169                 return -1;
 170
 171         if (NULL != (tmp = hv_fetch (hash, "name", 4, 0))) {
 172                 strncpy (ds->name, SvPV_nolen (*tmp), DATA_MAX_NAME_LEN);
 173                 ds->name[DATA_MAX_NAME_LEN - 1] = '\0';
 174         }
 175         else {
 176                 log_err ("hv2data_source: No DS name given.");
 177                 return -1;
 178         }
 179
 180         if (NULL != (tmp = hv_fetch (hash, "type", 4, 0))) {
 181                 ds->type = SvIV (*tmp);
 182
 183                 if ((DS_TYPE_COUNTER != ds->type) && (DS_TYPE_GAUGE != ds->type)) {
 184                         log_err ("hv2data_source: Invalid DS type.");
 185                         return -1;
 186                 }
 187         }
 188         else {
 189                 ds->type = DS_TYPE_COUNTER;
 190         }
 191
 192         if (NULL != (tmp = hv_fetch (hash, "min", 3, 0)))
 193                 ds->min = SvNV (*tmp);
 194         else
 195                 ds->min = NAN;
 196
 197         if (NULL != (tmp = hv_fetch (hash, "max", 3, 0)))
 198                 ds->max = SvNV (*tmp);
 199         else
 200                 ds->max = NAN;
 201         return 0;
 202 } /* static data_source_t *hv2data_source (HV *) */
 203
 204 static int av2value (pTHX_ char *name, AV *array, value_t *value, int len)
 205 {
 206         const data_set_t *ds;
 207
 208         int i = 0;
 209
 210         if ((NULL == name) || (NULL == array) || (NULL == value))
 211                 return -1;
 212
 213         if (av_len (array) < len - 1)
 214                 len = av_len (array) + 1;
 215
 216         if (0 >= len)
 217                 return -1;
 218
 219         ds = plugin_get_ds (name);
 220         if (NULL == ds) {
 221                 log_err ("av2value: Unknown dataset \"%s\"", name);
 222                 return -1;
 223         }
 224
 225         if (ds->ds_num < len) {
 226                 log_warn ("av2value: Value length exceeds data set length.");
 227                 len = ds->ds_num;
 228         }
 229
 230         for (i = 0; i < len; ++i) {
 231                 SV **tmp = av_fetch (array, i, 0);
 232
 233                 if (NULL != tmp) {
 234                         if (DS_TYPE_COUNTER == ds->ds[i].type)
 235                                 value[i].counter = SvIV (*tmp);
 236                         else
 237                                 value[i].gauge = SvNV (*tmp);
 238                 }
 239                 else {
 240                         return -1;
 241                 }
 242         }
 243         return len;
 244 } /* static int av2value (char *, AV *, value_t *, int) */
 245
 246 static int data_set2av (pTHX_ data_set_t *ds, AV *array)
 247 {
 248         int i = 0;
 249
 250         if ((NULL == ds) || (NULL == array))
 251                 return -1;
 252
 253         av_extend (array, ds->ds_num);
 254
 255         for (i = 0; i < ds->ds_num; ++i) {
 256                 HV *source = newHV ();
 257
 258                 if (NULL == hv_store (source, "name", 4,
 259                                 newSVpv (ds->ds[i].name, 0), 0))
 260                         return -1;
 261
 262                 if (NULL == hv_store (source, "type", 4, newSViv (ds->ds[i].type), 0))
 263                         return -1;
 264
 265                 if (! isnan (ds->ds[i].min))
 266                         if (NULL == hv_store (source, "min", 3,
 267                                         newSVnv (ds->ds[i].min), 0))
 268                                 return -1;
 269
 270                 if (! isnan (ds->ds[i].max))
 271                         if (NULL == hv_store (source, "max", 3,
 272                                         newSVnv (ds->ds[i].max), 0))
 273                                 return -1;
 274
 275                 if (NULL == av_store (array, i, newRV_noinc ((SV *)source)))
 276                         return -1;
 277         }
 278         return 0;
 279 } /* static int data_set2av (data_set_t *, AV *) */
 280
 281 static int value_list2hv (pTHX_ value_list_t *vl, data_set_t *ds, HV *hash)
 282 {
 283         AV *values = NULL;
 284
 285         int i   = 0;
 286         int len = 0;
 287
 288         if ((NULL == vl) || (NULL == ds) || (NULL == hash))
 289                 return -1;
 290
 291         len = vl->values_len;
 292
 293         if (ds->ds_num < len) {
 294                 log_warn ("value2av: Value length exceeds data set length.");
 295                 len = ds->ds_num;
 296         }
 297
 298         values = newAV ();
 299         av_extend (values, len - 1);
 300
 301         for (i = 0; i < len; ++i) {
 302                 SV *val = NULL;
 303
 304                 if (DS_TYPE_COUNTER == ds->ds[i].type)
 305                         val = newSViv (vl->values[i].counter);
 306                 else
 307                         val = newSVnv (vl->values[i].gauge);
 308
 309                 if (NULL == av_store (values, i, val)) {
 310                         av_undef (values);
 311                         return -1;
 312                 }
 313         }
 314
 315         if (NULL == hv_store (hash, "values", 6, newRV_noinc ((SV *)values), 0))
 316                 return -1;
 317
 318         if (0 != vl->time)
 319                 if (NULL == hv_store (hash, "time", 4, newSViv (vl->time), 0))
 320                         return -1;
 321
 322         if ('\0' != vl->host[0])
 323                 if (NULL == hv_store (hash, "host", 4, newSVpv (vl->host, 0), 0))
 324                         return -1;
 325
 326         if ('\0' != vl->plugin[0])
 327                 if (NULL == hv_store (hash, "plugin", 6, newSVpv (vl->plugin, 0), 0))
 328                         return -1;
 329
 330         if ('\0' != vl->plugin_instance[0])
 331                 if (NULL == hv_store (hash, "plugin_instance", 15,
 332                                 newSVpv (vl->plugin_instance, 0), 0))
 333                         return -1;
 334
 335         if ('\0' != vl->type_instance[0])
 336                 if (NULL == hv_store (hash, "type_instance", 13,
 337                                 newSVpv (vl->type_instance, 0), 0))
 338                         return -1;
 339         return 0;
 340 } /* static int value2av (value_list_t *, data_set_t *, HV *) */
 341
 342 /*
 343  * Internal functions.
 344  */
 345
 346 static char *get_module_name (char *buf, size_t buf_len, const char *module) {
 347         int status = 0;
 348         if (base_name[0] == '\0')
 349                 status = snprintf (buf, buf_len, "%s", module);
 350         else
 351                 status = snprintf (buf, buf_len, "%s::%s", base_name, module);
 352         if ((status < 0) || (status >= buf_len))
 353                 return (NULL);
 354         buf[buf_len - 1] = '\0';
 355         return (buf);
 356 } /* char *get_module_name */
 357
 358 /*
 359  * Add a plugin's data set definition.
 360  */
 361 static int pplugin_register_data_set (pTHX_ char *name, AV *dataset)
 362 {
 363         int len = -1;
 364         int i   = 0;
 365
 366         data_source_t *ds  = NULL;
 367         data_set_t    *set = NULL;
 368
 369         if ((NULL == name) || (NULL == dataset))
 370                 return -1;
 371
 372         len = av_len (dataset);
 373
 374         if (-1 == len)
 375                 return -1;
 376
 377         ds  = (data_source_t *)smalloc ((len + 1) * sizeof (data_source_t));
 378         set = (data_set_t *)smalloc (sizeof (data_set_t));
 379
 380         for (i = 0; i <= len; ++i) {
 381                 SV **elem = av_fetch (dataset, i, 0);
 382
 383                 if (NULL == elem)
 384                         return -1;
 385
 386                 if (! (SvROK (*elem) && (SVt_PVHV == SvTYPE (SvRV (*elem))))) {
 387                         log_err ("pplugin_register_data_set: Invalid data source.");
 388                         return -1;
 389                 }
 390
 391                 if (-1 == hv2data_source (aTHX_ (HV *)SvRV (*elem), &ds[i]))
 392                         return -1;
 393
 394                 log_debug ("pplugin_register_data_set: "
 395                                 "DS.name = \"%s\", DS.type = %i, DS.min = %f, DS.max = %f",
 396                                 ds[i].name, ds[i].type, ds[i].min, ds[i].max);
 397         }
 398
 399         strncpy (set->type, name, DATA_MAX_NAME_LEN);
 400         set->type[DATA_MAX_NAME_LEN - 1] = '\0';
 401
 402         set->ds_num = len + 1;
 403         set->ds = ds;
 404         return plugin_register_data_set (set);
 405 } /* static int pplugin_register_data_set (char *, SV *) */
 406
 407 /*
 408  * Remove a plugin's data set definition.
 409  */
 410 static int pplugin_unregister_data_set (char *name)
 411 {
 412         if (NULL == name)
 413                 return 0;
 414         return plugin_unregister_data_set (name);
 415 } /* static int pplugin_unregister_data_set (char *) */
 416
 417 /*
 418  * Submit the values to the write functions.
 419  *
 420  * value list:
 421  * {
 422  *   values => [ @values ],
 423  *   time   => $time,
 424  *   host   => $host,
 425  *   plugin => $plugin,
 426  *   plugin_instance => $pinstance,
 427  *   type_instance   => $tinstance,
 428  * }
 429  */
 430 static int pplugin_dispatch_values (pTHX_ char *name, HV *values)
 431 {
 432         value_list_t list = VALUE_LIST_INIT;
 433         value_t      *val = NULL;
 434
 435         SV **tmp = NULL;
 436
 437         int ret = 0;
 438
 439         if ((NULL == name) || (NULL == values))
 440                 return -1;
 441
 442         if ((NULL == (tmp = hv_fetch (values, "values", 6, 0)))
 443                         || (! (SvROK (*tmp) && (SVt_PVAV == SvTYPE (SvRV (*tmp)))))) {
 444                 log_err ("pplugin_dispatch_values: No valid values given.");
 445                 return -1;
 446         }
 447
 448         {
 449                 AV  *array = (AV *)SvRV (*tmp);
 450                 int len    = av_len (array) + 1;
 451
 452                 if (len <= 0)
 453                         return -1;
 454
 455                 val = (value_t *)smalloc (len * sizeof (value_t));
 456
 457                 list.values_len = av2value (aTHX_ name, (AV *)SvRV (*tmp), val, len);
 458                 list.values = val;
 459
 460                 if (-1 == list.values_len) {
 461                         sfree (val);
 462                         return -1;
 463                 }
 464         }
 465
 466         if (NULL != (tmp = hv_fetch (values, "time", 4, 0))) {
 467                 list.time = (time_t)SvIV (*tmp);
 468         }
 469         else {
 470                 list.time = time (NULL);
 471         }
 472
 473         if (NULL != (tmp = hv_fetch (values, "host", 4, 0))) {
 474                 strncpy (list.host, SvPV_nolen (*tmp), DATA_MAX_NAME_LEN);
 475                 list.host[DATA_MAX_NAME_LEN - 1] = '\0';
 476         }
 477         else {
 478                 strcpy (list.host, hostname_g);
 479         }
 480
 481         if (NULL != (tmp = hv_fetch (values, "plugin", 6, 0))) {
 482                 strncpy (list.plugin, SvPV_nolen (*tmp), DATA_MAX_NAME_LEN);
 483                 list.plugin[DATA_MAX_NAME_LEN - 1] = '\0';
 484         }
 485
 486         if (NULL != (tmp = hv_fetch (values,
 487                         "plugin_instance", 15, 0))) {
 488                 strncpy (list.plugin_instance, SvPV_nolen (*tmp), DATA_MAX_NAME_LEN);
 489                 list.plugin_instance[DATA_MAX_NAME_LEN - 1] = '\0';
 490         }
 491
 492         if (NULL != (tmp = hv_fetch (values, "type_instance", 13, 0))) {
 493                 strncpy (list.type_instance, SvPV_nolen (*tmp), DATA_MAX_NAME_LEN);
 494                 list.type_instance[DATA_MAX_NAME_LEN - 1] = '\0';
 495         }
 496
 497         ret = plugin_dispatch_values (name, &list);
 498
 499         sfree (val);
 500         return ret;
 501 } /* static int pplugin_dispatch_values (char *, HV *) */
 502
 503 /*
 504  * Call all working functions of the given type.
 505  */
 506 static int pplugin_call_all (pTHX_ int type, ...)
 507 {
 508         int retvals = 0;
 509
 510         va_list ap;
 511         int ret = 0;
 512
 513         dSP;
 514
 515         if ((type < 0) || (type >= PLUGIN_TYPES))
 516                 return -1;
 517
 518         va_start (ap, type);
 519
 520         ENTER;
 521         SAVETMPS;
 522
 523         PUSHMARK (SP);
 524
 525         XPUSHs (sv_2mortal (newSViv ((IV)type)));
 526
 527         if (PLUGIN_WRITE == type) {
 528                 /*
 529                  * $_[0] = $plugin_type;
 530                  *
 531                  * $_[1] =
 532                  * [
 533                  *   {
 534                  *     name => $ds_name,
 535                  *     type => $ds_type,
 536                  *     min  => $ds_min,
 537                  *     max  => $ds_max
 538                  *   },
 539                  *   ...
 540                  * ];
 541                  *
 542                  * $_[2] =
 543                  * {
 544                  *   values => [ $v1, ... ],
 545                  *   time   => $time,
 546                  *   host   => $hostname,
 547                  *   plugin => $plugin,
 548                  *   plugin_instance => $instance,
 549                  *   type_instance   => $type_instance
 550                  * };
 551                  */
 552                 data_set_t   *ds;
 553                 value_list_t *vl;
 554
 555                 AV *pds = newAV ();
 556                 HV *pvl = newHV ();
 557
 558                 ds = va_arg (ap, data_set_t *);
 559                 vl = va_arg (ap, value_list_t *);
 560
 561                 if (-1 == data_set2av (aTHX_ ds, pds))
 562                         return -1;
 563
 564                 if (-1 == value_list2hv (aTHX_ vl, ds, pvl))
 565                         return -1;
 566
 567                 XPUSHs (sv_2mortal (newSVpv (ds->type, 0)));
 568                 XPUSHs (sv_2mortal (newRV_noinc ((SV *)pds)));
 569                 XPUSHs (sv_2mortal (newRV_noinc ((SV *)pvl)));
 570         }
 571         else if (PLUGIN_LOG == type) {
 572                 /*
 573                  * $_[0] = $level;
 574                  *
 575                  * $_[1] = $message;
 576                  */
 577                 XPUSHs (sv_2mortal (newSViv (va_arg (ap, int))));
 578                 XPUSHs (sv_2mortal (newSVpv (va_arg (ap, char *), 0)));
 579         }
 580
 581         PUTBACK;
 582
 583         retvals = call_pv ("Collectd::plugin_call_all", G_SCALAR);
 584
 585         SPAGAIN;
 586         if (0 < retvals) {
 587                 SV *tmp = POPs;
 588                 if (! SvTRUE (tmp))
 589                         ret = -1;
 590         }
 591
 592         PUTBACK;
 593         FREETMPS;
 594         LEAVE;
 595
 596         va_end (ap);
 597         return ret;
 598 } /* static int pplugin_call_all (int, ...) */
 599
 600 /*
 601  * Exported Perl API.
 602  */
 603
 604 /*
 605  * Collectd::plugin_register_data_set (type, dataset).
 606  *
 607  * type:
 608  *   type of the dataset
 609  *
 610  * dataset:
 611  *   dataset to be registered
 612  */
 613 static XS (Collectd_plugin_register_ds)
 614 {
 615         SV  *data = NULL;
 616         int ret   = 0;
 617
 618         dXSARGS;
 619
 620         if (2 != items) {
 621                 log_err ("Usage: Collectd::plugin_register_data_set(type, dataset)");
 622                 XSRETURN_EMPTY;
 623         }
 624
 625         log_debug ("Collectd::plugin_register_data_set: "
 626                         "type = \"%s\", dataset = \"%s\"",
 627                         SvPV_nolen (ST (0)), SvPV_nolen (ST (1)));
 628
 629         data = ST (1);
 630
 631         if (SvROK (data) && (SVt_PVAV == SvTYPE (SvRV (data)))) {
 632                 ret = pplugin_register_data_set (aTHX_ SvPV_nolen (ST (0)),
 633                                 (AV *)SvRV (data));
 634         }
 635         else {
 636                 log_err ("Collectd::plugin_register_data_set: Invalid data.");
 637                 XSRETURN_EMPTY;
 638         }
 639
 640         if (0 == ret)
 641                 XSRETURN_YES;
 642         else
 643                 XSRETURN_EMPTY;
 644 } /* static XS (Collectd_plugin_register_ds) */
 645
 646 /*
 647  * Collectd::plugin_unregister_data_set (type).
 648  *
 649  * type:
 650  *   type of the dataset
 651  */
 652 static XS (Collectd_plugin_unregister_ds)
 653 {
 654         dXSARGS;
 655
 656         if (1 != items) {
 657                 log_err ("Usage: Collectd::plugin_unregister_data_set(type)");
 658                 XSRETURN_EMPTY;
 659         }
 660
 661         log_debug ("Collectd::plugin_unregister_data_set: type = \"%s\"",
 662                         SvPV_nolen (ST (0)));
 663
 664         if (0 == pplugin_unregister_data_set (SvPV_nolen (ST (1))))
 665                 XSRETURN_YES;
 666         else
 667                 XSRETURN_EMPTY;
 668 } /* static XS (Collectd_plugin_register_ds) */
 669
 670 /*
 671  * Collectd::plugin_dispatch_values (name, values).
 672  *
 673  * name:
 674  *   name of the plugin
 675  *
 676  * values:
 677  *   value list to submit
 678  */
 679 static XS (Collectd_plugin_dispatch_values)
 680 {
 681         SV *values = NULL;
 682
 683         int ret = 0;
 684
 685         dXSARGS;
 686
 687         if (2 != items) {
 688                 log_err ("Usage: Collectd::plugin_dispatch_values(name, values)");
 689                 XSRETURN_EMPTY;
 690         }
 691
 692         log_debug ("Collectd::plugin_dispatch_values: "
 693                         "name = \"%s\", values=\"%s\"",
 694                         SvPV_nolen (ST (0)), SvPV_nolen (ST (1)));
 695
 696         values = ST (1);
 697
 698         if (! (SvROK (values) && (SVt_PVHV == SvTYPE (SvRV (values))))) {
 699                 log_err ("Collectd::plugin_dispatch_values: Invalid values.");
 700                 XSRETURN_EMPTY;
 701         }
 702
 703         if ((NULL == ST (0)) || (NULL == values))
 704                 XSRETURN_EMPTY;
 705
 706         ret = pplugin_dispatch_values (aTHX_ SvPV_nolen (ST (0)),
 707                         (HV *)SvRV (values));
 708
 709         if (0 == ret)
 710                 XSRETURN_YES;
 711         else
 712                 XSRETURN_EMPTY;
 713 } /* static XS (Collectd_plugin_dispatch_values) */
 714
 715 /*
 716  * Collectd::plugin_log (level, message).
 717  *
 718  * level:
 719  *   log level (LOG_DEBUG, ... LOG_ERR)
 720  *
 721  * message:
 722  *   log message
 723  */
 724 static XS (Collectd_plugin_log)
 725 {
 726         dXSARGS;
 727
 728         if (2 != items) {
 729                 log_err ("Usage: Collectd::plugin_log(level, message)");
 730                 XSRETURN_EMPTY;
 731         }
 732
 733         plugin_log (SvIV (ST (0)), SvPV_nolen (ST (1)));
 734         XSRETURN_YES;
 735 } /* static XS (Collectd_plugin_log) */
 736
 737 /*
 738  * collectd's perl interpreter based thread implementation.
 739  *
 740  * This has been inspired by Perl's ithreads introduced in version 5.6.0.
 741  */
 742
 743 /* must be called with perl_threads->mutex locked */
 744 static c_ithread_t *c_ithread_create (PerlInterpreter *base)
 745 {
 746         c_ithread_t *t = NULL;
 747
 748         assert (NULL != perl_threads);
 749
 750         t = (c_ithread_t *)smalloc (sizeof (c_ithread_t));
 751         memset (t, 0, sizeof (c_ithread_t));
 752
 753         t->interp = (NULL == base)
 754                 ? NULL
 755                 : perl_clone (base, CLONEf_KEEP_PTR_TABLE);
 756
 757 #if COLLECT_DEBUG
 758         ++perl_threads->number_of_threads;
 759 #endif /* COLLECT_DEBUG */
 760
 761         t->next = NULL;
 762
 763         if (NULL == perl_threads->tail) {
 764                 perl_threads->head = t;
 765                 t->prev = NULL;
 766         }
 767         else {
 768                 perl_threads->tail->next = t;
 769                 t->prev = perl_threads->tail;
 770         }
 771
 772         perl_threads->tail = t;
 773         return t;
 774 } /* static c_ithread_t *c_ithread_create (PerlInterpreter *) */
 775
 776 /*
 777  * Interface to collectd.
 778  */
 779
 780 static int perl_init (void)
 781 {
 782         dTHX;
 783
 784         if (NULL == perl_threads)
 785                 return 0;
 786
 787         if (NULL == aTHX) {
 788                 c_ithread_t *t = NULL;
 789
 790                 pthread_mutex_lock (&perl_threads->mutex);
 791                 t = c_ithread_create (perl_threads->head->interp);
 792                 pthread_mutex_unlock (&perl_threads->mutex);
 793
 794                 aTHX = t->interp;
 795         }
 796
 797         log_debug ("perl_init: c_ithread: interp = %p (active threads: %i)\n",
 798                         aTHX, perl_threads->number_of_threads);
 799         return pplugin_call_all (aTHX_ PLUGIN_INIT);
 800 } /* static int perl_init (void) */
 801
 802 static int perl_read (void)
 803 {
 804         dTHX;
 805
 806         if (NULL == perl_threads)
 807                 return 0;
 808
 809         if (NULL == aTHX) {
 810                 c_ithread_t *t = NULL;
 811
 812                 pthread_mutex_lock (&perl_threads->mutex);
 813                 t = c_ithread_create (perl_threads->head->interp);
 814                 pthread_mutex_unlock (&perl_threads->mutex);
 815
 816                 aTHX = t->interp;
 817         }
 818
 819         log_debug ("perl_read: c_ithread: interp = %p (active threads: %i)\n",
 820                         aTHX, perl_threads->number_of_threads);
 821         return pplugin_call_all (aTHX_ PLUGIN_READ);
 822 } /* static int perl_read (void) */
 823
 824 static int perl_write (const data_set_t *ds, const value_list_t *vl)
 825 {
 826         dTHX;
 827
 828         if (NULL == perl_threads)
 829                 return 0;
 830
 831         if (NULL == aTHX) {
 832                 c_ithread_t *t = NULL;
 833
 834                 pthread_mutex_lock (&perl_threads->mutex);
 835                 t = c_ithread_create (perl_threads->head->interp);
 836                 pthread_mutex_unlock (&perl_threads->mutex);
 837
 838                 aTHX = t->interp;
 839         }
 840
 841         log_debug ("perl_write: c_ithread: interp = %p (active threads: %i)\n",
 842                         aTHX, perl_threads->number_of_threads);
 843         return pplugin_call_all (aTHX_ PLUGIN_WRITE, ds, vl);
 844 } /* static int perl_write (const data_set_t *, const value_list_t *) */
 845
 846 static void perl_log (int level, const char *msg)
 847 {
 848         dTHX;
 849
 850         if (NULL == perl_threads)
 851                 return;
 852
 853         if (NULL == aTHX) {
 854                 c_ithread_t *t = NULL;
 855
 856                 pthread_mutex_lock (&perl_threads->mutex);
 857                 t = c_ithread_create (perl_threads->head->interp);
 858                 pthread_mutex_unlock (&perl_threads->mutex);
 859
 860                 aTHX = t->interp;
 861         }
 862
 863         pplugin_call_all (aTHX_ PLUGIN_LOG, level, msg);
 864         return;
 865 } /* static void perl_log (int, const char *) */
 866
 867 static int perl_shutdown (void)
 868 {
 869         c_ithread_t *t = NULL;
 870
 871         int ret = 0;
 872
 873         dTHX;
 874
 875         plugin_unregister_complex_config ("perl");
 876
 877         if (NULL == perl_threads)
 878                 return 0;
 879
 880         if (NULL == aTHX) {
 881                 c_ithread_t *t = NULL;
 882
 883                 pthread_mutex_lock (&perl_threads->mutex);
 884                 t = c_ithread_create (perl_threads->head->interp);
 885                 pthread_mutex_unlock (&perl_threads->mutex);
 886
 887                 aTHX = t->interp;
 888         }
 889
 890         log_debug ("perl_shutdown: c_ithread: interp = %p (active threads: %i)\n",
 891                         aTHX, perl_threads->number_of_threads);
 892
 893         plugin_unregister_log ("perl");
 894         plugin_unregister_init ("perl");
 895         plugin_unregister_read ("perl");
 896         plugin_unregister_write ("perl");
 897
 898         ret = pplugin_call_all (aTHX_ PLUGIN_SHUTDOWN);
 899
 900         pthread_mutex_lock (&perl_threads->mutex);
 901         t = perl_threads->tail;
 902
 903         while (NULL != t) {
 904                 aTHX = t->interp;
 905                 PERL_SET_CONTEXT (aTHX);
 906
 907 #if COLLECT_DEBUG
 908                 sv_report_used ();
 909 #endif /* COLLECT_DEBUG */
 910
 911                 perl_destruct (aTHX);
 912                 perl_free (aTHX);
 913
 914                 t = t->prev;
 915
 916                 sfree (t);
 917         }
 918
 919         pthread_mutex_unlock (&perl_threads->mutex);
 920
 921         sfree (perl_threads);
 922
 923         PERL_SYS_TERM ();
 924
 925         plugin_unregister_shutdown ("perl");
 926         return ret;
 927 } /* static void perl_shutdown (void) */
 928
 929 /* bootstrap the Collectd module */
 930 static void xs_init (pTHX)
 931 {
 932         HV   *stash = NULL;
 933         char *file  = __FILE__;
 934
 935         int i = 0;
 936
 937         dXSUB_SYS;
 938
 939         /* enable usage of Perl modules using shared libraries */
 940         newXS ("DynaLoader::boot_DynaLoader", boot_DynaLoader, file);
 941
 942         /* register API */
 943         for (i = 0; NULL != api[i].f; ++i)
 944                 newXS (api[i].name, api[i].f, file);
 945
 946         stash = gv_stashpv ("Collectd", 1);
 947
 948         /* export "constants" */
 949         for (i = 0; '\0' != constants[i].name[0]; ++i)
 950                 newCONSTSUB (stash, constants[i].name, newSViv (constants[i].value));
 951         return;
 952 } /* static void xs_init (pTHX) */
 953
 954 /* Initialize the global Perl interpreter. */
 955 static int init_pi (int argc, char **argv)
 956 {
 957         dTHXa (NULL);
 958
 959         if (NULL != perl_threads)
 960                 return 0;
 961
 962         log_info ("Initializing Perl interpreter...");
 963 #if COLLECT_DEBUG
 964         {
 965                 int i = 0;
 966
 967                 for (i = 0; i < argc; ++i)
 968                         log_debug ("argv[%i] = \"%s\"", i, argv[i]);
 969         }
 970 #endif /* COLLECT_DEBUG */
 971
 972         PERL_SYS_INIT3 (&argc, &argv, &environ);
 973
 974         perl_threads = (c_ithread_list_t *)smalloc (sizeof (c_ithread_list_t));
 975         memset (perl_threads, 0, sizeof (c_ithread_list_t));
 976
 977         pthread_mutex_init (&perl_threads->mutex, NULL);
 978         /* locking the mutex should not be necessary at this point
 979          * but let's just do it for the sake of completeness */
 980         pthread_mutex_lock (&perl_threads->mutex);
 981
 982         perl_threads->head = c_ithread_create (NULL);
 983         perl_threads->tail = perl_threads->head;
 984
 985         if (NULL == (perl_threads->head->interp = perl_alloc ())) {
 986                 log_err ("module_register: Not enough memory.");
 987                 exit (3);
 988         }
 989
 990         aTHX = perl_threads->head->interp;
 991         pthread_mutex_unlock (&perl_threads->mutex);
 992
 993         perl_construct (aTHX);
 994
 995         PL_exit_flags |= PERL_EXIT_DESTRUCT_END;
 996
 997         if (0 != perl_parse (aTHX_ xs_init, argc, argv, NULL)) {
 998                 log_err ("module_register: Unable to bootstrap Collectd.");
 999                 exit (1);
1000         }
1001
1002         /* Set $0 to "collectd" because perl_parse() has to set it to "-e". */
1003         sv_setpv (get_sv ("0", 0), "collectd");
1004
1005         perl_run (aTHX);
1006
1007         plugin_register_log ("perl", perl_log);
1008         plugin_register_init ("perl", perl_init);
1009
1010         plugin_register_read ("perl", perl_read);
1011
1012         plugin_register_write ("perl", perl_write);
1013         plugin_register_shutdown ("perl", perl_shutdown);
1014         return 0;
1015 } /* static int init_pi (const char **, const int) */
1016
1017 /*
1018  * LoadPlugin "<Plugin>"
1019  */
1020 static int perl_config_loadplugin (pTHX_ oconfig_item_t *ci)
1021 {
1022         char module_name[DATA_MAX_NAME_LEN];
1023
1024         char *value = NULL;
1025
1026         if ((0 != ci->children_num) || (1 != ci->values_num)
1027                         || (OCONFIG_TYPE_STRING != ci->values[0].type))
1028                 return 1;
1029
1030         value = ci->values[0].value.string;
1031
1032         if (NULL == get_module_name (module_name, sizeof (module_name), value)) {
1033                 log_err ("Invalid module name %s", value);
1034                 return (1);
1035         }
1036
1037         init_pi (perl_argc, perl_argv);
1038         assert (NULL != perl_threads);
1039         assert (NULL != perl_threads->head);
1040
1041         aTHX = perl_threads->head->interp;
1042
1043         log_debug ("perl_config: loading perl plugin \"%s\"", value);
1044         load_module (PERL_LOADMOD_NOIMPORT,
1045                         newSVpv (module_name, strlen (module_name)), Nullsv);
1046         return 0;
1047 } /* static int perl_config_loadplugin (oconfig_item_it *) */
1048
1049 /*
1050  * BaseName "<Name>"
1051  */
1052 static int perl_config_basename (pTHX_ oconfig_item_t *ci)
1053 {
1054         char *value = NULL;
1055
1056         if ((0 != ci->children_num) || (1 != ci->values_num)
1057                         || (OCONFIG_TYPE_STRING != ci->values[0].type))
1058                 return 1;
1059
1060         value = ci->values[0].value.string;
1061
1062         log_debug ("perl_config: Setting plugin basename to \"%s\"", value);
1063         strncpy (base_name, value, sizeof (base_name));
1064         base_name[sizeof (base_name) - 1] = '\0';
1065         return 0;
1066 } /* static int perl_config_basename (oconfig_item_it *) */
1067
1068 /*
1069  * EnableDebugger "<Package>"|""
1070  */
1071 static int perl_config_enabledebugger (pTHX_ oconfig_item_t *ci)
1072 {
1073         char *value = NULL;
1074
1075         if ((0 != ci->children_num) || (1 != ci->values_num)
1076                         || (OCONFIG_TYPE_STRING != ci->values[0].type))
1077                 return 1;
1078
1079         value = ci->values[0].value.string;
1080
1081         perl_argv = (char **)realloc (perl_argv,
1082                         (++perl_argc + 1) * sizeof (char *));
1083
1084         if (NULL == perl_argv) {
1085                 log_err ("perl_config: Not enough memory.");
1086                 exit (3);
1087         }
1088
1089         if ('\0' == value[0]) {
1090                 perl_argv[perl_argc - 1] = "-d";
1091         }
1092         else {
1093                 perl_argv[perl_argc - 1] = (char *)smalloc (strlen (value) + 4);
1094                 sstrncpy (perl_argv[perl_argc - 1], "-d:", 4);
1095                 sstrncpy (perl_argv[perl_argc - 1] + 3, value, strlen (value) + 1);
1096         }
1097
1098         perl_argv[perl_argc] = NULL;
1099         return 0;
1100 } /* static int perl_config_enabledebugger (oconfig_item_it *) */
1101
1102 /*
1103  * IncludeDir "<Dir>"
1104  */
1105 static int perl_config_includedir (pTHX_ oconfig_item_t *ci)
1106 {
1107         char *value = NULL;
1108
1109         if ((0 != ci->children_num) || (1 != ci->values_num)
1110                         || (OCONFIG_TYPE_STRING != ci->values[0].type))
1111                 return 1;
1112
1113         value = ci->values[0].value.string;
1114
1115         if (NULL == aTHX) {
1116                 perl_argv = (char **)realloc (perl_argv,
1117                                 (++perl_argc + 1) * sizeof (char *));
1118
1119                 if (NULL == perl_argv) {
1120                         log_err ("perl_config: Not enough memory.");
1121                         exit (3);
1122                 }
1123
1124                 perl_argv[perl_argc - 1] = (char *)smalloc (strlen (value) + 3);
1125                 sstrncpy(perl_argv[perl_argc - 1], "-I", 3);
1126                 sstrncpy(perl_argv[perl_argc - 1] + 2, value, strlen (value) + 1);
1127
1128                 perl_argv[perl_argc] = NULL;
1129         }
1130         else {
1131                 /* prepend the directory to @INC */
1132                 av_unshift (GvAVn (PL_incgv), 1);
1133                 av_store (GvAVn (PL_incgv), 0, newSVpv (value, strlen (value)));
1134         }
1135         return 0;
1136 } /* static int perl_config_includedir (oconfig_item_it *) */
1137
1138 static int perl_config (oconfig_item_t *ci)
1139 {
1140         int i = 0;
1141
1142         dTHX;
1143
1144         /* dTHX does not get any valid values in case Perl
1145          * has not been initialized */
1146         if (NULL == perl_threads)
1147                 aTHX = NULL;
1148
1149         for (i = 0; i < ci->children_num; ++i) {
1150                 oconfig_item_t *c = ci->children + i;
1151
1152                 if (0 == strcasecmp (c->key, "LoadPlugin"))
1153                         perl_config_loadplugin (aTHX_ c);
1154                 else if (0 == strcasecmp (c->key, "BaseName"))
1155                         perl_config_basename (aTHX_ c);
1156                 else if (0 == strcasecmp (c->key, "EnableDebugger"))
1157                         perl_config_enabledebugger (aTHX_ c);
1158                 else if (0 == strcasecmp (c->key, "IncludeDir"))
1159                         perl_config_includedir (aTHX_ c);
1160                 else
1161                         log_warn ("Ignoring unknown config key \"%s\".", c->key);
1162         }
1163         return 0;
1164 } /* static int perl_config (oconfig_item_t *) */
1165
1166 void module_register (void)
1167 {
1168         perl_argc = 4;
1169         perl_argv = (char **)smalloc ((perl_argc + 1) * sizeof (char *));
1170
1171         /* default options for the Perl interpreter */
1172         perl_argv[0] = "";
1173         perl_argv[1] = "-MCollectd";
1174         perl_argv[2] = "-e";
1175         perl_argv[3] = "1";
1176         perl_argv[4] = NULL;
1177
1178         plugin_register_complex_config ("perl", perl_config);
1179         return;
1180 } /* void module_register (void) */
1181
1182 /* vim: set sw=4 ts=4 tw=78 noexpandtab : */
1183