static void rlm_perl_destruct(PerlInterpreter *perl)
{
dTHXa(perl);
PERL_SET_CONTEXT(perl);
PL_perl_destruct_level = 2;
PL_origenviron = environ;
{
dTHXa(perl);
}
/*
* FIXME: This shouldn't happen
*
*/
while (PL_scopestack_ix > 1) {
LEAVE;
}
perl_destruct(perl);
perl_free(perl);
}
static PerlInterpreter *rlm_perl_clone(PerlInterpreter *perl, pthread_key_t *key)
{
PerlInterpreter *interp;
UV clone_flags = 0;
PERL_SET_CONTEXT(perl);
interp = pthread_getspecific(*key);
if (interp) return interp;
interp = perl_clone(perl, clone_flags);
{
dTHXa(interp);
}
#if PERL_REVISION >= 5 && PERL_VERSION <8
call_pv("CLONE",0);
#endif
ptr_table_free(PL_ptr_table);
PL_ptr_table = NULL;
PERL_SET_CONTEXT(aTHX);
rlm_perl_clear_handles(aTHX);
pthread_setspecific(*key, interp);
return interp;
}
static PerlInterpreter *rlm_perl_clone(PerlInterpreter *perl, pthread_key_t *key)
{
int ret;
PerlInterpreter *interp;
UV clone_flags = 0;
PERL_SET_CONTEXT(perl);
interp = pthread_getspecific(*key);
if (interp) return interp;
interp = perl_clone(perl, clone_flags);
{
dTHXa(interp);
}
# if PERL_REVISION >= 5 && PERL_VERSION <8
call_pv("CLONE",0);
# endif
ptr_table_free(PL_ptr_table);
PL_ptr_table = NULL;
PERL_SET_CONTEXT(aTHX);
rlm_perl_clear_handles(aTHX);
ret = pthread_setspecific(*key, interp);
if (ret != 0) {
DEBUG("Failed associating interpretor with thread %s", fr_syserror(ret));
rlm_perl_destruct(interp);
return NULL;
}
return interp;
}
/*
* The xlat function
*/
static ssize_t perl_xlat(void *instance, REQUEST *request, char const *fmt, char *out, size_t freespace)
{
rlm_perl_t *inst= (rlm_perl_t *) instance;
char *tmp;
char const *p, *q;
int count;
size_t ret = 0;
STRLEN n_a;
#ifdef USE_ITHREADS
PerlInterpreter *interp;
pthread_mutex_lock(&inst->clone_mutex);
interp = rlm_perl_clone(inst->perl, inst->thread_key);
{
dTHXa(interp);
PERL_SET_CONTEXT(interp);
}
pthread_mutex_unlock(&inst->clone_mutex);
#else
PERL_SET_CONTEXT(inst->perl);
#endif
{
dSP;
ENTER;SAVETMPS;
PUSHMARK(SP);
p = fmt;
while ((q = strchr(p, ' '))) {
XPUSHs(sv_2mortal(newSVpv(p, p - q)));
p = q + 1;
}
PUTBACK;
count = call_pv(inst->func_xlat, G_SCALAR | G_EVAL);
SPAGAIN;
if (SvTRUE(ERRSV)) {
REDEBUG("Exit %s", SvPV(ERRSV,n_a));
(void)POPs;
} else if (count > 0) {
tmp = POPp;
strlcpy(out, tmp, freespace);
ret = strlen(out);
RDEBUG("Len is %zu , out is %s freespace is %zu", ret, out, freespace);
}
PUTBACK ;
FREETMPS ;
LEAVE ;
}
return ret;
}
static char *
ngx_http_perl_set(ngx_conf_t *cf, ngx_command_t *cmd, void *conf)
{
ngx_int_t index;
ngx_str_t *value;
ngx_http_variable_t *v;
ngx_http_perl_variable_t *pv;
ngx_http_perl_main_conf_t *pmcf;
value = cf->args->elts;
if (value[1].data[0] != '$')
{
ngx_conf_log_error(NGX_LOG_EMERG, cf, 0,
"invalid variable name \"%V\"", &value[1]);
return NGX_CONF_ERROR;
}
value[1].len--;
value[1].data++;
v = ngx_http_add_variable(cf, &value[1], NGX_HTTP_VAR_CHANGEABLE);
if (v == NULL)
{
return NGX_CONF_ERROR;
}
pv = ngx_palloc(cf->pool, sizeof(ngx_http_perl_variable_t));
if (pv == NULL)
{
return NGX_CONF_ERROR;
}
index = ngx_http_get_variable_index(cf, &value[1]);
if (index == NGX_ERROR)
{
return NGX_CONF_ERROR;
}
pmcf = ngx_http_conf_get_module_main_conf(cf, ngx_http_perl_module);
if (pmcf->perl == NULL)
{
if (ngx_http_perl_init_interpreter(cf, pmcf) != NGX_CONF_OK)
{
return NGX_CONF_ERROR;
}
}
pv->handler = value[2];
{
dTHXa(pmcf->perl);
PERL_SET_CONTEXT(pmcf->perl);
ngx_http_perl_eval_anon_sub(aTHX_ & value[2], &pv->sub);
if (pv->sub == &PL_sv_undef)
{
ngx_conf_log_error(NGX_LOG_ERR, cf, 0,
"eval_pv(\"%V\") failed", &value[2]);
return NGX_CONF_ERROR;
}
if (pv->sub == NULL)
{
pv->sub = newSVpvn((char *) value[2].data, value[2].len);
}
}
v->get_handler = ngx_http_perl_variable;
v->data = (uintptr_t) pv;
return NGX_CONF_OK;
}
static PerlInterpreter *rlm_perl_clone(PerlInterpreter *perl)
{
PerlInterpreter *interp;
UV clone_flags = 0;
PERL_SET_CONTEXT(perl);
pthread_once(&rlm_perl_once, rlm_perl_make_key);
interp = pthread_getspecific(rlm_perl_key);
if (interp) return interp;
interp = perl_clone(perl, clone_flags);
{
dTHXa(interp);
}
#if PERL_REVISION >= 5 && PERL_VERSION <8
call_pv("CLONE",0);
#endif
ptr_table_free(PL_ptr_table);
PL_ptr_table = NULL;
PERL_SET_CONTEXT(aTHX);
rlm_perl_clear_handles(aTHX);
pthread_setspecific(rlm_perl_key, interp);
fprintf(stderr, "GOT CLONE %d %p\n", pthread_self(), interp);
return interp;
}
ngx_int_t
ngx_http_psgi_perl_init_worker(ngx_cycle_t *cycle)
{
ngx_http_psgi_main_conf_t *psgimcf =
ngx_http_cycle_get_module_main_conf(cycle, ngx_http_psgi_module);
ngx_log_debug1(NGX_LOG_DEBUG_HTTP, cycle->log, 0,
"Init Perl interpreter in worker %d", ngx_pid);
if (psgimcf) {
dTHXa(psgimcf->perl);
PERL_SET_CONTEXT(psgimcf->perl);
/* FIXME: It looks very wrong.
* Has new worker it's own Perl instance?
* I think I should perl_clone() or something like that
* Also $0 (script path) should be set somewhere.
* I don't think it's right place for it. It should be done somewhere in local conf init stuff
* Or, if many handlers share single Perl interpreter - before each handler call
*
* TODO
* Test PID and related stuff
* Test what happens if user try to change
* Test what happens if user does 'fork' inside PSGI app
*/
sv_setiv(GvSV(gv_fetchpv("$$", TRUE, SVt_PV)), (I32) ngx_pid);
} else {
ngx_log_error(NGX_LOG_ALERT, cycle->log, 0, "PSGI panic: no main configuration supplied for init worker %d", ngx_pid);
return NGX_ERROR;
}
return NGX_OK;
}
static ngx_int_t
ngx_http_perl_variable(ngx_http_request_t *r, ngx_http_variable_value_t *v,
uintptr_t data)
{
ngx_http_perl_variable_t *pv = (ngx_http_perl_variable_t *) data;
ngx_int_t rc;
ngx_str_t value;
ngx_http_perl_ctx_t *ctx;
ngx_http_perl_main_conf_t *pmcf;
ngx_log_debug0(NGX_LOG_DEBUG_HTTP, r->connection->log, 0,
"perl variable handler");
ctx = ngx_http_get_module_ctx(r, ngx_http_perl_module);
if (ctx == NULL) {
ctx = ngx_pcalloc(r->pool, sizeof(ngx_http_perl_ctx_t));
if (ctx == NULL) {
return NGX_ERROR;
}
ngx_http_set_ctx(r, ctx, ngx_http_perl_module);
}
pmcf = ngx_http_get_module_main_conf(r, ngx_http_perl_module);
value.data = NULL;
{
dTHXa(pmcf->perl);
PERL_SET_CONTEXT(pmcf->perl);
rc = ngx_http_perl_call_handler(aTHX_ r, pmcf->nginx, pv->sub, NULL,
&pv->handler, &value);
}
if (value.data) {
v->len = value.len;
v->valid = 1;
v->no_cacheable = 0;
v->not_found = 0;
v->data = value.data;
} else {
v->not_found = 1;
}
ctx->filename.data = NULL;
ctx->redirect_uri.len = 0;
ngx_log_debug0(NGX_LOG_DEBUG_HTTP, r->connection->log, 0,
"perl variable done");
return rc;
}
static void rlm_destroy_perl(PerlInterpreter *perl)
{
void **handles;
dTHXa(perl);
PERL_SET_CONTEXT(perl);
handles = rlm_perl_get_handles(aTHX);
if (handles) rlm_perl_close_handles(handles);
rlm_perl_destruct(perl);
}
struct servent *
win32_getservbyport(int port, const char *proto)
{
dTHXa(NULL);
struct servent *r;
SOCKET_TEST(r = getservbyport(port, proto), NULL);
if (r) {
aTHXa(PERL_GET_THX);
r = win32_savecopyservent(&w32_servent, r, proto);
}
return r;
}
static char *
ngx_http_perl(ngx_conf_t *cf, ngx_command_t *cmd, void *conf)
{
ngx_http_perl_loc_conf_t *plcf = conf;
ngx_str_t *value;
ngx_http_core_loc_conf_t *clcf;
ngx_http_perl_main_conf_t *pmcf;
value = cf->args->elts;
if (plcf->handler.data) {
ngx_conf_log_error(NGX_LOG_EMERG, cf, 0,
"duplicate perl handler \"%V\"", &value[1]);
return NGX_CONF_ERROR;
}
pmcf = ngx_http_conf_get_module_main_conf(cf, ngx_http_perl_module);
if (pmcf->perl == NULL) {
if (ngx_http_perl_init_interpreter(cf, pmcf) != NGX_CONF_OK) {
return NGX_CONF_ERROR;
}
}
plcf->handler = value[1];
{
dTHXa(pmcf->perl);
PERL_SET_CONTEXT(pmcf->perl);
ngx_http_perl_eval_anon_sub(aTHX_ &value[1], &plcf->sub);
if (plcf->sub == &PL_sv_undef) {
ngx_conf_log_error(NGX_LOG_ERR, cf, 0,
"eval_pv(\"%V\") failed", &value[1]);
return NGX_CONF_ERROR;
}
if (plcf->sub == NULL) {
plcf->sub = newSVpvn((char *) value[1].data, value[1].len);
}
}
clcf = ngx_http_conf_get_module_loc_conf(cf, ngx_http_core_module);
clcf->handler = ngx_http_perl_handler;
return NGX_CONF_OK;
}
static ngx_int_t
ngx_http_perl_init_worker(ngx_cycle_t *cycle)
{
ngx_http_perl_main_conf_t *pmcf;
pmcf = ngx_http_cycle_get_module_main_conf(cycle, ngx_http_perl_module);
if (pmcf)
{
dTHXa(pmcf->perl);
PERL_SET_CONTEXT(pmcf->perl);
/* set worker's $$ */
sv_setiv(GvSV(gv_fetchpv("$", TRUE, SVt_PV)), (I32) ngx_pid);
}
return NGX_OK;
}
PerlInterpreter *
ngx_http_psgi_create_interpreter(ngx_conf_t *cf)
{
int n;
PerlInterpreter *perl;
ngx_log_debug0(NGX_LOG_DEBUG_HTTP, cf->log, 0,
"Create PSGI Perl interpreter");
/* FIXME: Some code from ngx_http_perl_module.c I don't understand */
if (ngx_set_environment(cf->cycle, NULL) == NULL) {
return NULL;
}
perl = perl_alloc();
if (perl == NULL) {
ngx_log_error(NGX_LOG_ALERT, cf->log, 0, "perl_alloc() failed");
return NULL;
}
{
char *my_argv[] = { "", "-MIO::Handle", "-e", "0" };
dTHXa(perl);
PERL_SET_CONTEXT(perl);
perl_construct(perl);
n = perl_parse(perl, xs_init, 3, my_argv, NULL);
if (n != 0) {
ngx_log_error(NGX_LOG_ALERT, cf->log, 3, "perl_parse() failed: %d", n);
goto fail;
}
PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_nginx_error));
}
return perl;
fail:
(void) perl_destruct(perl);
perl_free(perl);
return NULL;
}
static void get_names_callback(const CMacroInfo *pmi)
{
struct get_names_cb_arg *a = pmi->arg;
if (a->ll)
{
dTHXa(a->interp);
LL_push(a->ll, newSVpv(pmi->name, 0));
}
else
{
a->count++;
}
}
static void
ngx_http_perl_exit(ngx_cycle_t *cycle)
{
ngx_http_perl_main_conf_t *pmcf;
pmcf = ngx_http_cycle_get_module_main_conf(cycle, ngx_http_perl_module);
{
dTHXa(pmcf->perl);
PERL_SET_CONTEXT(pmcf->perl);
PERL_SYS_TERM();
}
}
static int mod_detach(void *instance)
{
rlm_perl_t *inst = (rlm_perl_t *) instance;
int exitstatus = 0, count = 0;
if (inst->perl_parsed) {
dTHXa(inst->perl);
PERL_SET_CONTEXT(inst->perl);
if (inst->rad_perlconf_hv != NULL) hv_undef(inst->rad_perlconf_hv);
if (inst->func_detach) {
dSP; ENTER; SAVETMPS;
PUSHMARK(SP);
count = call_pv(inst->func_detach, G_SCALAR | G_EVAL );
SPAGAIN;
if (count == 1) {
exitstatus = POPi;
if (exitstatus >= 100 || exitstatus < 0) {
exitstatus = RLM_MODULE_FAIL;
}
}
PUTBACK;
FREETMPS;
LEAVE;
}
}
#ifdef USE_ITHREADS
rlm_perl_destruct(inst->perl);
pthread_mutex_destroy(&inst->clone_mutex);
#else
perl_destruct(inst->perl);
perl_free(inst->perl);
#endif
/*
* Hope this is not really needed.
* Is only allowed to be called once just before exit().
*
PERL_SYS_TERM();
*/
return exitstatus;
}
static MP_INLINE
apr_status_t modperl_cleanup_pnotes(void *data) {
HV **pnotes = data;
if (*pnotes) {
#ifdef USE_ITHREADS
modperl_cleanup_pnotes_data_t *cleanup_data = data;
dTHXa(cleanup_data->perl);
pnotes = cleanup_data->pnotes;
#else
pnotes = data;
#endif
SvREFCNT_dec(*pnotes);
*pnotes = (HV *)NULL;
}
return APR_SUCCESS;
}
/* all ap_filter_t filter cleanups should go here */
static apr_status_t modperl_filter_f_cleanup(void *data)
{
ap_filter_t *f = (ap_filter_t *)data;
modperl_filter_ctx_t *ctx = (modperl_filter_ctx_t *)(f->ctx);
/* mod_perl filter ctx cleanup */
if (ctx->data){
#ifdef USE_ITHREADS
dTHXa(ctx->perl);
#endif
if (SvOK(ctx->data) && SvREFCNT(ctx->data)) {
SvREFCNT_dec(ctx->data);
ctx->data = NULL;
}
ctx->perl = NULL;
}
return APR_SUCCESS;
}
static PerlInterpreter *rlm_perl_clone(PerlInterpreter *perl)
{
PerlInterpreter *clone;
UV clone_flags = 0;
PERL_SET_CONTEXT(perl);
clone = perl_clone(perl, clone_flags);
{
dTHXa(clone);
}
#if PERL_REVISION >= 5 && PERL_VERSION <8
call_pv("CLONE",0);
#endif
ptr_table_free(PL_ptr_table);
PL_ptr_table = NULL;
PERL_SET_CONTEXT(aTHX);
rlm_perl_clear_handles(aTHX);
return clone;
}
/*
* Call the function_name inside the module
* Store all vps in hashes %RAD_CONFIG %RAD_REPLY %RAD_REQUEST
*
*/
static int do_perl(void *instance, REQUEST *request, char const *function_name)
{
rlm_perl_t *inst = instance;
VALUE_PAIR *vp;
int exitstatus=0, count;
STRLEN n_a;
HV *rad_reply_hv;
HV *rad_config_hv;
HV *rad_request_hv;
HV *rad_state_hv;
#ifdef WITH_PROXY
HV *rad_request_proxy_hv;
HV *rad_request_proxy_reply_hv;
#endif
/*
* Radius has told us to call this function, but none
* is defined.
*/
if (!function_name) return RLM_MODULE_FAIL;
#ifdef USE_ITHREADS
pthread_mutex_lock(&inst->clone_mutex);
PerlInterpreter *interp;
interp = rlm_perl_clone(inst->perl,inst->thread_key);
{
dTHXa(interp);
PERL_SET_CONTEXT(interp);
}
pthread_mutex_unlock(&inst->clone_mutex);
#else
PERL_SET_CONTEXT(inst->perl);
#endif
{
dSP;
ENTER;
SAVETMPS;
rad_reply_hv = get_hv("RAD_REPLY", 1);
rad_config_hv = get_hv("RAD_CONFIG", 1);
rad_request_hv = get_hv("RAD_REQUEST", 1);
rad_state_hv = get_hv("RAD_STATE", 1);
perl_store_vps(request->packet, request, &request->packet->vps, rad_request_hv, "RAD_REQUEST", "request");
perl_store_vps(request->reply, request, &request->reply->vps, rad_reply_hv, "RAD_REPLY", "reply");
perl_store_vps(request, request, &request->control, rad_config_hv, "RAD_CONFIG", "control");
perl_store_vps(request->state_ctx, request, &request->state, rad_state_hv, "RAD_STATE", "session-state");
#ifdef WITH_PROXY
rad_request_proxy_hv = get_hv("RAD_REQUEST_PROXY",1);
rad_request_proxy_reply_hv = get_hv("RAD_REQUEST_PROXY_REPLY",1);
if (request->proxy) {
perl_store_vps(request->proxy->packet, request, &request->proxy->packet->vps, rad_request_proxy_hv,
"RAD_REQUEST_PROXY", "proxy-request");
} else {
hv_undef(rad_request_proxy_hv);
}
if (request->proxy && request->proxy->reply != NULL) {
perl_store_vps(request->proxy->reply, request, &request->proxy->reply->vps,
rad_request_proxy_reply_hv, "RAD_REQUEST_PROXY_REPLY", "proxy-reply");
} else {
hv_undef(rad_request_proxy_reply_hv);
}
#endif
/*
* Store pointer to request structure globally so radiusd::xlat works
*/
rlm_perl_request = request;
PUSHMARK(SP);
/*
* This way %RAD_xx can be pushed onto stack as sub parameters.
* XPUSHs( newRV_noinc((SV *)rad_request_hv) );
* XPUSHs( newRV_noinc((SV *)rad_reply_hv) );
* XPUSHs( newRV_noinc((SV *)rad_config_hv) );
* PUTBACK;
*/
count = call_pv(function_name, G_SCALAR | G_EVAL | G_NOARGS);
SPAGAIN;
if (SvTRUE(ERRSV)) {
REDEBUG("perl_embed:: module = %s , func = %s exit status= %s\n",
inst->module, function_name, SvPV(ERRSV,n_a));
(void)POPs;
exitstatus = RLM_MODULE_FAIL;
} else if (count == 1) {
exitstatus = POPi;
if (exitstatus >= 100 || exitstatus < 0) {
exitstatus = RLM_MODULE_FAIL;
}
}
PUTBACK;
FREETMPS;
LEAVE;
vp = NULL;
if ((get_hv_content(request->packet, request, rad_request_hv, &vp, "RAD_REQUEST", "request")) == 0) {
fr_pair_list_free(&request->packet->vps);
request->packet->vps = vp;
vp = NULL;
/*
* Update cached copies
*/
request->username = fr_pair_find_by_da(request->packet->vps, attr_user_name, TAG_ANY);
request->password = fr_pair_find_by_da(request->packet->vps, attr_user_password, TAG_ANY);
if (!request->password) request->password = fr_pair_find_by_da(request->packet->vps,
attr_chap_password,
TAG_ANY);
}
if ((get_hv_content(request->reply, request, rad_reply_hv, &vp, "RAD_REPLY", "reply")) == 0) {
fr_pair_list_free(&request->reply->vps);
request->reply->vps = vp;
vp = NULL;
}
if ((get_hv_content(request, request, rad_config_hv, &vp, "RAD_CONFIG", "control")) == 0) {
fr_pair_list_free(&request->control);
request->control = vp;
vp = NULL;
}
if ((get_hv_content(request->state_ctx, request, rad_state_hv, &vp, "RAD_STATE", "session-state")) == 0) {
fr_pair_list_free(&request->state);
request->state = vp;
vp = NULL;
}
#ifdef WITH_PROXY
if (request->proxy &&
(get_hv_content(request->proxy->packet, request, rad_request_proxy_hv, &vp,
"RAD_REQUEST_PROXY", "proxy-request") == 0)) {
fr_pair_list_free(&request->proxy->packet->vps);
request->proxy->packet->vps = vp;
vp = NULL;
}
if (request->proxy && request->proxy->reply &&
(get_hv_content(request->proxy->reply, request, rad_request_proxy_reply_hv, &vp,
"RAD_REQUEST_PROXY_REPLY", "proxy-reply") == 0)) {
fr_pair_list_free(&request->proxy->reply->vps);
request->proxy->reply->vps = vp;
vp = NULL;
}
#endif
}
return exitstatus;
}
/*
* 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;
}
/*
* The xlat function
*/
static ssize_t perl_xlat(UNUSED TALLOC_CTX *ctx, char **out, size_t outlen,
void const *mod_inst, UNUSED void const *xlat_inst,
REQUEST *request, char const *fmt)
{
rlm_perl_t *inst;
char *tmp;
char const *p, *q;
int count;
size_t ret = 0;
STRLEN n_a;
memcpy(&inst, &mod_inst, sizeof(inst));
#ifdef USE_ITHREADS
PerlInterpreter *interp;
pthread_mutex_lock(&inst->clone_mutex);
interp = rlm_perl_clone(inst->perl, inst->thread_key);
{
dTHXa(interp);
PERL_SET_CONTEXT(interp);
}
pthread_mutex_unlock(&inst->clone_mutex);
#else
PERL_SET_CONTEXT(inst->perl);
#endif
{
dSP;
ENTER;SAVETMPS;
PUSHMARK(SP);
p = q = fmt;
while (*p == ' ') {
p++;
q++;
}
while (*q) {
if (*q == ' ') {
XPUSHs(sv_2mortal(newSVpvn(p, q - p)));
p = q + 1;
/*
* Don't use an empty string
*/
while (*p == ' ') p++;
q = p;
}
q++;
}
/*
* And the last bit.
*/
if (*p) {
XPUSHs(sv_2mortal(newSVpvn(p, strlen(p))));
}
PUTBACK;
count = call_pv(inst->func_xlat, G_SCALAR | G_EVAL);
SPAGAIN;
if (SvTRUE(ERRSV)) {
REDEBUG("Exit %s", SvPV(ERRSV,n_a));
(void)POPs;
} else if (count > 0) {
tmp = POPp;
strlcpy(*out, tmp, outlen);
ret = strlen(*out);
RDEBUG2("Len is %zu , out is %s freespace is %zu", ret, *out, outlen);
}
PUTBACK ;
FREETMPS ;
LEAVE ;
}
return ret;
}
static ngx_int_t
ngx_http_perl_ssi(ngx_http_request_t *r, ngx_http_ssi_ctx_t *ssi_ctx,
ngx_str_t **params)
{
SV *sv, **asv;
ngx_int_t rc;
ngx_str_t *handler, **args;
ngx_uint_t i;
ngx_http_perl_ctx_t *ctx;
ngx_http_perl_main_conf_t *pmcf;
ngx_log_debug0(NGX_LOG_DEBUG_HTTP, r->connection->log, 0,
"perl ssi handler");
ctx = ngx_http_get_module_ctx(r, ngx_http_perl_module);
if (ctx == NULL) {
ctx = ngx_pcalloc(r->pool, sizeof(ngx_http_perl_ctx_t));
if (ctx == NULL) {
return NGX_ERROR;
}
ngx_http_set_ctx(r, ctx, ngx_http_perl_module);
}
pmcf = ngx_http_get_module_main_conf(r, ngx_http_perl_module);
ctx->ssi = ssi_ctx;
handler = params[NGX_HTTP_PERL_SSI_SUB];
handler->data[handler->len] = '\0';
{
dTHXa(pmcf->perl);
PERL_SET_CONTEXT(pmcf->perl);
#if 0
/* the code is disabled to force the precompiled perl code using only */
ngx_http_perl_eval_anon_sub(aTHX_ handler, &sv);
if (sv == &PL_sv_undef) {
ngx_log_error(NGX_LOG_ERR, r->connection->log, 0,
"eval_pv(\"%V\") failed", handler);
return NGX_ERROR;
}
if (sv == NULL) {
sv = newSVpvn((char *) handler->data, handler->len);
}
#endif
sv = newSVpvn((char *) handler->data, handler->len);
args = ¶ms[NGX_HTTP_PERL_SSI_ARG];
if (args) {
for (i = 0; args[i]; i++) { /* void */ }
asv = ngx_pcalloc(r->pool, (i + 1) * sizeof(SV *));
if (asv == NULL) {
SvREFCNT_dec(sv);
return NGX_ERROR;
}
asv[0] = (SV *) i;
for (i = 0; args[i]; i++) {
asv[i + 1] = newSVpvn((char *) args[i]->data, args[i]->len);
}
} else {
asv = NULL;
}
rc = ngx_http_perl_call_handler(aTHX_ r, pmcf->nginx, sv, asv, handler,
NULL);
SvREFCNT_dec(sv);
}
ctx->filename.data = NULL;
ctx->redirect_uri.len = 0;
ctx->ssi = NULL;
ngx_log_debug0(NGX_LOG_DEBUG_HTTP, r->connection->log, 0, "perl ssi done");
return rc;
}
/*
* Clear up after thread is done with
*/
void
Perl_ithread_destruct (pTHX_ ithread* thread, const char *why)
{
PerlInterpreter *freeperl = NULL;
MUTEX_LOCK(&thread->mutex);
if (!thread->next) {
Perl_croak(aTHX_ "panic: destruct destroyed thread %p (%s)",thread, why);
}
if (thread->count != 0) {
MUTEX_UNLOCK(&thread->mutex);
return;
}
MUTEX_LOCK(&create_destruct_mutex);
/* Remove from circular list of threads */
if (thread->next == thread) {
/* last one should never get here ? */
threads = NULL;
}
else {
thread->next->prev = thread->prev;
thread->prev->next = thread->next;
if (threads == thread) {
threads = thread->next;
}
thread->next = NULL;
thread->prev = NULL;
}
known_threads--;
assert( known_threads >= 0 );
#if 0
Perl_warn(aTHX_ "destruct %d @ %p by %p now %d",
thread->tid,thread->interp,aTHX, known_threads);
#endif
MUTEX_UNLOCK(&create_destruct_mutex);
/* Thread is now disowned */
if(thread->interp) {
dTHXa(thread->interp);
ithread* current_thread;
#ifdef OEMVS
void *ptr;
#endif
PERL_SET_CONTEXT(thread->interp);
current_thread = Perl_ithread_get(aTHX);
Perl_ithread_set(aTHX_ thread);
SvREFCNT_dec(thread->params);
thread->params = Nullsv;
perl_destruct(thread->interp);
freeperl = thread->interp;
thread->interp = NULL;
}
MUTEX_UNLOCK(&thread->mutex);
MUTEX_DESTROY(&thread->mutex);
#ifdef WIN32
if (thread->handle)
CloseHandle(thread->handle);
thread->handle = 0;
#endif
PerlMemShared_free(thread);
if (freeperl)
perl_free(freeperl);
PERL_SET_CONTEXT(aTHX);
}
static PerlInterpreter *
ngx_http_perl_create_interpreter(ngx_conf_t *cf,
ngx_http_perl_main_conf_t *pmcf)
{
int n;
STRLEN len;
SV *sv;
char *ver, *embedding[6];
PerlInterpreter *perl;
ngx_log_debug0(NGX_LOG_DEBUG_HTTP, cf->log, 0, "create perl interpreter");
if (ngx_set_environment(cf->cycle, NULL) == NULL) {
return NULL;
}
perl = perl_alloc();
if (perl == NULL) {
ngx_log_error(NGX_LOG_ALERT, cf->log, 0, "perl_alloc() failed");
return NULL;
}
{
dTHXa(perl);
PERL_SET_CONTEXT(perl);
perl_construct(perl);
#ifdef PERL_EXIT_DESTRUCT_END
PL_exit_flags |= PERL_EXIT_DESTRUCT_END;
#endif
embedding[0] = "";
if (pmcf->modules.data) {
embedding[1] = "-I";
embedding[2] = (char *) pmcf->modules.data;
n = 3;
} else {
n = 1;
}
embedding[n++] = "-Mnginx";
embedding[n++] = "-e";
embedding[n++] = "0";
n = perl_parse(perl, ngx_http_perl_xs_init, n, embedding, NULL);
if (n != 0) {
ngx_log_error(NGX_LOG_ALERT, cf->log, 0, "perl_parse() failed: %d", n);
goto fail;
}
sv = get_sv("nginx::VERSION", FALSE);
ver = SvPV(sv, len);
if (ngx_strcmp(ver, NGINX_VERSION) != 0) {
ngx_log_error(NGX_LOG_ALERT, cf->log, 0,
"version " NGINX_VERSION " of nginx.pm is required, "
"but %s was found", ver);
goto fail;
}
if (ngx_http_perl_run_requires(aTHX_ &pmcf->requires, cf->log) != NGX_OK) {
goto fail;
}
}
return perl;
fail:
(void) perl_destruct(perl);
perl_free(perl);
return NULL;
}
static int mod_detach(void *instance)
{
rlm_perl_t *inst = (rlm_perl_t *) instance;
int exitstatus = 0, count = 0;
#if 0
/*
* FIXME: Call this in the destruct function?
*/
{
dTHXa(handle->clone);
PERL_SET_CONTEXT(handle->clone);
{
dSP; ENTER; SAVETMPS; PUSHMARK(SP);
count = call_pv(inst->func_detach, G_SCALAR | G_EVAL );
SPAGAIN;
if (count == 1) {
exitstatus = POPi;
/*
* FIXME: bug in perl
*
*/
if (exitstatus >= 100 || exitstatus < 0) {
exitstatus = RLM_MODULE_FAIL;
}
}
PUTBACK;
FREETMPS;
LEAVE;
}
}
#endif
if (inst->func_detach) {
dTHXa(inst->perl);
PERL_SET_CONTEXT(inst->perl);
{
dSP; ENTER; SAVETMPS;
PUSHMARK(SP);
count = call_pv(inst->func_detach, G_SCALAR | G_EVAL );
SPAGAIN;
if (count == 1) {
exitstatus = POPi;
if (exitstatus >= 100 || exitstatus < 0) {
exitstatus = RLM_MODULE_FAIL;
}
}
PUTBACK;
FREETMPS;
LEAVE;
}
}
#ifdef USE_ITHREADS
rlm_perl_destruct(inst->perl);
pthread_mutex_destroy(&inst->clone_mutex);
#else
perl_destruct(inst->perl);
perl_free(inst->perl);
#endif
PERL_SYS_TERM();
return exitstatus;
}
/*
* Call the function_name inside the module
* Store all vps in hashes %RAD_CHECK %RAD_REPLY %RAD_REQUEST
*
*/
static int do_perl(void *instance, REQUEST *request, char *function_name)
{
rlm_perl_t *inst = instance;
VALUE_PAIR *vp;
int exitstatus=0, count;
STRLEN n_a;
HV *rad_reply_hv;
HV *rad_check_hv;
HV *rad_config_hv;
HV *rad_request_hv;
#ifdef WITH_PROXY
HV *rad_request_proxy_hv;
HV *rad_request_proxy_reply_hv;
#endif
/*
* Radius has told us to call this function, but none
* is defined.
*/
if (!function_name) return RLM_MODULE_FAIL;
#ifdef USE_ITHREADS
pthread_mutex_lock(&inst->clone_mutex);
PerlInterpreter *interp;
interp = rlm_perl_clone(inst->perl,inst->thread_key);
{
dTHXa(interp);
PERL_SET_CONTEXT(interp);
}
pthread_mutex_unlock(&inst->clone_mutex);
#else
PERL_SET_CONTEXT(inst->perl);
#endif
{
dSP;
ENTER;
SAVETMPS;
rad_reply_hv = get_hv("RAD_REPLY",1);
rad_check_hv = get_hv("RAD_CHECK",1);
rad_config_hv = get_hv("RAD_CONFIG",1);
rad_request_hv = get_hv("RAD_REQUEST",1);
perl_store_vps(request->reply, request->reply->vps, rad_reply_hv);
perl_store_vps(request, request->config_items, rad_check_hv);
perl_store_vps(request->packet, request->packet->vps, rad_request_hv);
perl_store_vps(request, request->config_items, rad_config_hv);
#ifdef WITH_PROXY
rad_request_proxy_hv = get_hv("RAD_REQUEST_PROXY",1);
rad_request_proxy_reply_hv = get_hv("RAD_REQUEST_PROXY_REPLY",1);
if (request->proxy != NULL) {
perl_store_vps(request->proxy, request->proxy->vps, rad_request_proxy_hv);
} else {
hv_undef(rad_request_proxy_hv);
}
if (request->proxy_reply !=NULL) {
perl_store_vps(request->proxy_reply, request->proxy_reply->vps, rad_request_proxy_reply_hv);
} else {
hv_undef(rad_request_proxy_reply_hv);
}
#endif
PUSHMARK(SP);
/*
* This way %RAD_xx can be pushed onto stack as sub parameters.
* XPUSHs( newRV_noinc((SV *)rad_request_hv) );
* XPUSHs( newRV_noinc((SV *)rad_reply_hv) );
* XPUSHs( newRV_noinc((SV *)rad_check_hv) );
* PUTBACK;
*/
count = call_pv(function_name, G_SCALAR | G_EVAL | G_NOARGS);
SPAGAIN;
if (SvTRUE(ERRSV)) {
ERROR("rlm_perl: perl_embed:: module = %s , func = %s exit status= %s\n",
inst->module,
function_name, SvPV(ERRSV,n_a));
(void)POPs;
}
if (count == 1) {
exitstatus = POPi;
if (exitstatus >= 100 || exitstatus < 0) {
exitstatus = RLM_MODULE_FAIL;
}
}
PUTBACK;
FREETMPS;
LEAVE;
vp = NULL;
if ((get_hv_content(request->packet, rad_request_hv, &vp)) > 0 ) {
pairfree(&request->packet->vps);
request->packet->vps = vp;
vp = NULL;
/*
* Update cached copies
*/
request->username = pairfind(request->packet->vps, PW_USER_NAME, 0, TAG_ANY);
request->password = pairfind(request->packet->vps, PW_USER_PASSWORD, 0, TAG_ANY);
if (!request->password)
request->password = pairfind(request->packet->vps, PW_CHAP_PASSWORD, 0, TAG_ANY);
}
if ((get_hv_content(request->reply, rad_reply_hv, &vp)) > 0 ) {
pairfree(&request->reply->vps);
request->reply->vps = vp;
vp = NULL;
}
if ((get_hv_content(request, rad_check_hv, &vp)) > 0 ) {
pairfree(&request->config_items);
request->config_items = vp;
vp = NULL;
}
#ifdef WITH_PROXY
if (request->proxy &&
(get_hv_content(request->proxy, rad_request_proxy_hv, &vp) > 0)) {
pairfree(&request->proxy->vps);
request->proxy->vps = vp;
vp = NULL;
}
if (request->proxy_reply &&
(get_hv_content(request->proxy_reply, rad_request_proxy_reply_hv, &vp) > 0)) {
pairfree(&request->proxy_reply->vps);
request->proxy_reply->vps = vp;
vp = NULL;
}
#endif
}
return exitstatus;
}
/*
* 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.
*
* Boyan:
* 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 **embed;
char **envp = NULL;
char const *xlat_name;
int exitstatus = 0, argc=0;
MEM(embed = talloc_zero_array(inst, char *, 4));
/*
* 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[0] = NULL;
if (inst->perl_flags) {
embed[1] = inst->perl_flags;
embed[2] = inst->module;
embed[3] = arg;
argc = 4;
} else {
embed[1] = inst->module;
embed[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);
}
return 0;
}
THREAD_RET_TYPE
Perl_ithread_run(LPVOID arg) {
#else
void*
Perl_ithread_run(void * arg) {
#endif
ithread* thread = (ithread*) arg;
dTHXa(thread->interp);
PERL_SET_CONTEXT(thread->interp);
Perl_ithread_set(aTHX_ thread);
#if 0
/* Far from clear messing with ->thr child-side is a good idea */
MUTEX_LOCK(&thread->mutex);
#ifdef WIN32
thread->thr = GetCurrentThreadId();
#else
thread->thr = pthread_self();
#endif
MUTEX_UNLOCK(&thread->mutex);
#endif
PL_perl_destruct_level = 2;
{
AV* params = (AV*) SvRV(thread->params);
I32 len = av_len(params)+1;
int i;
dSP;
ENTER;
SAVETMPS;
PUSHMARK(SP);
for(i = 0; i < len; i++) {
XPUSHs(av_shift(params));
}
PUTBACK;
len = call_sv(thread->init_function, thread->gimme|G_EVAL);
SPAGAIN;
for (i=len-1; i >= 0; i--) {
SV *sv = POPs;
av_store(params, i, SvREFCNT_inc(sv));
}
if (SvTRUE(ERRSV)) {
Perl_warn(aTHX_ "thread failed to start: %" SVf, ERRSV);
}
FREETMPS;
LEAVE;
SvREFCNT_dec(thread->init_function);
}
PerlIO_flush((PerlIO*)NULL);
MUTEX_LOCK(&thread->mutex);
thread->state |= PERL_ITHR_FINISHED;
if (thread->state & PERL_ITHR_DETACHED) {
MUTEX_UNLOCK(&thread->mutex);
Perl_ithread_destruct(aTHX_ thread, "detached finish");
} else {
MUTEX_UNLOCK(&thread->mutex);
}
MUTEX_LOCK(&create_destruct_mutex);
active_threads--;
assert( active_threads >= 0 );
MUTEX_UNLOCK(&create_destruct_mutex);
#ifdef WIN32
return (DWORD)0;
#else
return 0;
#endif
}
/*
* 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;
}
