X-Git-Url: https://git.octo.it/?a=blobdiff_plain;f=src%2Fperl.c;h=82b9b8c1454262ab0e1c7709718edebee2624908;hb=49ac868d2346c77335272b8a643bca295db9feaa;hp=78e508ae4d1f1bb7c0b9ae5c9ca340b9685e79e6;hpb=b61a03b05c1f4040a6599334b65141aa3bd134f5;p=collectd.git diff --git a/src/perl.c b/src/perl.c index 78e508ae..82b9b8c1 100644 --- a/src/perl.c +++ b/src/perl.c @@ -2,20 +2,25 @@ * collectd - src/perl.c * Copyright (C) 2007-2009 Sebastian Harl * - * This program is free software; you can redistribute it and/or modify it - * under the terms of the GNU General Public License as published by the - * Free Software Foundation; only version 2 of the License is applicable. + * Permission is hereby granted, free of charge, to any person obtaining a + * copy of this software and associated documentation files (the "Software"), + * to deal in the Software without restriction, including without limitation + * the rights to use, copy, modify, merge, publish, distribute, sublicense, + * and/or sell copies of the Software, and to permit persons to whom the + * Software is furnished to do so, subject to the following conditions: * - * This program is distributed in the hope that it will be useful, but - * WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU - * General Public License for more details. + * The above copyright notice and this permission notice shall be included in + * all copies or substantial portions of the Software. * - * You should have received a copy of the GNU General Public License along - * with this program; if not, write to the Free Software Foundation, Inc., - * 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA + * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR + * IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, + * FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE + * AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER + * LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING + * FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER + * DEALINGS IN THE SOFTWARE. * - * Author: + * Authors: * Sebastian Harl **/ @@ -24,7 +29,7 @@ * interface for collectd plugins written in perl. */ -/* do not automatically get the thread specific perl interpreter */ +/* do not automatically get the thread specific Perl interpreter */ #define PERL_NO_GET_CONTEXT #define DONT_POISON_SPRINTF_YET 1 @@ -41,6 +46,7 @@ #include #if defined(COLLECT_DEBUG) && COLLECT_DEBUG && defined(__GNUC__) && __GNUC__ +# undef sprintf # pragma GCC poison sprintf #endif @@ -117,6 +123,9 @@ static XS (Collectd_call_by_name); typedef struct c_ithread_s { /* the thread's Perl interpreter */ PerlInterpreter *interp; + _Bool running; /* thread is inside Perl interpreter */ + _Bool shutdown; + pthread_t pthread; /* double linked list of threads */ struct c_ithread_s *prev; @@ -133,6 +142,7 @@ typedef struct { #endif /* COLLECT_DEBUG */ pthread_mutex_t mutex; + pthread_mutexattr_t mutexattr; } c_ithread_list_t; /* name / user_data for Perl matches / targets */ @@ -510,7 +520,6 @@ static int av2notification_meta (pTHX_ AV *array, notification_meta_t **meta) if (NULL == (tmp = hv_fetch (hash, "value", 5, 0))) { log_warn ("av2notification_meta: Skipping invalid " "meta information."); - free ((*m)->name); free (*m); continue; } @@ -1003,6 +1012,32 @@ static int pplugin_dispatch_notification (pTHX_ HV *notif) } /* static int pplugin_dispatch_notification (HV *) */ /* + * Call perl sub with thread locking flags handled. + */ +static int call_pv_locked (pTHX_ const char* sub_name) +{ + _Bool old_running; + int ret; + + c_ithread_t *t = (c_ithread_t *)pthread_getspecific(perl_thr_key); + if (t == NULL) /* thread destroyed */ + return 0; + + old_running = t->running; + t->running = 1; + + if (t->shutdown) { + t->running = old_running; + return 0; + } + + ret = call_pv (sub_name, G_SCALAR); + + t->running = old_running; + return ret; +} /* static int call_pv_locked (pTHX, *sub_name) */ + +/* * Call all working functions of the given type. */ static int pplugin_call_all (pTHX_ int type, ...) @@ -1131,7 +1166,7 @@ static int pplugin_call_all (pTHX_ int type, ...) PUTBACK; - retvals = call_pv ("Collectd::plugin_call_all", G_SCALAR); + retvals = call_pv_locked (aTHX_ "Collectd::plugin_call_all"); SPAGAIN; if (0 < retvals) { @@ -1149,7 +1184,7 @@ static int pplugin_call_all (pTHX_ int type, ...) } /* static int pplugin_call_all (int, ...) */ /* - * collectd's perl interpreter based thread implementation. + * collectd's Perl interpreter based thread implementation. * * This has been inspired by Perl's ithreads introduced in version 5.6.0. */ @@ -1203,7 +1238,10 @@ static void c_ithread_destructor (void *arg) /* the ithread no longer exists */ if (NULL == t) + { + pthread_mutex_unlock (&perl_threads->mutex); return; + } c_ithread_destroy (ithread); @@ -1249,6 +1287,9 @@ static c_ithread_t *c_ithread_create (PerlInterpreter *base) t->prev = perl_threads->tail; } + t->pthread = pthread_self(); + t->running = 0; + t->shutdown = 0; perl_threads->tail = t; pthread_setspecific (perl_thr_key, (const void *)t); @@ -1369,7 +1410,7 @@ static int fc_call (pTHX_ int type, int cb_type, pfc_user_data_t *data, ...) PUTBACK; - retvals = call_pv ("Collectd::fc_call", G_SCALAR); + retvals = call_pv_locked (aTHX_ "Collectd::fc_call"); if ((FC_CB_EXEC == cb_type) && (meta != NULL)) { assert (pmeta != NULL); @@ -1644,15 +1685,15 @@ static XS (Collectd_plugin_dispatch_values) values = ST (/* stack index = */ 0); + if (NULL == values) + XSRETURN_EMPTY; + /* Make sure the argument is a hash reference. */ if (! (SvROK (values) && (SVt_PVHV == SvTYPE (SvRV (values))))) { log_err ("Collectd::plugin_dispatch_values: Invalid values."); XSRETURN_EMPTY; } - if (NULL == values) - XSRETURN_EMPTY; - ret = pplugin_dispatch_values (aTHX_ (HV *)SvRV (values)); if (0 == ret) @@ -1909,6 +1950,7 @@ static XS (Collectd_call_by_name) static int perl_init (void) { + int status; dTHX; if (NULL == perl_threads) @@ -1926,7 +1968,19 @@ static int perl_init (void) log_debug ("perl_init: c_ithread: interp = %p (active threads: %i)", aTHX, perl_threads->number_of_threads); - return pplugin_call_all (aTHX_ PLUGIN_INIT); + + /* Lock the base thread to avoid race conditions with c_ithread_create(). + * See https://github.com/collectd/collectd/issues/9 and + * https://github.com/collectd/collectd/issues/1706 for details. + */ + assert (aTHX == perl_threads->head->interp); + pthread_mutex_lock (&perl_threads->mutex); + + status = pplugin_call_all (aTHX_ PLUGIN_INIT); + + pthread_mutex_unlock (&perl_threads->mutex); + + return status; } /* static int perl_init (void) */ static int perl_read (void) @@ -2011,7 +2065,9 @@ static void perl_log (int level, const char *msg, /* Lock the base thread if this is not called from one of the read threads * to avoid race conditions with c_ithread_create(). See - * https://github.com/collectd/collectd/issues/9 for details. */ + * https://github.com/collectd/collectd/issues/9 for details. + */ + if (aTHX == perl_threads->head->interp) pthread_mutex_lock (&perl_threads->mutex); @@ -2077,7 +2133,7 @@ static int perl_shutdown (void) return 0; if (NULL == aTHX) { - c_ithread_t *t = NULL; + t = NULL; pthread_mutex_lock (&perl_threads->mutex); t = c_ithread_create (perl_threads->head->interp); @@ -2102,17 +2158,31 @@ static int perl_shutdown (void) t = perl_threads->tail; while (NULL != t) { + struct timespec ts_wait; c_ithread_t *thr = t; /* the pointer has to be advanced before destroying * the thread as this will free the memory */ t = t->prev; + thr->shutdown = 1; + if (thr->running) { + /* Give some time to thread to exit from Perl interpreter */ + WARNING ("perl shutdown: Thread is running inside Perl. Waiting."); + ts_wait.tv_sec = 0; + ts_wait.tv_nsec = 500000; + nanosleep (&ts_wait, NULL); + } + if (thr->running) { + pthread_kill (thr->pthread, SIGTERM); + ERROR ("perl shutdown: Thread hangs inside Perl. Thread killed."); + } c_ithread_destroy (thr); } pthread_mutex_unlock (&perl_threads->mutex); pthread_mutex_destroy (&perl_threads->mutex); + pthread_mutexattr_destroy (&perl_threads->mutexattr); sfree (perl_threads); @@ -2256,7 +2326,9 @@ static int init_pi (int argc, char **argv) perl_threads = (c_ithread_list_t *)smalloc (sizeof (c_ithread_list_t)); memset (perl_threads, 0, sizeof (c_ithread_list_t)); - pthread_mutex_init (&perl_threads->mutex, NULL); + pthread_mutexattr_init(&perl_threads->mutexattr); + pthread_mutexattr_settype(&perl_threads->mutexattr, PTHREAD_MUTEX_RECURSIVE); + pthread_mutex_init (&perl_threads->mutex, &perl_threads->mutexattr); /* locking the mutex should not be necessary at this point * but let's just do it for the sake of completeness */ pthread_mutex_lock (&perl_threads->mutex); @@ -2337,7 +2409,7 @@ static int perl_config_loadplugin (pTHX_ oconfig_item_t *ci) aTHX = perl_threads->head->interp; - log_debug ("perl_config: loading perl plugin \"%s\"", value); + log_debug ("perl_config: Loading Perl plugin \"%s\"", value); load_module (PERL_LOADMOD_NOIMPORT, newSVpv (module_name, strlen (module_name)), Nullsv); return 0; @@ -2510,7 +2582,10 @@ static int perl_config (oconfig_item_t *ci) int current_status = 0; if (NULL != perl_threads) - aTHX = PERL_GET_CONTEXT; + { + if ((aTHX = PERL_GET_CONTEXT) == NULL) + return -1; + } if (0 == strcasecmp (c->key, "LoadPlugin")) current_status = perl_config_loadplugin (aTHX_ c);