Code

Merge branch 'collectd-4.1'
[collectd.git] / 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  **/
22 /*
23  * This plugin embeds a Perl interpreter into collectd and provides an
24  * interface for collectd plugins written in perl.
25  */
27 #include "collectd.h"
29 #include "configfile.h"
31 #include <EXTERN.h>
32 #include <perl.h>
34 #include <XSUB.h>
36 /* Some versions of Perl define their own version of DEBUG... :-/ */
37 #ifdef DEBUG
38 # undef DEBUG
39 #endif /* DEBUG */
41 /* ... while we want the definition found in plugin.h. */
42 #include "plugin.h"
43 #include "common.h"
45 #define PLUGIN_INIT     0
46 #define PLUGIN_READ     1
47 #define PLUGIN_WRITE    2
48 #define PLUGIN_SHUTDOWN 3
49 #define PLUGIN_LOG      4
51 #define PLUGIN_TYPES    5
53 #define PLUGIN_DATASET  255
55 #define log_debug(...) DEBUG ("perl: " __VA_ARGS__)
56 #define log_info(...) INFO ("perl: " __VA_ARGS__)
57 #define log_warn(...) WARNING ("perl: " __VA_ARGS__)
58 #define log_err(...) ERROR ("perl: " __VA_ARGS__)
61 /* this is defined in DynaLoader.a */
62 void boot_DynaLoader (PerlInterpreter *, CV *);
64 static XS (Collectd_plugin_register_ds);
65 static XS (Collectd_plugin_unregister_ds);
66 static XS (Collectd_plugin_dispatch_values);
67 static XS (Collectd_plugin_log);
70 /*
71  * private data types
72  */
74 typedef struct {
75         int len;
76         int *values;
77 } ds_types_t;
80 /*
81  * private variables
82  */
84 static PerlInterpreter *perl = NULL;
86 static int  perl_argc   = 0;
87 static char **perl_argv = NULL;
89 static char base_name[DATA_MAX_NAME_LEN] = "";
91 static HV   *data_sets;
93 static struct {
94         char name[64];
95         XS ((*f));
96 } api[] =
97 {
98         { "Collectd::plugin_register_data_set",   Collectd_plugin_register_ds },
99         { "Collectd::plugin_unregister_data_set", Collectd_plugin_unregister_ds },
100         { "Collectd::plugin_dispatch_values",     Collectd_plugin_dispatch_values },
101         { "Collectd::plugin_log",                 Collectd_plugin_log },
102         { "", NULL }
103 };
105 struct {
106         char name[64];
107         int  value;
108 } constants[] =
110         { "Collectd::TYPE_INIT",       PLUGIN_INIT },
111         { "Collectd::TYPE_READ",       PLUGIN_READ },
112         { "Collectd::TYPE_WRITE",      PLUGIN_WRITE },
113         { "Collectd::TYPE_SHUTDOWN",   PLUGIN_SHUTDOWN },
114         { "Collectd::TYPE_LOG",        PLUGIN_LOG },
115         { "Collectd::TYPE_DATASET",    PLUGIN_DATASET },
116         { "Collectd::DS_TYPE_COUNTER", DS_TYPE_COUNTER },
117         { "Collectd::DS_TYPE_GAUGE",   DS_TYPE_GAUGE },
118         { "Collectd::LOG_ERR",         LOG_ERR },
119         { "Collectd::LOG_WARNING",     LOG_WARNING },
120         { "Collectd::LOG_NOTICE",      LOG_NOTICE },
121         { "Collectd::LOG_INFO",        LOG_INFO },
122         { "Collectd::LOG_DEBUG",       LOG_DEBUG },
123         { "", 0 }
124 };
127 /*
128  * Helper functions for data type conversion.
129  */
131 /*
132  * data source:
133  * [
134  *   {
135  *     name => $ds_name,
136  *     type => $ds_type,
137  *     min  => $ds_min,
138  *     max  => $ds_max
139  *   },
140  *   ...
141  * ]
142  */
143 static int hv2data_source (HV *hash, data_source_t *ds)
145         SV **tmp = NULL;
147         if ((NULL == hash) || (NULL == ds))
148                 return -1;
150         if (NULL != (tmp = Perl_hv_fetch (perl, hash, "name", 4, 0))) {
151                 strncpy (ds->name, SvPV_nolen (*tmp), DATA_MAX_NAME_LEN);
152                 ds->name[DATA_MAX_NAME_LEN - 1] = '\0';
153         }
154         else {
155                 log_err ("hv2data_source: No DS name given.");
156                 return -1;
157         }
159         if (NULL != (tmp = Perl_hv_fetch (perl, hash, "type", 4, 0))) {
160                 ds->type = SvIV (*tmp);
162                 if ((DS_TYPE_COUNTER != ds->type) && (DS_TYPE_GAUGE != ds->type)) {
163                         log_err ("hv2data_source: Invalid DS type.");
164                         return -1;
165                 }
166         }
167         else {
168                 ds->type = DS_TYPE_COUNTER;
169         }
171         if (NULL != (tmp = Perl_hv_fetch (perl, hash, "min", 3, 0)))
172                 ds->min = SvNV (*tmp);
173         else
174                 ds->min = NAN;
176         if (NULL != (tmp = Perl_hv_fetch (perl, hash, "max", 3, 0)))
177                 ds->max = SvNV (*tmp);
178         else
179                 ds->max = NAN;
180         return 0;
181 } /* static data_source_t *hv2data_source (HV *) */
183 static int av2value (char *name, AV *array, value_t *value, int len)
185         SV **tmp = NULL;
187         ds_types_t *ds = NULL;
189         int i = 0;
191         if ((NULL == name) || (NULL == array) || (NULL == value))
192                 return -1;
194         if (Perl_av_len (perl, array) < len - 1)
195                 len = Perl_av_len (perl, array) + 1;
197         if (0 >= len)
198                 return -1;
200         tmp = Perl_hv_fetch (perl, data_sets, name, strlen (name), 0);
201         if (NULL == tmp) {
202                 log_err ("av2value: No dataset for \"%s\".", name);
203                 return -1;
204         }
205         ds = (ds_types_t *)SvIV ((SV *)SvRV (*tmp));
207         if (ds->len < len) {
208                 log_warn ("av2value: Value length exceeds data set length.");
209                 len = ds->len;
210         }
212         for (i = 0; i < len; ++i) {
213                 SV **tmp = Perl_av_fetch (perl, array, i, 0);
215                 if (NULL != tmp) {
216                         if (DS_TYPE_COUNTER == ds->values[i])
217                                 value[i].counter = SvIV (*tmp);
218                         else
219                                 value[i].gauge = SvNV (*tmp);
220                 }
221                 else {
222                         return -1;
223                 }
224         }
225         return len;
226 } /* static int av2value (char *, AV *, value_t *, int) */
228 static int data_set2av (data_set_t *ds, AV *array)
230         int i = 0;
232         if ((NULL == ds) || (NULL == array))
233                 return -1;
235         Perl_av_extend (perl, array, ds->ds_num);
237         for (i = 0; i < ds->ds_num; ++i) {
238                 HV *source = Perl_newHV (perl);
240                 if (NULL == Perl_hv_store (perl, source, "name", 4,
241                                 Perl_newSVpv (perl, ds->ds[i].name, 0), 0))
242                         return -1;
244                 if (NULL == Perl_hv_store (perl, source, "type", 4,
245                                 Perl_newSViv (perl, ds->ds[i].type), 0))
246                         return -1;
248                 if (! isnan (ds->ds[i].min))
249                         if (NULL == Perl_hv_store (perl, source, "min", 3,
250                                         Perl_newSVnv (perl, ds->ds[i].min), 0))
251                                 return -1;
253                 if (! isnan (ds->ds[i].max))
254                         if (NULL == Perl_hv_store (perl, source, "max", 3,
255                                         Perl_newSVnv (perl, ds->ds[i].max), 0))
256                                 return -1;
258                 if (NULL == Perl_av_store (perl, array, i,
259                                 Perl_newRV_noinc (perl, (SV *)source)))
260                         return -1;
261         }
262         return 0;
263 } /* static int data_set2av (data_set_t *, AV *) */
265 static int value_list2hv (value_list_t *vl, data_set_t *ds, HV *hash)
267         AV *values = NULL;
269         int i   = 0;
270         int len = 0;
272         if ((NULL == vl) || (NULL == ds) || (NULL == hash))
273                 return -1;
275         len = vl->values_len;
277         if (ds->ds_num < len) {
278                 log_warn ("value2av: Value length exceeds data set length.");
279                 len = ds->ds_num;
280         }
282         values = Perl_newAV (perl);
283         Perl_av_extend (perl, values, len - 1);
285         for (i = 0; i < len; ++i) {
286                 SV *val = NULL;
288                 if (DS_TYPE_COUNTER == ds->ds[i].type)
289                         val = Perl_newSViv (perl, vl->values[i].counter);
290                 else
291                         val = Perl_newSVnv (perl, vl->values[i].gauge);
293                 if (NULL == Perl_av_store (perl, values, i, val)) {
294                         Perl_av_undef (perl, values);
295                         return -1;
296                 }
297         }
299         if (NULL == Perl_hv_store (perl, hash, "values", 6,
300                         Perl_newRV_noinc (perl, (SV *)values), 0))
301                 return -1;
303         if (0 != vl->time)
304                 if (NULL == Perl_hv_store (perl, hash, "time", 4,
305                                 Perl_newSViv (perl, vl->time), 0))
306                         return -1;
308         if ('\0' != vl->host[0])
309                 if (NULL == Perl_hv_store (perl, hash, "host", 4,
310                                 Perl_newSVpv (perl, vl->host, 0), 0))
311                         return -1;
313         if ('\0' != vl->plugin[0])
314                 if (NULL == Perl_hv_store (perl, hash, "plugin", 6,
315                                 Perl_newSVpv (perl, vl->plugin, 0), 0))
316                         return -1;
318         if ('\0' != vl->plugin_instance[0])
319                 if (NULL == Perl_hv_store (perl, hash, "plugin_instance", 15,
320                                 Perl_newSVpv (perl, vl->plugin_instance, 0), 0))
321                         return -1;
323         if ('\0' != vl->type_instance[0])
324                 if (NULL == Perl_hv_store (perl, hash, "type_instance", 13,
325                                 Perl_newSVpv (perl, vl->type_instance, 0), 0))
326                         return -1;
327         return 0;
328 } /* static int value2av (value_list_t *, data_set_t *, HV *) */
331 /*
332  * Internal functions.
333  */
335 static char *get_module_name (char *buf, size_t buf_len, const char *module) {
336         int status = 0;
337         if (base_name[0] == '\0')
338                 status = snprintf (buf, buf_len, "%s", module);
339         else
340                 status = snprintf (buf, buf_len, "%s::%s", base_name, module);
341         if ((status < 0) || (status >= buf_len))
342                 return (NULL);
343         buf[buf_len - 1] = '\0';
344         return (buf);
345 } /* char *get_module_name */
347 /*
348  * Add a plugin's data set definition.
349  */
350 static int pplugin_register_data_set (char *name, AV *dataset)
352         int len = -1;
353         int i   = 0;
355         data_source_t *ds  = NULL;
356         data_set_t    *set = NULL;
358         ds_types_t *types = NULL;
360         if ((NULL == name) || (NULL == dataset))
361                 return -1;
363         len = Perl_av_len (perl, dataset);
365         if (-1 == len)
366                 return -1;
368         ds  = (data_source_t *)smalloc ((len + 1) * sizeof (data_source_t));
369         set = (data_set_t *)smalloc (sizeof (data_set_t));
371         types = (ds_types_t *)smalloc (sizeof (ds_types_t));
372         types->len = len + 1;
373         types->values = (int *)smalloc ((types->len) * sizeof (int));
375         for (i = 0; i <= len; ++i) {
376                 SV **elem = Perl_av_fetch (perl, dataset, i, 0);
378                 if (NULL == elem)
379                         return -1;
381                 if (! (SvROK (*elem) && (SVt_PVHV == SvTYPE (SvRV (*elem))))) {
382                         log_err ("pplugin_register_data_set: Invalid data source.");
383                         return -1;
384                 }
386                 if (-1 == hv2data_source ((HV *)SvRV (*elem), &ds[i]))
387                         return -1;
389                 types->values[i] = ds[i].type;
390                 log_debug ("pplugin_register_data_set: "
391                                 "DS.name = \"%s\", DS.type = %i, DS.min = %f, DS.max = %f",
392                                 ds[i].name, ds[i].type, ds[i].min, ds[i].max);
393         }
395         if (NULL == Perl_hv_store (perl, data_sets, name, strlen (name),
396                         Perl_sv_setref_pv (perl, Perl_newSV (perl, 0), 0, types), 0))
397                 return -1;
399         strncpy (set->type, name, DATA_MAX_NAME_LEN);
400         set->type[DATA_MAX_NAME_LEN - 1] = '\0';
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 *) */
407 /*
408  * Remove a plugin's data set definition.
409  */
410 static int pplugin_unregister_data_set (char *name)
412         SV *tmp = NULL;
414         if (NULL == name)
415                 return 0;
417         /* freeing the allocated memory of the element itself (ds_types_t *)
418          * causes a segfault during perl_destruct () thus I assume perl somehow
419          * takes care of this... */
421         tmp = Perl_hv_delete (perl, data_sets, name, strlen (name), 0);
422         if (NULL != tmp) {
423                 ds_types_t *ds = (ds_types_t *)SvIV ((SV *)SvRV (tmp));
424                 sfree (ds->values);
425         }
426         return plugin_unregister_data_set (name);
427 } /* static int pplugin_unregister_data_set (char *) */
429 /*
430  * Submit the values to the write functions.
431  *
432  * value list:
433  * {
434  *   values => [ @values ],
435  *   time   => $time,
436  *   host   => $host,
437  *   plugin => $plugin,
438  *   plugin_instance => $pinstance,
439  *   type_instance   => $tinstance,
440  * }
441  */
442 static int pplugin_dispatch_values (char *name, HV *values)
444         value_list_t list = VALUE_LIST_INIT;
445         value_t      *val = NULL;
447         SV **tmp = NULL;
449         int ret = 0;
451         if ((NULL == name) || (NULL == values))
452                 return -1;
454         if ((NULL == (tmp = Perl_hv_fetch (perl, values, "values", 6, 0)))
455                         || (! (SvROK (*tmp) && (SVt_PVAV == SvTYPE (SvRV (*tmp)))))) {
456                 log_err ("pplugin_dispatch_values: No valid values given.");
457                 return -1;
458         }
460         {
461                 AV  *array = (AV *)SvRV (*tmp);
462                 int len    = Perl_av_len (perl, array) + 1;
464                 val = (value_t *)smalloc (len * sizeof (value_t));
466                 list.values_len = av2value (name, (AV *)SvRV (*tmp), val, len);
467                 list.values = val;
469                 if (-1 == list.values_len) {
470                         sfree (val);
471                         return -1;
472                 }
473         }
475         if (NULL != (tmp = Perl_hv_fetch (perl, values, "time", 4, 0))) {
476                 list.time = (time_t)SvIV (*tmp);
477         }
478         else {
479                 list.time = time (NULL);
480         }
482         if (NULL != (tmp = Perl_hv_fetch (perl, values, "host", 4, 0))) {
483                 strncpy (list.host, SvPV_nolen (*tmp), DATA_MAX_NAME_LEN);
484                 list.host[DATA_MAX_NAME_LEN - 1] = '\0';
485         }
486         else {
487                 strcpy (list.host, hostname_g);
488         }
490         if (NULL != (tmp = Perl_hv_fetch (perl, values, "plugin", 6, 0))) {
491                 strncpy (list.plugin, SvPV_nolen (*tmp), DATA_MAX_NAME_LEN);
492                 list.plugin[DATA_MAX_NAME_LEN - 1] = '\0';
493         }
495         if (NULL != (tmp = Perl_hv_fetch (perl, values,
496                         "plugin_instance", 15, 0))) {
497                 strncpy (list.plugin_instance, SvPV_nolen (*tmp), DATA_MAX_NAME_LEN);
498                 list.plugin_instance[DATA_MAX_NAME_LEN - 1] = '\0';
499         }
501         if (NULL != (tmp = Perl_hv_fetch (perl, values, "type_instance", 13, 0))) {
502                 strncpy (list.type_instance, SvPV_nolen (*tmp), DATA_MAX_NAME_LEN);
503                 list.type_instance[DATA_MAX_NAME_LEN - 1] = '\0';
504         }
506         ret = plugin_dispatch_values (name, &list);
508         sfree (val);
509         return ret;
510 } /* static int pplugin_dispatch_values (char *, HV *) */
512 /*
513  * Call all working functions of the given type.
514  */
515 static int pplugin_call_all (int type, ...)
517         int retvals = 0;
519         va_list ap;
520         int ret = 0;
522         dSP;
524         if ((type < 0) || (type >= PLUGIN_TYPES))
525                 return -1;
527         va_start (ap, type);
529         ENTER;
530         SAVETMPS;
532         PUSHMARK (SP);
534         XPUSHs (sv_2mortal (Perl_newSViv (perl, (IV)type)));
536         if (PLUGIN_WRITE == type) {
537                 /*
538                  * $_[0] = $plugin_type;
539                  *
540                  * $_[1] =
541                  * [
542                  *   {
543                  *     name => $ds_name,
544                  *     type => $ds_type,
545                  *     min  => $ds_min,
546                  *     max  => $ds_max
547                  *   },
548                  *   ...
549                  * ];
550                  *
551                  * $_[2] =
552                  * {
553                  *   values => [ $v1, ... ],
554                  *   time   => $time,
555                  *   host   => $hostname,
556                  *   plugin => $plugin,
557                  *   plugin_instance => $instance,
558                  *   type_instance   => $type_instance
559                  * };
560                  */
561                 data_set_t   *ds;
562                 value_list_t *vl;
564                 AV *pds = Perl_newAV (perl);
565                 HV *pvl = Perl_newHV (perl);
567                 ds = va_arg (ap, data_set_t *);
568                 vl = va_arg (ap, value_list_t *);
570                 if (-1 == data_set2av (ds, pds))
571                         return -1;
573                 if (-1 == value_list2hv (vl, ds, pvl))
574                         return -1;
576                 XPUSHs (sv_2mortal (Perl_newSVpv (perl, ds->type, 0)));
577                 XPUSHs (sv_2mortal (Perl_newRV_noinc (perl, (SV *)pds)));
578                 XPUSHs (sv_2mortal (Perl_newRV_noinc (perl, (SV *)pvl)));
579         }
580         else if (PLUGIN_LOG == type) {
581                 /*
582                  * $_[0] = $level;
583                  *
584                  * $_[1] = $message;
585                  */
586                 XPUSHs (sv_2mortal (Perl_newSViv (perl, va_arg (ap, int))));
587                 XPUSHs (sv_2mortal (Perl_newSVpv (perl, va_arg (ap, char *), 0)));
588         }
590         PUTBACK;
592         retvals = Perl_call_pv (perl, "Collectd::plugin_call_all", G_SCALAR);
594         SPAGAIN;
595         if (0 < retvals) {
596                 SV *tmp = POPs;
597                 if (! SvTRUE (tmp))
598                         ret = -1;
599         }
601         PUTBACK;
602         FREETMPS;
603         LEAVE;
605         va_end (ap);
606         return ret;
607 } /* static int pplugin_call_all (int, ...) */
610 /*
611  * Exported Perl API.
612  */
614 /*
615  * Collectd::plugin_register_data_set (type, dataset).
616  *
617  * type:
618  *   type of the dataset
619  *
620  * dataset:
621  *   dataset to be registered
622  */
623 static XS (Collectd_plugin_register_ds)
625         SV  *data = NULL;
626         int ret   = 0;
628         dXSARGS;
630         if (2 != items) {
631                 log_err ("Usage: Collectd::plugin_register_data_set(type, dataset)");
632                 XSRETURN_EMPTY;
633         }
635         log_debug ("Collectd::plugin_register_data_set: "
636                         "type = \"%s\", dataset = \"%s\"",
637                         SvPV_nolen (ST (0)), SvPV_nolen (ST (1)));
639         data = ST (1);
641         if (SvROK (data) && (SVt_PVAV == SvTYPE (SvRV (data)))) {
642                 ret = pplugin_register_data_set (SvPV_nolen (ST (0)),
643                                 (AV *)SvRV (data));
644         }
645         else {
646                 log_err ("Collectd::plugin_register_data_set: Invalid data.");
647                 XSRETURN_EMPTY;
648         }
650         if (0 == ret)
651                 XSRETURN_YES;
652         else
653                 XSRETURN_EMPTY;
654 } /* static XS (Collectd_plugin_register_ds) */
656 /*
657  * Collectd::plugin_unregister_data_set (type).
658  *
659  * type:
660  *   type of the dataset
661  */
662 static XS (Collectd_plugin_unregister_ds)
664         dXSARGS;
666         if (1 != items) {
667                 log_err ("Usage: Collectd::plugin_unregister_data_set(type)");
668                 XSRETURN_EMPTY;
669         }
671         log_debug ("Collectd::plugin_unregister_data_set: type = \"%s\"",
672                         SvPV_nolen (ST (0)));
674         if (0 == pplugin_unregister_data_set (SvPV_nolen (ST (1))))
675                 XSRETURN_YES;
676         else
677                 XSRETURN_EMPTY;
678 } /* static XS (Collectd_plugin_register_ds) */
680 /*
681  * Collectd::plugin_dispatch_values (name, values).
682  *
683  * name:
684  *   name of the plugin
685  *
686  * values:
687  *   value list to submit
688  */
689 static XS (Collectd_plugin_dispatch_values)
691         SV *values = NULL;
693         int ret = 0;
695         dXSARGS;
697         if (2 != items) {
698                 log_err ("Usage: Collectd::plugin_dispatch_values(name, values)");
699                 XSRETURN_EMPTY;
700         }
702         log_debug ("Collectd::plugin_dispatch_values: "
703                         "name = \"%s\", values=\"%s\"",
704                         SvPV_nolen (ST (0)), SvPV_nolen (ST (1)));
706         values = ST (1);
708         if (! (SvROK (values) && (SVt_PVHV == SvTYPE (SvRV (values))))) {
709                 log_err ("Collectd::plugin_dispatch_values: Invalid values.");
710                 XSRETURN_EMPTY;
711         }
713         if ((NULL == ST (0)) || (NULL == values))
714                 XSRETURN_EMPTY;
716         ret = pplugin_dispatch_values (SvPV_nolen (ST (0)), (HV *)SvRV (values));
718         if (0 == ret)
719                 XSRETURN_YES;
720         else
721                 XSRETURN_EMPTY;
722 } /* static XS (Collectd_plugin_dispatch_values) */
724 /*
725  * Collectd::plugin_log (level, message).
726  *
727  * level:
728  *   log level (LOG_DEBUG, ... LOG_ERR)
729  *
730  * message:
731  *   log message
732  */
733 static XS (Collectd_plugin_log)
735         dXSARGS;
737         if (2 != items) {
738                 log_err ("Usage: Collectd::plugin_log(level, message)");
739                 XSRETURN_EMPTY;
740         }
742         plugin_log (SvIV (ST (0)), SvPV_nolen (ST (1)));
743         XSRETURN_YES;
744 } /* static XS (Collectd_plugin_log) */
747 /*
748  * Interface to collectd.
749  */
751 static int perl_init (void)
753         if (NULL == perl)
754                 return 0;
756         PERL_SET_CONTEXT (perl);
757         return pplugin_call_all (PLUGIN_INIT);
758 } /* static int perl_init (void) */
760 static int perl_read (void)
762         if (NULL == perl)
763                 return 0;
765         PERL_SET_CONTEXT (perl);
766         return pplugin_call_all (PLUGIN_READ);
767 } /* static int perl_read (void) */
769 static int perl_write (const data_set_t *ds, const value_list_t *vl)
771         if (NULL == perl)
772                 return 0;
774         PERL_SET_CONTEXT (perl);
775         return pplugin_call_all (PLUGIN_WRITE, ds, vl);
776 } /* static int perl_write (const data_set_t *, const value_list_t *) */
778 static void perl_log (int level, const char *msg)
780         if (NULL == perl)
781                 return;
783         PERL_SET_CONTEXT (perl);
784         pplugin_call_all (PLUGIN_LOG, level, msg);
785         return;
786 } /* static void perl_log (int, const char *) */
788 static int perl_shutdown (void)
790         int ret = 0;
792         plugin_unregister_complex_config ("perl");
794         if (NULL == perl)
795                 return 0;
797         plugin_unregister_log ("perl");
798         plugin_unregister_init ("perl");
799         plugin_unregister_read ("perl");
800         plugin_unregister_write ("perl");
802         PERL_SET_CONTEXT (perl);
803         ret = pplugin_call_all (PLUGIN_SHUTDOWN);
805         if (0 < Perl_hv_iterinit (perl, data_sets)) {
806                 char *k = NULL;
807                 I32  l  = 0;
809                 while (NULL != Perl_hv_iternextsv (perl, data_sets, &k, &l)) {
810                         pplugin_unregister_data_set (k);
811                 }
812         }
814         Perl_hv_undef (perl, data_sets);
816 #if COLLECT_DEBUG
817         Perl_sv_report_used (perl);
818 #endif /* COLLECT_DEBUG */
820         perl_destruct (perl);
821         perl_free (perl);
822         perl = NULL;
824         PERL_SYS_TERM ();
826         plugin_unregister_shutdown ("perl");
827         return ret;
828 } /* static void perl_shutdown (void) */
830 /* bootstrap the Collectd module */
831 static void xs_init (pTHX)
833         HV   *stash = NULL;
834         char *file  = __FILE__;
836         int i = 0;
838         dXSUB_SYS;
840         /* enable usage of Perl modules using shared libraries */
841         Perl_newXS (perl, "DynaLoader::boot_DynaLoader", boot_DynaLoader, file);
843         /* register API */
844         for (i = 0; NULL != api[i].f; ++i)
845                 Perl_newXS (perl, api[i].name, api[i].f, file);
847         stash = Perl_gv_stashpv (perl, "Collectd", 1);
849         /* export "constants" */
850         for (i = 0; '\0' != constants[i].name[0]; ++i)
851                 Perl_newCONSTSUB (perl, stash, constants[i].name,
852                                 Perl_newSViv (perl, constants[i].value));
853         return;
854 } /* static void xs_init (pTHX) */
856 /* Initialize the global Perl interpreter. */
857 static int init_pi (int argc, char **argv)
859         if (NULL != perl)
860                 return 0;
862         log_info ("Initializing Perl interpreter...");
863 #if COLLECT_DEBUG
864         {
865                 int i = 0;
867                 for (i = 0; i < argc; ++i)
868                         log_debug ("argv[%i] = \"%s\"", i, argv[i]);
869         }
870 #endif /* COLLECT_DEBUG */
872         PERL_SYS_INIT3 (&argc, &argv, &environ);
874         if (NULL == (perl = perl_alloc ())) {
875                 log_err ("module_register: Not enough memory.");
876                 exit (3);
877         }
878         perl_construct (perl);
880         PL_exit_flags |= PERL_EXIT_DESTRUCT_END;
882         if (0 != perl_parse (perl, xs_init, argc, argv, NULL)) {
883                 log_err ("module_register: Unable to bootstrap Collectd.");
884                 exit (1);
885         }
886         perl_run (perl);
888         data_sets = Perl_newHV (perl);
890         plugin_register_log ("perl", perl_log);
891         plugin_register_init ("perl", perl_init);
893         plugin_register_read ("perl", perl_read);
895         plugin_register_write ("perl", perl_write);
896         plugin_register_shutdown ("perl", perl_shutdown);
897         return 0;
898 } /* static int init_pi (const char **, const int) */
900 /*
901  * LoadPlugin "<Plugin>"
902  */
903 static int perl_config_loadplugin (oconfig_item_t *ci)
905         char module_name[DATA_MAX_NAME_LEN];
907         char *value = NULL;
909         if ((0 != ci->children_num) || (1 != ci->values_num)
910                         || (OCONFIG_TYPE_STRING != ci->values[0].type)) {
911         }
913         value = ci->values[0].value.string;
915         if (NULL == get_module_name (module_name, sizeof (module_name), value)) {
916                 log_err ("Invalid module name %s", value);
917                 return (1);
918         }
920         init_pi (perl_argc, perl_argv);
922         log_debug ("perl_config: loading perl plugin \"%s\"", value);
923         Perl_load_module (perl, PERL_LOADMOD_NOIMPORT,
924                         Perl_newSVpv (perl, module_name, strlen (module_name)),
925                         Nullsv);
926         return 0;
927 } /* static int perl_config_loadplugin (oconfig_item_it *) */
929 /*
930  * BaseName "<Name>"
931  */
932 static int perl_config_basename (oconfig_item_t *ci)
934         char *value = NULL;
936         if ((0 != ci->children_num) || (1 != ci->values_num)
937                         || (OCONFIG_TYPE_STRING != ci->values[0].type)) {
938         }
940         value = ci->values[0].value.string;
942         log_debug ("perl_config: Setting plugin basename to \"%s\"", value);
943         strncpy (base_name, value, sizeof (base_name));
944         base_name[sizeof (base_name) - 1] = '\0';
945         return 0;
946 } /* static int perl_config_basename (oconfig_item_it *) */
948 /*
949  * EnableDebugger "<Package>"|""
950  */
951 static int perl_config_enabledebugger (oconfig_item_t *ci)
953         char *value = NULL;
955         if ((0 != ci->children_num) || (1 != ci->values_num)
956                         || (OCONFIG_TYPE_STRING != ci->values[0].type)) {
957         }
959         value = ci->values[0].value.string;
961         perl_argv = (char **)realloc (perl_argv,
962                         (++perl_argc + 1) * sizeof (char *));
964         if (NULL == perl_argv) {
965                 log_err ("perl_config: Not enough memory.");
966                 exit (3);
967         }
969         if ('\0' == value[0]) {
970                 perl_argv[perl_argc - 1] = "-d";
971         }
972         else {
973                 perl_argv[perl_argc - 1] = (char *)smalloc (strlen (value) + 4);
974                 sstrncpy (perl_argv[perl_argc - 1], "-d:", 4);
975                 sstrncpy (perl_argv[perl_argc - 1] + 3, value, strlen (value) + 1);
976         }
978         perl_argv[perl_argc] = NULL;
979         return 0;
980 } /* static int perl_config_enabledebugger (oconfig_item_it *) */
982 /*
983  * IncludeDir "<Dir>"
984  */
985 static int perl_config_includedir (oconfig_item_t *ci)
987         char *value = NULL;
989         if ((0 != ci->children_num) || (1 != ci->values_num)
990                         || (OCONFIG_TYPE_STRING != ci->values[0].type)) {
991         }
993         value = ci->values[0].value.string;
995         perl_argv = (char **)realloc (perl_argv,
996                         (++perl_argc + 1) * sizeof (char *));
998         if (NULL == perl_argv) {
999                 log_err ("perl_config: Not enough memory.");
1000                 exit (3);
1001         }
1003         perl_argv[perl_argc - 1] = (char *)smalloc (strlen (value) + 3);
1004         sstrncpy(perl_argv[perl_argc - 1], "-I", 3);
1005         sstrncpy(perl_argv[perl_argc - 1] + 2, value, strlen (value) + 1);
1007         perl_argv[perl_argc] = NULL;
1008         return 0;
1009 } /* static int perl_config_includedir (oconfig_item_it *) */
1011 static int perl_config (oconfig_item_t *ci)
1013         int i = 0;
1015         for (i = 0; i < ci->children_num; ++i) {
1016                 oconfig_item_t *c = ci->children + i;
1018                 if (0 == strcasecmp (c->key, "LoadPlugin"))
1019                         perl_config_loadplugin (c);
1020                 else if (0 == strcasecmp (c->key, "BaseName"))
1021                         perl_config_basename (c);
1022                 else if (0 == strcasecmp (c->key, "EnableDebugger"))
1023                         perl_config_enabledebugger (c);
1024                 else if (0 == strcasecmp (c->key, "IncludeDir"))
1025                         perl_config_includedir (c);
1026                 else
1027                         log_warn ("Ignoring unknown config key \"%s\".", c->key);
1028         }
1029         return 0;
1030 } /* static int perl_config (oconfig_item_t *) */
1032 void module_register (void)
1034         perl_argc = 4;
1035         perl_argv = (char **)smalloc ((perl_argc + 1) * sizeof (char *));
1037         /* default options for the Perl interpreter */
1038         perl_argv[0] = "";
1039         perl_argv[1] = "-MCollectd";
1040         perl_argv[2] = "-e";
1041         perl_argv[3] = "1";
1042         perl_argv[4] = NULL;
1044         plugin_register_complex_config ("perl", perl_config);
1045         return;
1046 } /* void module_register (void) */
1048 /* vim: set sw=4 ts=4 tw=78 noexpandtab : */