X-Git-Url: https://git.tokkee.org/?a=blobdiff_plain;f=src%2Fperl.c;h=dc548b2590269328376cf6341b6d0b4ddc2891c8;hb=acbd25344a59c091b087311804d375b759077e32;hp=5cec1ed8bfcf04d06af57452234b891aa1527bfb;hpb=368a2bc5559829b5f4325301364790efeb9de236;p=collectd.git diff --git a/src/perl.c b/src/perl.c index 5cec1ed8..dc548b25 100644 --- a/src/perl.c +++ b/src/perl.c @@ -112,6 +112,9 @@ typedef struct { * point to the "base" thread */ static c_ithread_list_t *perl_threads = NULL; +/* the key used to store each pthread's ithread */ +static pthread_key_t perl_thr_key; + static int perl_argc = 0; static char **perl_argv = NULL; @@ -151,6 +154,24 @@ struct { { "", 0 } }; +struct { + char name[64]; + char *var; +} g_strings[] = +{ + { "Collectd::hostname_g", hostname_g }, + { "", NULL } +}; + +struct { + char name[64]; + int *var; +} g_integers[] = +{ + { "Collectd::interval_g", &interval_g }, + { "", NULL } +}; + /* * Helper functions for data type conversion. */ @@ -367,6 +388,7 @@ static char *get_module_name (char *buf, size_t buf_len, const char *module) { static int pplugin_register_data_set (pTHX_ char *name, AV *dataset) { int len = -1; + int ret = 0; int i = 0; data_source_t *ds = NULL; @@ -407,7 +429,12 @@ static int pplugin_register_data_set (pTHX_ char *name, AV *dataset) set->ds_num = len + 1; set->ds = ds; - return plugin_register_data_set (set); + + ret = plugin_register_data_set (set); + + free (ds); + free (set); + return ret; } /* static int pplugin_register_data_set (char *, SV *) */ /* @@ -775,6 +802,63 @@ static XS (Collectd_call_by_name) * This has been inspired by Perl's ithreads introduced in version 5.6.0. */ +/* must be called with perl_threads->mutex locked */ +static void c_ithread_destroy (c_ithread_t *ithread) +{ + dTHXa (ithread->interp); + + assert (NULL != perl_threads); + + PERL_SET_CONTEXT (aTHX); + log_debug ("Shutting down Perl interpreter %p...", aTHX); + +#if COLLECT_DEBUG + sv_report_used (); + + --perl_threads->number_of_threads; +#endif /* COLLECT_DEBUG */ + + perl_destruct (aTHX); + perl_free (aTHX); + + if (NULL == ithread->prev) + perl_threads->head = ithread->next; + else + ithread->prev->next = ithread->next; + + if (NULL == ithread->next) + perl_threads->tail = ithread->prev; + else + ithread->next->prev = ithread->prev; + + sfree (ithread); + return; +} /* static void c_ithread_destroy (c_ithread_t *) */ + +static void c_ithread_destructor (void *arg) +{ + c_ithread_t *ithread = (c_ithread_t *)arg; + c_ithread_t *t = NULL; + + if (NULL == perl_threads) + return; + + pthread_mutex_lock (&perl_threads->mutex); + + for (t = perl_threads->head; NULL != t; t = t->next) + if (t == ithread) + break; + + /* the ithread no longer exists */ + if (NULL == t) + return; + + c_ithread_destroy (ithread); + + pthread_mutex_unlock (&perl_threads->mutex); + return; +} /* static void c_ithread_destructor (void *) */ + /* must be called with perl_threads->mutex locked */ static c_ithread_t *c_ithread_create (PerlInterpreter *base) { @@ -814,6 +898,8 @@ static c_ithread_t *c_ithread_create (PerlInterpreter *base) } perl_threads->tail = t; + + pthread_setspecific (perl_thr_key, (const void *)t); return t; } /* static c_ithread_t *c_ithread_create (PerlInterpreter *) */ @@ -945,40 +1031,72 @@ static int perl_shutdown (void) t = perl_threads->tail; while (NULL != t) { - c_ithread_t *last = NULL; - - aTHX = t->interp; - PERL_SET_CONTEXT (aTHX); - - log_debug ("Shutting down Perl interpreter %p...", aTHX); - -#if COLLECT_DEBUG - sv_report_used (); -#endif /* COLLECT_DEBUG */ + c_ithread_t *thr = t; - perl_destruct (aTHX); - perl_free (aTHX); - - last = t; + /* the pointer has to be advanced before destroying + * the thread as this will free the memory */ t = t->prev; - sfree (last); + c_ithread_destroy (thr); } pthread_mutex_unlock (&perl_threads->mutex); + pthread_mutex_destroy (&perl_threads->mutex); sfree (perl_threads); + pthread_key_delete (perl_thr_key); + PERL_SYS_TERM (); plugin_unregister_shutdown ("perl"); return ret; } /* static void perl_shutdown (void) */ +/* + * Access functions for global variables. + * + * These functions implement the "magic" used to access + * the global variables from Perl. + */ + +static int g_pv_get (pTHX_ SV *var, MAGIC *mg) +{ + char *pv = mg->mg_ptr; + sv_setpv (var, pv); + return 0; +} /* static int g_pv_get (pTHX_ SV *, MAGIC *) */ + +static int g_pv_set (pTHX_ SV *var, MAGIC *mg) +{ + char *pv = mg->mg_ptr; + strncpy (pv, SvPV_nolen (var), DATA_MAX_NAME_LEN); + pv[DATA_MAX_NAME_LEN - 1] = '\0'; + return 0; +} /* static int g_pv_set (pTHX_ SV *, MAGIC *) */ + +static int g_iv_get (pTHX_ SV *var, MAGIC *mg) +{ + int *iv = (int *)mg->mg_ptr; + sv_setiv (var, *iv); + return 0; +} /* static int g_iv_get (pTHX_ SV *, MAGIC *) */ + +static int g_iv_set (pTHX_ SV *var, MAGIC *mg) +{ + int *iv = (int *)mg->mg_ptr; + *iv = (int)SvIV (var); + return 0; +} /* static int g_iv_set (pTHX_ SV *, MAGIC *) */ + +static MGVTBL g_pv_vtbl = { g_pv_get, g_pv_set, NULL, NULL, NULL }; +static MGVTBL g_iv_vtbl = { g_iv_get, g_iv_set, NULL, NULL, NULL }; + /* bootstrap the Collectd module */ static void xs_init (pTHX) { HV *stash = NULL; + SV *tmp = NULL; char *file = __FILE__; int i = 0; @@ -997,6 +1115,25 @@ static void xs_init (pTHX) /* export "constants" */ for (i = 0; '\0' != constants[i].name[0]; ++i) newCONSTSUB (stash, constants[i].name, newSViv (constants[i].value)); + + /* export global variables + * by adding "magic" to the SV's representing the globale variables + * perl is able to automagically call the get/set function when + * accessing any such variable (this is basically the same as using + * tie() in Perl) */ + /* global strings */ + for (i = 0; '\0' != g_strings[i].name[0]; ++i) { + tmp = get_sv (g_strings[i].name, 1); + sv_magicext (tmp, NULL, PERL_MAGIC_ext, &g_pv_vtbl, + g_strings[i].var, 0); + } + + /* global integers */ + for (i = 0; '\0' != g_integers[i].name[0]; ++i) { + tmp = get_sv (g_integers[i].name, 1); + sv_magicext (tmp, NULL, PERL_MAGIC_ext, &g_iv_vtbl, + (char *)g_integers[i].var, 0); + } return; } /* static void xs_init (pTHX) */ @@ -1018,6 +1155,13 @@ static int init_pi (int argc, char **argv) } #endif /* COLLECT_DEBUG */ + if (0 != pthread_key_create (&perl_thr_key, c_ithread_destructor)) { + log_err ("init_pi: pthread_key_create failed"); + + /* this must not happen - cowardly giving up if it does */ + exit (1); + } + PERL_SYS_INIT3 (&argc, &argv, &environ); perl_threads = (c_ithread_list_t *)smalloc (sizeof (c_ithread_list_t)); @@ -1032,7 +1176,7 @@ static int init_pi (int argc, char **argv) perl_threads->tail = perl_threads->head; if (NULL == (perl_threads->head->interp = perl_alloc ())) { - log_err ("module_register: Not enough memory."); + log_err ("init_pi: Not enough memory."); exit (3); } @@ -1044,7 +1188,7 @@ static int init_pi (int argc, char **argv) PL_exit_flags |= PERL_EXIT_DESTRUCT_END; if (0 != perl_parse (aTHX_ xs_init, argc, argv, NULL)) { - log_err ("module_register: Unable to bootstrap Collectd."); + log_err ("init_pi: Unable to bootstrap Collectd."); exit (1); } @@ -1073,8 +1217,10 @@ static int perl_config_loadplugin (pTHX_ oconfig_item_t *ci) char *value = NULL; if ((0 != ci->children_num) || (1 != ci->values_num) - || (OCONFIG_TYPE_STRING != ci->values[0].type)) + || (OCONFIG_TYPE_STRING != ci->values[0].type)) { + log_err ("LoadPlugin expects a single string argument."); return 1; + } value = ci->values[0].value.string; @@ -1103,8 +1249,10 @@ static int perl_config_basename (pTHX_ oconfig_item_t *ci) char *value = NULL; if ((0 != ci->children_num) || (1 != ci->values_num) - || (OCONFIG_TYPE_STRING != ci->values[0].type)) + || (OCONFIG_TYPE_STRING != ci->values[0].type)) { + log_err ("BaseName expects a single string argument."); return 1; + } value = ci->values[0].value.string; @@ -1122,8 +1270,10 @@ static int perl_config_enabledebugger (pTHX_ oconfig_item_t *ci) char *value = NULL; if ((0 != ci->children_num) || (1 != ci->values_num) - || (OCONFIG_TYPE_STRING != ci->values[0].type)) + || (OCONFIG_TYPE_STRING != ci->values[0].type)) { + log_err ("EnableDebugger expects a single string argument."); return 1; + } value = ci->values[0].value.string; @@ -1156,8 +1306,10 @@ static int perl_config_includedir (pTHX_ oconfig_item_t *ci) char *value = NULL; if ((0 != ci->children_num) || (1 != ci->values_num) - || (OCONFIG_TYPE_STRING != ci->values[0].type)) + || (OCONFIG_TYPE_STRING != ci->values[0].type)) { + log_err ("IncludeDir expects a single string argument."); return 1; + } value = ci->values[0].value.string;