/*
* Parse a configuration section, and populate a HV.
* This function is recursively called (allows to have nested hashes.)
*/
static void perl_parse_config(CONF_SECTION *cs, int lvl, HV *rad_hv)
{
if (!cs || !rad_hv) return;
int indent_section = (lvl + 1) * 4;
int indent_item = (lvl + 2) * 4;
DEBUG("%*s%s {", indent_section, " ", cf_section_name1(cs));
CONF_ITEM *ci = NULL;
while ((ci = cf_item_next(cs, ci))) {
/*
* This is a section.
* Create a new HV, store it as a reference in current HV,
* Then recursively call perl_parse_config with this section and the new HV.
*/
if (cf_item_is_section(ci)) {
CONF_SECTION *sub_cs = cf_item_to_section(ci);
char const *key = cf_section_name1(sub_cs); /* hash key */
HV *sub_hv;
SV *ref;
if (!key) continue;
if (hv_exists(rad_hv, key, strlen(key))) {
WARN("Ignoring duplicate config section '%s'", key);
continue;
}
sub_hv = newHV();
ref = newRV_inc((SV*) sub_hv);
(void)hv_store(rad_hv, key, strlen(key), ref, 0);
perl_parse_config(sub_cs, lvl + 1, sub_hv);
} else if (cf_item_is_pair(ci)){
CONF_PAIR *cp = cf_item_to_pair(ci);
char const *key = cf_pair_attr(cp); /* hash key */
char const *value = cf_pair_value(cp); /* hash value */
if (!key || !value) continue;
/*
* This is an item.
* Store item attr / value in current HV.
*/
if (hv_exists(rad_hv, key, strlen(key))) {
WARN("Ignoring duplicate config item '%s'", key);
continue;
}
(void)hv_store(rad_hv, key, strlen(key), newSVpvn(value, strlen(value)), 0);
DEBUG("%*s%s = %s", indent_item, " ", key, value);
}
}
DEBUG("%*s}", indent_section, " ");
}
/*
* Do any per-module initialization that is separate to each
* configured instance of the module. e.g. set up connections
* to external databases, read configuration files, set up
* dictionary entries, etc.
*
* If configuration information is given in the config section
* that must be referenced in later calls, store a handle to it
* in *instance otherwise put a null pointer there.
*
* Setup a hashes wich we will use later
* parse a module and give him a chance to live
*
*/
static int mod_instantiate(void *instance, CONF_SECTION *conf)
{
rlm_perl_t *inst = instance;
AV *end_AV;
char const **embed_c; /* Stupid Perl and lack of const consistency */
char **embed;
char **envp = NULL;
int exitstatus = 0, argc=0;
char arg[] = "0";
CONF_SECTION *cs;
#ifdef USE_ITHREADS
/*
* Create pthread key. This key will be stored in instance
*/
pthread_mutex_init(&inst->clone_mutex, NULL);
MEM(inst->thread_key = talloc_zero(inst, pthread_key_t));
rlm_perl_make_key(inst->thread_key);
#endif
/*
* Setup the argument array we pass to the perl interpreter
*/
MEM(embed_c = talloc_zero_array(inst, char const *, 4));
memcpy(&embed, &embed_c, sizeof(embed));
embed_c[0] = NULL;
if (inst->perl_flags) {
embed_c[1] = inst->perl_flags;
embed_c[2] = inst->module;
embed_c[3] = arg;
argc = 4;
} else {
embed_c[1] = inst->module;
embed_c[2] = arg;
argc = 3;
}
/*
* Create tweak the server's environment to support
* perl. Docs say only call this once... Oops.
*/
if (!perl_sys_init3_called) {
PERL_SYS_INIT3(&argc, &embed, &envp);
perl_sys_init3_called = 1;
}
/*
* Allocate a new perl interpreter to do the parsing
*/
if ((inst->perl = perl_alloc()) == NULL) {
ERROR("No memory for allocating new perl interpretor!");
return -1;
}
perl_construct(inst->perl); /* ...and initialise it */
#ifdef USE_ITHREADS
PL_perl_destruct_level = 2;
{
dTHXa(inst->perl);
}
PERL_SET_CONTEXT(inst->perl);
#endif
#if PERL_REVISION >= 5 && PERL_VERSION >=8
PL_exit_flags |= PERL_EXIT_DESTRUCT_END;
#endif
exitstatus = perl_parse(inst->perl, xs_init, argc, embed, NULL);
end_AV = PL_endav;
PL_endav = (AV *)NULL;
if (exitstatus) {
ERROR("Perl_parse failed: %s not found or has syntax errors", inst->module);
return -1;
}
/* parse perl configuration sub-section */
cs = cf_section_find(conf, "config", NULL);
if (cs) {
inst->rad_perlconf_hv = get_hv("RAD_PERLCONF", 1);
perl_parse_config(cs, 0, inst->rad_perlconf_hv);
}
inst->perl_parsed = true;
perl_run(inst->perl);
PL_endav = end_AV;
return 0;
}
/*
* Do any per-module initialization that is separate to each
* configured instance of the module. e.g. set up connections
* to external databases, read configuration files, set up
* dictionary entries, etc.
*
* If configuration information is given in the config section
* that must be referenced in later calls, store a handle to it
* in *instance otherwise put a null pointer there.
*
* Setup a hashes wich we will use later
* parse a module and give him a chance to live
*
*/
static int mod_instantiate(CONF_SECTION *conf, void *instance)
{
rlm_perl_t *inst = instance;
AV *end_AV;
char const **embed_c; /* Stupid Perl and lack of const consistency */
char **embed;
char **envp = NULL;
char const *xlat_name;
int exitstatus = 0, argc=0;
MEM(embed_c = talloc_zero_array(inst, char const *, 4));
memcpy(&embed, &embed_c, sizeof(embed));
/*
* Create pthread key. This key will be stored in instance
*/
#ifdef USE_ITHREADS
pthread_mutex_init(&inst->clone_mutex, NULL);
inst->thread_key = rad_malloc(sizeof(*inst->thread_key));
memset(inst->thread_key,0,sizeof(*inst->thread_key));
rlm_perl_make_key(inst->thread_key);
#endif
char arg[] = "0";
embed_c[0] = NULL;
if (inst->perl_flags) {
embed_c[1] = inst->perl_flags;
embed_c[2] = inst->module;
embed_c[3] = arg;
argc = 4;
} else {
embed_c[1] = inst->module;
embed_c[2] = arg;
argc = 3;
}
PERL_SYS_INIT3(&argc, &embed, &envp);
if ((inst->perl = perl_alloc()) == NULL) {
ERROR("rlm_perl: No memory for allocating new perl !");
return (-1);
}
perl_construct(inst->perl);
#ifdef USE_ITHREADS
PL_perl_destruct_level = 2;
{
dTHXa(inst->perl);
}
PERL_SET_CONTEXT(inst->perl);
#endif
#if PERL_REVISION >= 5 && PERL_VERSION >=8
PL_exit_flags |= PERL_EXIT_DESTRUCT_END;
#endif
exitstatus = perl_parse(inst->perl, xs_init, argc, embed, NULL);
end_AV = PL_endav;
PL_endav = Nullav;
if(!exitstatus) {
perl_run(inst->perl);
} else {
ERROR("rlm_perl: perl_parse failed: %s not found or has syntax errors. \n", inst->module);
return (-1);
}
PL_endav = end_AV;
xlat_name = cf_section_name2(conf);
if (!xlat_name)
xlat_name = cf_section_name1(conf);
if (xlat_name) {
xlat_register(xlat_name, perl_xlat, NULL, inst);
}
/* parse perl configuration sub-section */
CONF_SECTION *cs;
cs = cf_section_sub_find(conf, "config");
if (cs) {
DEBUG("rlm_perl (%s): parsing 'config' section...", xlat_name);
inst->rad_perlconf_hv = get_hv("RAD_PERLCONF",1);
perl_parse_config(cs, 0, inst->rad_perlconf_hv);
DEBUG("rlm_perl (%s): done parsing 'config'.", xlat_name);
}
return 0;
}
