/*
* Detach a instance give a chance to a module to make some internal setup ...
*/
static int perl_detach(void *instance)
{
PERL_INST *inst = (PERL_INST *) 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;
}
}
xlat_unregister(inst->xlat_name, perl_xlat);
free(inst->xlat_name);
#ifdef USE_ITHREADS
rlm_perl_destruct(inst->perl);
#else
perl_destruct(inst->perl);
perl_free(inst->perl);
#endif
PERL_SYS_TERM();
free(inst);
return exitstatus;
}
/*
* The xlat function
*/
static size_t perl_xlat(void *instance, REQUEST *request, char *fmt, char *out,
size_t freespace, RADIUS_ESCAPE_STRING func)
{
PERL_INST *inst= (PERL_INST *) instance;
PerlInterpreter *perl;
char params[1024], *ptr, *tmp;
int count;
size_t ret = 0;
STRLEN n_a;
/*
* Do an xlat on the provided string (nice recursive operation).
*/
if (!radius_xlat(params, sizeof(params), fmt, request, func)) {
radlog(L_ERR, "rlm_perl: xlat failed.");
return 0;
}
#ifndef WITH_ITHREADS
perl = inst->perl;
#else
perl = rlm_perl_clone(inst->perl,inst->thread_key);
{
dTHXa(perl);
}
#endif
PERL_SET_CONTEXT(perl);
{
dSP;
ENTER;SAVETMPS;
ptr = strtok(params, " ");
PUSHMARK(SP);
while (ptr != NULL) {
XPUSHs(sv_2mortal(newSVpv(ptr,0)));
ptr = strtok(NULL, " ");
}
PUTBACK;
count = call_pv(inst->func_xlat, G_SCALAR | G_EVAL);
SPAGAIN;
if (SvTRUE(ERRSV)) {
radlog(L_ERR, "rlm_perl: perl_xlat exit %s\n",
SvPV(ERRSV,n_a));
POPs ;
} else if (count > 0) {
tmp = POPp;
strlcpy(out, tmp, freespace);
ret = strlen(out);
radlog(L_DBG,"rlm_perl: Len is %d , out is %s freespace is %d",
ret, out,freespace);
}
PUTBACK ;
FREETMPS ;
LEAVE ;
}
return ret;
}
/*
* Call the function_name inside the module
* Store all vps in hashes %RAD_CHECK %RAD_REPLY %RAD_REQUEST
*
*/
static int rlmperl_call(void *instance, REQUEST *request, char *function_name)
{
PERL_INST *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
#ifdef USE_ITHREADS
PerlInterpreter *interp;
interp = rlm_perl_clone(inst->perl,inst->thread_key);
{
dTHXa(interp);
PERL_SET_CONTEXT(interp);
}
#else
PERL_SET_CONTEXT(inst->perl);
#endif
{
dSP;
ENTER;
SAVETMPS;
/*
* Radius has told us to call this function, but none
* is defined.
*/
if (!function_name) {
return RLM_MODULE_FAIL;
}
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);
#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);
#endif
perl_store_vps(request->reply->vps, rad_reply_hv);
perl_store_vps(request->config_items, rad_check_hv);
perl_store_vps(request->packet->vps, rad_request_hv);
perl_store_vps(request->config_items, rad_config_hv);
#ifdef WITH_PROXY
if (request->proxy != NULL) {
perl_store_vps(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->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)) {
radlog(L_ERR, "rlm_perl: perl_embed:: module = %s , func = %s exit status= %s\n",
inst->module,
function_name, SvPV(ERRSV,n_a));
POPs;
}
if (count == 1) {
exitstatus = POPi;
if (exitstatus >= 100 || exitstatus < 0) {
exitstatus = RLM_MODULE_FAIL;
}
}
PUTBACK;
FREETMPS;
LEAVE;
vp = NULL;
if ((get_hv_content(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);
request->password = pairfind(request->packet->vps,
PW_USER_PASSWORD, 0);
if (!request->password)
request->password = pairfind(request->packet->vps,
PW_CHAP_PASSWORD, 0);
}
if ((get_hv_content(rad_reply_hv, &vp)) > 0 ) {
pairfree(&request->reply->vps);
request->reply->vps = vp;
vp = NULL;
}
if ((get_hv_content(rad_check_hv, &vp)) > 0 ) {
pairfree(&request->config_items);
request->config_items = vp;
vp = NULL;
}
#ifdef WITH_PROXY
if (request->proxy &&
(get_hv_content(rad_request_proxy_hv, &vp) > 0)) {
pairfree(&request->proxy->vps);
request->proxy->vps = vp;
vp = NULL;
}
if (request->proxy_reply &&
(get_hv_content(rad_request_proxy_reply_hv, &vp) > 0)) {
pairfree(&request->proxy_reply->vps);
request->proxy_reply->vps = vp;
vp = NULL;
}
#endif
}
return exitstatus;
}
static int call_perl(const char *func, int signal, va_list va)
{
dSP;
PERL_SIGNAL_ARGS_REC *rec;
int retcount, n, ret;
void *arg;
HV *stash;
/* first check if we find exact match */
rec = NULL;
for (n = 0; perl_signal_args[n].signal != NULL; n++)
{
if (signal == perl_signal_args[n].signal_id)
{
rec = &perl_signal_args[n];
break;
}
}
if (rec == NULL)
{
/* try to find by name */
const char *signame;
signame = module_find_id_str("signals", signal);
for (n = 0; perl_signal_args[n].signal != NULL; n++)
{
if (strncmp(signame, perl_signal_args[n].signal,
strlen(perl_signal_args[n].signal)) == 0)
{
rec = &perl_signal_args[n];
break;
}
}
}
ENTER;
SAVETMPS;
PUSHMARK(sp);
if (rec != NULL)
{
/* put the arguments to perl stack */
for (n = 0; n < 7; n++)
{
arg = va_arg(va, gpointer);
if (rec->args[n] == NULL)
break;
if (strcmp(rec->args[n], "string") == 0)
XPUSHs(sv_2mortal(newSVpv(arg == NULL ? "" : arg, arg == NULL ? 0 : strlen(arg))));
else if (strcmp(rec->args[n], "int") == 0)
XPUSHs(sv_2mortal(newSViv(GPOINTER_TO_INT(arg))));
else if (strcmp(rec->args[n], "ulongptr") == 0)
XPUSHs(sv_2mortal(newSViv(*(gulong *) arg)));
else if (strncmp(rec->args[n], "glist_", 6) == 0)
{
GSList *tmp;
stash = gv_stashpv(rec->args[n]+6, 0);
for (tmp = arg; tmp != NULL; tmp = tmp->next)
XPUSHs(sv_2mortal(sv_bless(newRV_noinc(newSViv(GPOINTER_TO_INT(tmp->data))), stash)));
}
else
{
if (arg == NULL)
XPUSHs(sv_2mortal(newSViv(0)));
else {
stash = gv_stashpv(rec->args[n], 0);
XPUSHs(sv_2mortal(sv_bless(newRV_noinc(newSViv(GPOINTER_TO_INT(arg))), stash)));
}
}
}
}
PUTBACK;
retcount = perl_call_pv((char *) func, G_EVAL|G_SCALAR);
SPAGAIN;
ret = 0;
if (SvTRUE(ERRSV))
{
STRLEN n_a;
signal_emit("gui dialog", 2, "error", SvPV(ERRSV, n_a));
(void)POPs;
}
else
{
SV *sv;
if (retcount > 0)
{
sv = POPs;
if (SvIOK(sv) && SvIV(sv) == 1) ret = 1;
}
for (n = 2; n <= retcount; n++)
(void)POPi;
}
PUTBACK;
FREETMPS;
LEAVE;
return ret;
}
static CORBA_boolean
put_fixed (GIOPSendBuffer *buf, CORBA_TypeCode tc, SV *sv)
{
CORBA_octet *outbuf;
int count;
STRLEN len;
char *str;
int index, i;
int wire_length = (tc->digits + 2) / 2;
/* If we have an even number of digits, first half-octet is 0 */
gboolean offset = (tc->digits % 2 == 0);
dSP;
ENTER;
SAVETMPS;
if (!sv_isa (sv, "CORBA::Fixed"))
{
PUSHMARK(sp);
XPUSHs(sv_2mortal (newSVpv ("CORBA::Fixed", 0)));
XPUSHs(sv);
PUTBACK;
count = perl_call_method("from_string", G_SCALAR);
SPAGAIN;
if (count != 1) {
warn ("CORBA::Fixed::from_string returned %d items", count);
while (count--)
(void)POPs;
PUTBACK;
return CORBA_FALSE;
}
sv = POPs;
PUTBACK;
}
PUSHMARK(sp);
XPUSHs(sv);
XPUSHs(sv_2mortal (newSViv (tc->digits)));
XPUSHs(sv_2mortal (newSViv (tc->scale)));
PUTBACK;
count = perl_call_method("to_digits", G_SCALAR);
SPAGAIN;
if (count != 1) {
warn ("CORBA::Fixed::to_digits returned %d items", count);
while (count--)
(void)POPs;
PUTBACK;
return CORBA_FALSE;
}
sv = POPs;
str = SvPV(sv,len);
if (len != (STRLEN)(tc->digits + 1)) {
warn ("CORBA::Fixed::to_digits return wrong number of digits!\n");
return CORBA_FALSE;
}
outbuf = g_malloc ((tc->digits + 2) / 2);
index = 1;
for (i = 0; i < wire_length; i++) {
CORBA_octet c;
if (i == 0 && offset)
c = 0;
else
c = (str[index++] - '0') << 4;
if (i == wire_length - 1)
c |= (str[0] == '-') ? 0xd : 0xc;
else
c |= str[index++] - '0';
outbuf[i] = c;
}
giop_send_buffer_append_mem_indirect (buf, outbuf, wire_length);
g_free (outbuf);
return CORBA_TRUE;
}
// Convert all arguments to Perl and place them on the Perl stack.
static CHY_INLINE void
SI_push_args(void *vobj, va_list args, uint32_t num_args)
{
kino_Obj *obj = (kino_Obj*)vobj;
SV *invoker;
uint32_t i;
dSP;
uint32_t stack_slots_needed = num_args < 2
? num_args + 1
: (num_args * 2) + 1;
EXTEND(SP, stack_slots_needed);
if (Kino_Obj_Is_A(obj, KINO_VTABLE)) {
kino_VTable *vtable = (kino_VTable*)obj;
// TODO: Creating a new class name SV every time is wasteful.
invoker = XSBind_cb_to_sv(Kino_VTable_Get_Name(vtable));
}
else {
invoker = (SV*)Kino_Obj_To_Host(obj);
}
ENTER;
SAVETMPS;
PUSHMARK(SP);
PUSHs( sv_2mortal(invoker) );
for (i = 0; i < num_args; i++) {
uint32_t arg_type = va_arg(args, uint32_t);
char *label = va_arg(args, char*);
if (num_args > 1) {
PUSHs( sv_2mortal( newSVpvn(label, strlen(label)) ) );
}
switch (arg_type & CFISH_HOST_ARGTYPE_MASK) {
case CFISH_HOST_ARGTYPE_I32: {
int32_t value = va_arg(args, int32_t);
PUSHs( sv_2mortal( newSViv(value) ) );
}
break;
case CFISH_HOST_ARGTYPE_I64: {
int64_t value = va_arg(args, int64_t);
if (sizeof(IV) == 8) {
PUSHs( sv_2mortal( newSViv((IV)value) ) );
}
else {
// lossy
PUSHs( sv_2mortal( newSVnv((double)value) ) );
}
}
break;
case CFISH_HOST_ARGTYPE_F32:
case CFISH_HOST_ARGTYPE_F64: {
// Floats are promoted to doubles by variadic calling.
double value = va_arg(args, double);
PUSHs( sv_2mortal( newSVnv(value) ) );
}
break;
case CFISH_HOST_ARGTYPE_STR: {
kino_CharBuf *string = va_arg(args, kino_CharBuf*);
PUSHs( sv_2mortal( XSBind_cb_to_sv(string) ) );
}
break;
case CFISH_HOST_ARGTYPE_OBJ: {
kino_Obj* anObj = va_arg(args, kino_Obj*);
SV *arg_sv = anObj == NULL
? newSV(0)
: XSBind_cfish_to_perl(anObj);
PUSHs( sv_2mortal(arg_sv) );
}
break;
default:
CFISH_THROW(KINO_ERR, "Unrecognized arg type: %u32", arg_type);
}
}
PUTBACK;
}
int perl_exec2(struct sip_msg* _msg, char* fnc, char* mystr) {
int retval;
SV *m;
str reason;
dSP;
if (!perl_checkfnc(fnc)) {
LM_ERR("unknown perl function called.\n");
reason.s = "Internal error";
reason.len = sizeof("Internal error")-1;
if (sigb.reply(_msg, 500, &reason, NULL) == -1)
{
LM_ERR("failed to send reply\n");
}
return -1;
}
switch ((_msg->first_line).type) {
case SIP_REQUEST:
if (parse_sip_msg_uri(_msg) < 0) {
LM_ERR("failed to parse Request-URI\n");
reason.s = "Bad Request-URI";
reason.len = sizeof("Bad Request-URI")-1;
if (sigb.reply(_msg, 400, &reason, NULL) == -1) {
LM_ERR("failed to send reply\n");
}
return -1;
}
break;
case SIP_REPLY:
break;
default:
LM_ERR("invalid firstline");
return -1;
}
ENTER; /* everything created after here */
SAVETMPS; /* ...is a temporary variable. */
PUSHMARK(SP); /* remember the stack pointer */
m = sv_newmortal(); /* create a mortal SV to be killed on FREETMPS */
sv_setref_pv(m, "OpenSIPS::Message", (void *)_msg); /* bless the message with a class */
SvREADONLY_on(SvRV(m)); /* set the content of m to be readonly */
XPUSHs(m); /* Our reference to the stack... */
if (mystr)
XPUSHs(sv_2mortal(newSVpv(mystr, strlen(mystr))));
/* Our string to the stack... */
PUTBACK; /* make local stack pointer global */
call_pv(fnc, G_EVAL|G_SCALAR); /* call the function */
SPAGAIN; /* refresh stack pointer */
/* pop the return value from stack */
retval = POPi;
PUTBACK;
FREETMPS; /* free that return value */
LEAVE; /* ...and the XPUSHed "mortal" args.*/
return retval;
}
ngx_int_t
ngx_http_psgi_init_app(pTHX_ ngx_http_psgi_loc_conf_t *psgilcf, ngx_log_t *log)
{
ngx_int_t retval = NGX_ERROR;
/* Check if we have Perl interpreter */
if (psgilcf->perl == NULL) {
ngx_log_error(NGX_LOG_ERR, log, 0,
"Panic: NULL Perl interpreter");
return retval;
}
/* Already have PSGI app */
if (psgilcf->sub != NULL) {
return NGX_OK;
}
ngx_log_debug1(NGX_LOG_DEBUG_HTTP, log, 0,
"Loading app \"%s\"", psgilcf->app);
/* Init PSGI application */
{
dSP;
ENTER;
SAVETMPS;
PUSHMARK(SP);
/* FIXME: This should be written way cleaner! */
SV *call = newSVpvf("sub { return do '%s' }", psgilcf->app);
SV *cvrv = eval_pv(SvPV_nolen(call), FALSE);
int count = call_sv(cvrv, G_EVAL|G_SCALAR);
if (SvTRUE(ERRSV))
{
ngx_log_error(NGX_LOG_ERR, log, 0,
"Failed to initialize psgi app \"%s\": %s", psgilcf->app, SvPV_nolen(ERRSV));
} else if (count < 1) {
ngx_log_error(NGX_LOG_ERR, log, 0,
"Application '%s' returned empty list", psgilcf->app);
} else {
SPAGAIN;
psgilcf->sub = (SV*)POPs;
PUTBACK;
/* Dereference */
if (SvROK(psgilcf->sub)) {
psgilcf->sub = SvRV(psgilcf->sub);
}
if (SvTYPE(psgilcf->sub) == SVt_PVCV || SvTYPE(psgilcf->sub) == SVt_PVMG) {
SvREFCNT_inc(psgilcf->sub);
ngx_log_debug1(NGX_LOG_DEBUG_HTTP, log, 0,
"Application successfully initialized: %s", SvPV_nolen(psgilcf->sub));
retval = NGX_OK;
} else {
ngx_log_error(NGX_LOG_ERR, log, 0,
"psgi app \"%s\" returned something that is not a code reference: '%s'",
psgilcf->app, SvPV_nolen(psgilcf->sub));
}
}
FREETMPS;
LEAVE;
}
return retval;
}
int
perl_back_modify(
Operation *op,
SlapReply *rs )
{
PerlBackend *perl_back = (PerlBackend *)op->o_bd->be_private;
Modifications *modlist = op->orm_modlist;
int count;
int i;
PERL_SET_CONTEXT( PERL_INTERPRETER );
ldap_pvt_thread_mutex_lock( &perl_interpreter_mutex );
{
dSP; ENTER; SAVETMPS;
PUSHMARK(sp);
XPUSHs( perl_back->pb_obj_ref );
XPUSHs(sv_2mortal(newSVpv( op->o_req_dn.bv_val , 0)));
for (; modlist != NULL; modlist = modlist->sml_next ) {
Modification *mods = &modlist->sml_mod;
switch ( mods->sm_op & ~LDAP_MOD_BVALUES ) {
case LDAP_MOD_ADD:
XPUSHs(sv_2mortal(newSVpv("ADD", STRLENOF("ADD") )));
break;
case LDAP_MOD_DELETE:
XPUSHs(sv_2mortal(newSVpv("DELETE", STRLENOF("DELETE") )));
break;
case LDAP_MOD_REPLACE:
XPUSHs(sv_2mortal(newSVpv("REPLACE", STRLENOF("REPLACE") )));
break;
}
XPUSHs(sv_2mortal(newSVpv( mods->sm_desc->ad_cname.bv_val,
mods->sm_desc->ad_cname.bv_len )));
for ( i = 0;
mods->sm_values != NULL && mods->sm_values[i].bv_val != NULL;
i++ )
{
XPUSHs(sv_2mortal(newSVpv( mods->sm_values[i].bv_val, mods->sm_values[i].bv_len )));
}
/* Fix delete attrib without value. */
if ( i == 0) {
XPUSHs(sv_newmortal());
}
}
PUTBACK;
count = call_method("modify", G_SCALAR);
SPAGAIN;
if (count != 1) {
croak("Big trouble in back_modify\n");
}
rs->sr_err = POPi;
PUTBACK; FREETMPS; LEAVE;
}
ldap_pvt_thread_mutex_unlock( &perl_interpreter_mutex );
send_ldap_result( op, rs );
Debug( LDAP_DEBUG_ANY, "Perl MODIFY\n", 0, 0, 0 );
return( 0 );
}
static void perl_call_signal(PERL_SCRIPT_REC *script, SV *func,
int signal_id, gconstpointer *args)
{
dSP;
PERL_SIGNAL_ARGS_REC *rec;
SV *sv, *perlarg, *saved_args[SIGNAL_MAX_ARGUMENTS];
AV *av;
void *arg;
int n;
ENTER;
SAVETMPS;
PUSHMARK(sp);
/* push signal argument to perl stack */
rec = perl_signal_args_find(signal_id);
memset(saved_args, 0, sizeof(saved_args));
for (n = 0; n < SIGNAL_MAX_ARGUMENTS &&
rec != NULL && rec->args[n] != NULL; n++) {
arg = (void *) args[n];
if (strncmp(rec->args[n], "glistptr_", 9) == 0) {
/* pointer to linked list - push as AV */
GList *tmp, **ptr;
int is_iobject, is_str;
is_iobject = g_strcmp0(rec->args[n]+9, "iobject") == 0;
is_str = g_strcmp0(rec->args[n]+9, "char*") == 0;
av = newAV();
ptr = arg;
for (tmp = *ptr; tmp != NULL; tmp = tmp->next) {
sv = is_iobject ? iobject_bless((SERVER_REC *) tmp->data) :
is_str ? new_pv(tmp->data) :
irssi_bless_plain(rec->args[n]+9, tmp->data);
av_push(av, sv);
}
saved_args[n] = perlarg = newRV_noinc((SV *) av);
} else if (g_strcmp0(rec->args[n], "int") == 0)
perlarg = newSViv((IV)arg);
else if (arg == NULL)
perlarg = &PL_sv_undef;
else if (g_strcmp0(rec->args[n], "string") == 0)
perlarg = new_pv(arg);
else if (g_strcmp0(rec->args[n], "ulongptr") == 0)
perlarg = newSViv(*(unsigned long *) arg);
else if (g_strcmp0(rec->args[n], "intptr") == 0)
saved_args[n] = perlarg = newRV_noinc(newSViv(*(int *) arg));
else if (strncmp(rec->args[n], "gslist_", 7) == 0) {
/* linked list - push as AV */
GSList *tmp;
int is_iobject;
is_iobject = g_strcmp0(rec->args[n]+7, "iobject") == 0;
av = newAV();
for (tmp = arg; tmp != NULL; tmp = tmp->next) {
sv = is_iobject ? iobject_bless((SERVER_REC *) tmp->data) :
irssi_bless_plain(rec->args[n]+7, tmp->data);
av_push(av, sv);
}
perlarg = newRV_noinc((SV *) av);
} else if (g_strcmp0(rec->args[n], "iobject") == 0) {
/* "irssi object" - any struct that has
"int type; int chat_type" as it's first
variables (server, channel, ..) */
perlarg = iobject_bless((SERVER_REC *) arg);
} else if (g_strcmp0(rec->args[n], "siobject") == 0) {
/* "simple irssi object" - any struct that has
int type; as it's first variable (dcc) */
perlarg = simple_iobject_bless((SERVER_REC *) arg);
} else {
/* blessed object */
perlarg = plain_bless(arg, rec->args[n]);
}
XPUSHs(sv_2mortal(perlarg));
}
PUTBACK;
perl_call_sv(func, G_EVAL|G_DISCARD);
SPAGAIN;
if (SvTRUE(ERRSV)) {
char *error = g_strdup(SvPV_nolen(ERRSV));
signal_emit("script error", 2, script, error);
g_free(error);
rec = NULL;
}
/* restore arguments the perl script modified */
for (n = 0; n < SIGNAL_MAX_ARGUMENTS &&
rec != NULL && rec->args[n] != NULL; n++) {
arg = (void *) args[n];
if (saved_args[n] == NULL)
continue;
if (g_strcmp0(rec->args[n], "intptr") == 0) {
int *val = arg;
*val = SvIV(SvRV(saved_args[n]));
} else if (strncmp(rec->args[n], "glistptr_", 9) == 0) {
GList **ret = arg;
GList *out = NULL;
void *val;
int count;
av = (AV *) SvRV(saved_args[n]);
count = av_len(av);
while (count-- >= 0) {
sv = av_shift(av);
if (SvPOKp(sv))
val = g_strdup(SvPV_nolen(sv));
else
val = GINT_TO_POINTER(SvIV(sv));
out = g_list_append(out, val);
}
if (g_strcmp0(rec->args[n]+9, "char*") == 0)
g_list_foreach(*ret, (GFunc) g_free, NULL);
g_list_free(*ret);
*ret = out;
}
}
FREETMPS;
LEAVE;
}
ngx_int_t
ngx_http_psgi_perl_handler(ngx_http_request_t *r, ngx_http_psgi_loc_conf_t *psgilcf, void *interpreter)
{
PerlInterpreter *perl = (PerlInterpreter *) interpreter;
ngx_int_t retval = NGX_ERROR;
ngx_log_t *log = r->connection->log;
dTHXa(perl);
PERL_SET_CONTEXT(perl);
if (psgilcf->sub == NULL) {
if(ngx_http_psgi_init_app(aTHX_ psgilcf, log) != NGX_OK) {
return NGX_ERROR;
}
}
{
int count;
ngx_log_debug1(NGX_LOG_DEBUG_HTTP, log, 0,
"Running PSGI app \"%s\"",
psgilcf->app);
dSP;
ENTER;
SAVETMPS;
// ngx_http_psgi_create_env should be called between SAVETMPS and FREETMPS
SV *env = ngx_http_psgi_create_env(aTHX_ r, psgilcf->app);
PUSHMARK(SP);
XPUSHs(sv_2mortal(env));
PUTBACK;
count = call_sv(psgilcf->sub, G_EVAL|G_SCALAR);
ngx_log_debug1(NGX_LOG_DEBUG_HTTP, log, 0,
"PSGI app response: %d elements", count);
SPAGAIN;
if (SvTRUE(ERRSV))
{
ngx_log_error(NGX_LOG_ERR, log, 0,
"PSGI handler execution failed: %s", SvPV_nolen(ERRSV));
ngx_http_finalize_request(r, NGX_HTTP_INTERNAL_SERVER_ERROR);
retval = NGX_ERROR;
}
else if (count < 1) {
ngx_log_error(NGX_LOG_ERR, log, 0,
"PSGI app \"%s\" did not returned value: %s", psgilcf->app, SvPV_nolen(ERRSV));
ngx_http_finalize_request(r, NGX_HTTP_INTERNAL_SERVER_ERROR);
retval = NGX_ERROR;
} else {
retval = ngx_http_psgi_process_response(aTHX_ r, POPs, perl);
ngx_http_finalize_request(r, retval);
}
PUTBACK;
FREETMPS;
LEAVE;
}
return retval;
}
static int mod_detach(void *instance)
{
rlm_perl_t *inst = (rlm_perl_t *) instance;
int exitstatus = 0, count = 0;
hv_undef(inst->rad_perlconf_hv);
#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;
}
static int
print_cb (char *word[], void *userdata)
{
HookData *data = (HookData *) userdata;
SV *temp = NULL;
int retVal = 0;
int count = 1;
int last_index = 31;
/* must be initialized after SAVETMPS */
AV *wd = NULL;
dSP;
ENTER;
SAVETMPS;
if (data->depth)
return XCHAT_EAT_NONE;
wd = newAV ();
sv_2mortal ((SV *) wd);
/* need to scan backwards to find the index of the last element since some
events such as "DCC Timeout" can have NULL elements in between non NULL
elements */
while (last_index >= 0
&& (word[last_index] == NULL || word[last_index][0] == 0)) {
last_index--;
}
for (count = 1; count <= last_index; count++) {
if (word[count] == NULL) {
av_push (wd, &PL_sv_undef);
} else if (word[count][0] == 0) {
av_push (wd, newSVpvn ("",0));
} else {
temp = newSVpv (word[count], 0);
SvUTF8_on (temp);
av_push (wd, temp);
}
}
/*xchat_printf (ph, "Recieved %d words in print callback", av_len (wd)+1); */
PUSHMARK (SP);
XPUSHs (newRV_noinc ((SV *) wd));
XPUSHs (data->userdata);
PUTBACK;
data->depth++;
count = call_sv (data->callback, G_EVAL);
data->depth--;
SPAGAIN;
if (SvTRUE (ERRSV)) {
xchat_printf (ph, "Error in print callback %s", SvPV_nolen (ERRSV));
if (!SvOK (POPs)) {} /* remove undef from the top of the stack */
retVal = XCHAT_EAT_NONE;
} else {
if (count != 1) {
xchat_print (ph, "Print handler should only return 1 value.");
retVal = XCHAT_EAT_NONE;
} else {
retVal = POPi;
}
}
PUTBACK;
FREETMPS;
LEAVE;
return retVal;
}
static worker_insert_result_t
perl_worker_eval(LogThrDestDriver *d, LogMessage *msg)
{
PerlDestDriver *self = (PerlDestDriver *)d;
gboolean success, vp_ok;
LogPathOptions path_options = LOG_PATH_OPTIONS_INIT;
PerlInterpreter *my_perl = self->perl;
int count;
HV *kvmap;
gpointer args[3];
dSP;
ENTER;
SAVETMPS;
PUSHMARK(SP);
kvmap = newHV();
args[0] = self->perl;
args[1] = kvmap;
args[2] = self;
vp_ok = value_pairs_foreach(self->vp, perl_worker_vp_add_one,
msg, self->seq_num, LTZ_SEND,
&self->template_options,
args);
if (!vp_ok && (self->template_options.on_error & ON_ERROR_DROP_MESSAGE))
goto exit;
XPUSHs(sv_2mortal(newRV_noinc((SV *)kvmap)));
PUTBACK;
count = call_pv(self->queue_func_name, G_EVAL | G_SCALAR);
SPAGAIN;
if (SvTRUE(ERRSV))
{
msg_error("Error while calling a Perl function",
evt_tag_str("driver", self->super.super.super.id),
evt_tag_str("script", self->filename),
evt_tag_str("function", self->queue_func_name),
evt_tag_str("error-message", SvPV_nolen(ERRSV)),
NULL);
(void) POPs;
success = FALSE;
}
if (count != 1)
{
msg_error("Too many values returned by a Perl function",
evt_tag_str("driver", self->super.super.super.id),
evt_tag_str("script", self->filename),
evt_tag_str("function", self->queue_func_name),
evt_tag_int("returned-values", count),
evt_tag_int("expected-values", 1),
NULL);
success = FALSE;
}
else
{
int r = POPi;
success = (r != 0);
}
exit:
PUTBACK;
FREETMPS;
LEAVE;
if (success && vp_ok)
{
return WORKER_INSERT_RESULT_SUCCESS;
}
else
{
return WORKER_INSERT_RESULT_DROP;
}
}
void run_plugin(char *command_line) {
#ifdef aTHX
dTHX;
#endif
SV *plugin_hndlr_cr ;
STRLEN n_a ;
int count = 0 ;
int pclose_result;
char *plugin_output;
char fname[128];
char *args[] = {"", "", "", "", NULL };
dSP;
strncpy(fname,command_line,strcspn(command_line," "));
fname[strcspn(command_line," ")] = '\0';
/*
* Arguments passsed to Perl sub Embed::Persistent::run_package
*/
/*
* filename containing plugin
*/
args[0] = fname ;
/*
* Do _not_ cache the compiled plugin
*/
args[1] = DO_CLEAN ;
/*
* pointer to plugin arguments
*/
args[3] = command_line + strlen(fname) + 1 ;
ENTER;
SAVETMPS;
PUSHMARK(SP);
XPUSHs(sv_2mortal(newSVpv(args[0],0)));
XPUSHs(sv_2mortal(newSVpv(args[1],0)));
XPUSHs(sv_2mortal(newSVpv(args[2],0)));
XPUSHs(sv_2mortal(newSVpv(args[3],0)));
PUTBACK;
call_pv("Embed::Persistent::eval_file", G_SCALAR | G_EVAL);
SPAGAIN ;
if(SvTRUE(ERRSV)){
(void) POPs;
printf("embedded perl compiled plugin %s with error: %s - skipping plugin\n", fname, SvPVX(ERRSV));
return;
} else {
plugin_hndlr_cr = newSVsv(POPs);
PUTBACK ;
FREETMPS ;
LEAVE ;
}
/*
* Push the arguments to Embed::Persistent::run_package onto
* the Perl stack.
*/
ENTER;
SAVETMPS;
PUSHMARK(SP);
XPUSHs(sv_2mortal(newSVpv(args[0],0)));
XPUSHs(sv_2mortal(newSVpv(args[1],0)));
XPUSHs(plugin_hndlr_cr);
XPUSHs(sv_2mortal(newSVpv(args[3],0)));
PUTBACK;
count = call_pv("Embed::Persistent::run_package", G_ARRAY);
SPAGAIN;
plugin_output = POPpx ;
pclose_result = POPi ;
printf("embedded perl plugin return code and output was: %d & %s\n", pclose_result, plugin_output) ;
PUTBACK;
FREETMPS;
LEAVE;
return ;
}
regexp* hook_regcompp (pTHX_ char* exp, char* xend, PMOP* pm)
{
SV* handler = NULL;
/* fprintf(stderr,"hook_regcompp in %lx\n",(unsigned long)exp); */
/* Check $^H for lexical selection of semantics and implementation */
if(handler == NULL) {
const char hint_key[] = "regcompp";
SV** phandler;
HV* hints;
hints = get_hv("\b",0);
if(hints != NULL) {
phandler = hv_fetch(hints, hint_key, strlen(hint_key), 0);
if(phandler != NULL) {
handler = *phandler;
/* fprintf(stderr,"hook_regcompp lexical...%lx\n",(unsigned long)handler); */
/* call_sv(handler,G_DISCARD|G_EVAL);
fprintf(stderr,"can survive %lx %lx\n",(unsigned long)exp,(unsigned long)handler);
*/
}
}
}
/* Check $re::override::regcompp
for a dynamic selection of implementation */
if(handler == NULL) {
SV* sv;
sv = get_sv("$re::override::regcompp",0);
if(sv != NULL && sv != &PL_sv_undef) {
/* fprintf(stderr,"hook_regcompp dynamic...\n"); */
handler = sv;
}
}
/* If no handlers, then hand off */
if(handler == NULL) {
/* fprintf(stderr,"hook_regcompp punt.\n"); */
return previous_comp_hook(aTHX_ exp,xend,pm);
}
{
dSP;
char *nulpat;
regexp* r;
I32 ret;
I32 api;
nulpat = savepv(""); /*XXX - can be constant? */
r = Perl_pregcomp(aTHX_ nulpat,nulpat,pm);
/*XXX - can free nulpat now? */
/* fprintf(stderr,"exp =%lu\nxend=%lu\n",(unsigned long)exp,(unsigned long)xend);*/
PUSHMARK(SP);
XPUSHs(sv_2mortal(newSVpvn(exp,xend-exp)));
mXPUSHu((unsigned long)r);
PUTBACK;
HANDLER_CALL:
/* fprintf(stderr,"calling out...\n");*/
ret = call_sv(handler, G_ARRAY);
/* fprintf(stderr,"...back.\n");*/
SPAGAIN;
api = POPi;
if(api == 13) {
SV* pat;
long nparens;
SV* exec_callback_sub;
/* fprintf(stderr,"api 13\n");*/
if(ret != 4) {
fprintf(stderr,"api 13 violation\n"); exit(0);
}
pat = POPs;
nparens = POPl;
exec_callback_sub = POPs;
PUTBACK;
regexp_setup(aTHX_ r,pat,nparens,exec_callback_sub);
} else if(api == 14) {
SV* expr_code;
SV* expr_result;
/* fprintf(stderr,"api 14\n");*/
if(ret != 3) {
fprintf(stderr,"api 14 violation\n"); exit(0);
}
handler = SvREFCNT_inc(POPs); /*XXX needed? */
expr_code = POPs;
PUTBACK;
expr_result = eval_pv(SvPV_nolen(expr_code),0);
SPAGAIN;
XPUSHs(expr_result);
PUTBACK;
goto HANDLER_CALL;
} else {
fprintf(stderr,"api UNKNOWN violation\n"); exit(0);
}
/* fprintf(stderr,"hook_regcompp done.\n"); */
return r;
}
}
/*
* Implementation functions: load or unload a perl script.
*/
static module_t *do_script_load(const char *filename)
{
/* Remember, this must now be re-entrant. The use of the static
* perl_error buffer is still OK, as it's only used immediately after
* setting, without control passing from this function.
*/
perl_script_module_t *m = mowgli_heap_alloc(perl_script_module_heap);
mowgli_strlcpy(m->filename, filename, sizeof(m->filename));
snprintf(perl_error, sizeof(perl_error), "Unknown error attempting to load perl script %s",
filename);
dSP;
ENTER;
SAVETMPS;
PUSHMARK(SP);
XPUSHs(newRV_noinc((SV*)get_cv("Atheme::Init::load_script", 0)));
XPUSHs(sv_2mortal(newSVpv(filename, 0)));
PUTBACK;
int perl_return_count = call_pv("Atheme::Init::call_wrapper", G_EVAL | G_SCALAR);
SPAGAIN;
if (SvTRUE(ERRSV))
{
mowgli_strlcpy(perl_error, SvPV_nolen(ERRSV), sizeof(perl_error));
goto fail;
}
if (1 != perl_return_count)
{
snprintf(perl_error, sizeof(perl_error), "Script load didn't return a package name");
goto fail;
}
/* load_script should have returned the package name that was just
* loaded...
*/
const char *packagename = POPp;
char info_varname[BUFSIZE];
snprintf(info_varname, BUFSIZE, "%s::Info", packagename);
/* ... so use that name to grab the script information hash...
*/
HV *info_hash = get_hv(info_varname, 0);
if (!info_hash)
{
snprintf(perl_error, sizeof(perl_error), "Couldn't get package info hash %s", info_varname);
goto fail;
}
/* ..., extract the canonical name...
*/
SV **name_var = hv_fetch(info_hash, "name", 4, 0);
if (!name_var)
{
snprintf(perl_error, sizeof(perl_error), "Couldn't find canonical name in package info hash");
goto fail;
}
mowgli_strlcpy(m->mod.name, SvPV_nolen(*name_var), sizeof(m->mod.name));
/* ... and dependency list.
*/
SV **deplist_var = hv_fetch(info_hash, "depends", 7, 0);
/* Not declaring this is legal... */
if (deplist_var)
{
/* ... but having it as anything but an arrayref isn't. */
if (!SvROK(*deplist_var) || SvTYPE(SvRV(*deplist_var)) != SVt_PVAV)
{
snprintf(perl_error, sizeof(perl_error), "$Info::depends must be an array reference");
goto fail;
}
AV *deplist = (AV*)SvRV(*deplist_var);
I32 len = av_len(deplist);
/* av_len returns max index, not number of items */
for (I32 i = 0; i <= len; ++i)
{
SV **item = av_fetch(deplist, i, 0);
if (!item)
continue;
const char *dep_name = SvPV_nolen(*item);
if (!module_request(dep_name))
{
snprintf(perl_error, sizeof(perl_error), "Dependent module %s failed to load",
dep_name);
goto fail;
}
module_t *dep_mod = module_find_published(dep_name);
mowgli_node_add(dep_mod, mowgli_node_create(), &m->mod.deplist);
mowgli_node_add(m, mowgli_node_create(), &dep_mod->dephost);
}
}
FREETMPS;
LEAVE;
invalidate_object_references();
/* Now that everything's loaded, do the module housekeeping stuff. */
m->mod.unload_handler = perl_script_module_unload_handler;
/* Can't do much better than the address of the module_t here */
m->mod.address = m;
m->mod.can_unload = MODULE_UNLOAD_CAPABILITY_OK;
return (module_t*)m;
fail:
slog(LG_ERROR, "Failed to load Perl script %s: %s", filename, perl_error);
if (info_hash)
SvREFCNT_dec((SV*)info_hash);
do_script_unload(filename);
mowgli_heap_free(perl_script_module_heap, m);
POPs;
FREETMPS;
LEAVE;
invalidate_object_references();
return NULL;
}
I32 regexp_exechook_hook (pTHX_ regexp* r, char* stringarg, char* strend,
char* strbeg, I32 minend, SV* screamer,
void* data, U32 flags)
{
if(!CONTAINS_RECOGNITION_FLAG(r)) {
return previous_exec_hook(aTHX_ r,stringarg,strend,strbeg,
minend,screamer,data,flags);
}
else {
SV* perl_callback;
I32 ret;
IV matched;
I32 delta;
dSP;
/*
fprintf(stderr,"strarg=%lu\nstrbeg=%lu\nstrend=%lu\n",stringarg,strbeg,strend);
fprintf(stderr,"minend=%ld pos=%ld\n",minend,PL_reg_ganch);
fprintf(stderr,"flags=%lu\n",flags);
*/
perl_callback = r->substrs->data[0].substr;
ENTER;
SAVETMPS;
PUSHMARK(SP);
XPUSHs(newSVpv(stringarg,strend-stringarg));
mXPUSHu(flags);
mXPUSHu((unsigned long)r);
PUTBACK;
/* fprintf(stderr,"exec hook r=%lu callback SV*=%lu\n",(unsigned long)r,(unsigned long)perl_callback); */
ret = call_sv(perl_callback, G_ARRAY);
/* fprintf(stderr,"exec hook survived.\n"); */
if(ret < 1) {
fprintf(stderr,"regexp_hook_exec failed - didnt return anything\n"); exit(0);
}
SPAGAIN;
matched = POPi;
{ /* fail captures */
int i;
for(i=0;i<=r->nparens;i++) {
r->startp[i] = -1;
r->endp[i] = -1;
}
r->lastparen = r->lastcloseparen = 0;
}
if(matched) {
SV* lp;
SV* lcp;
int i;
if(ret < 3 || ret > 3 + 2 * (r->nparens+1)) {
fprintf(stderr,"regexp_hook_exec failed - paren info broken\n"); exit(0);
}
lp = POPs;
lcp = POPs;
delta = stringarg-strbeg;
for(i=0;i<=r->nparens && i+3<ret;i++) {
I32 v = POPi;
r->startp[i] = v >= 0 ? v+delta : v;
v = POPi;
r->endp[i] = v >= 0 ? v+delta : v;
}
r->lastparen = (lp == &PL_sv_undef) ? SvIV(lp) : r->nparens;
r->lastcloseparen = (lcp == &PL_sv_undef) ? SvIV(lcp) : r->nparens;
Safefree(r->subbeg);
r->sublen = strend-strbeg;
r->subbeg = savepvn(strbeg,r->sublen);
}
PUTBACK;
FREETMPS;
LEAVE;
/* fprintf(stderr,"done.\n"); */
return matched ? 1 : 0;
}
}
char *
virtm_http_handler (void *cli, char *err, int max_len,
const char *base_uri, const char *content,
const char *params, const char **lines, int n_lines,
char **head_ret, const char **options, int n_options, char **diag_ret, int compile_only)
{
PerlInterpreter *intrp = (PerlInterpreter *) cli;
STRLEN n_a;
int nret;
char *retval = NULL;
log_debug ("virtm_http_handler");
if (compile_only)
return NULL;
if (!intrp)
{
SET_ERR ("client not attached to the interface");
return NULL;
}
PERL_SET_CONTEXT(intrp);
{
dTHXa(intrp);
dSP;
if (content)
{
ENTER ;
SAVETMPS ;
PUSHMARK(SP) ;
XPUSHs(base_uri ? sv_2mortal(newSVpv(base_uri, 0)) : &PL_sv_undef);
XPUSHs(content ? sv_2mortal(newSVpv(content, 0)) : &PL_sv_undef);
XPUSHs(sv_2mortal(newSViv(DO_CLEAN)));
XPUSHs(sv_2mortal(newSVpv("", 0)));
XPUSHs(options ? sv_2mortal(virtm_make_perl_hash(aTHX_ options, n_options)) : &PL_sv_undef);
XPUSHs(params ? sv_2mortal(newSVpv(params, 0)) : &PL_sv_undef);
XPUSHs(lines ? sv_2mortal(virtm_make_perl_array(aTHX_ lines, n_lines)) : &PL_sv_undef);
PUTBACK ;
nret = call_pv("VIRT::Embed::Persistent::eval_string", G_ARRAY | G_EVAL);
SPAGAIN;
}
else
{
ENTER ;
SAVETMPS ;
PUSHMARK(SP) ;
XPUSHs(base_uri ? sv_2mortal(newSVpv(base_uri, strlen (base_uri))) : &PL_sv_undef);
XPUSHs(sv_2mortal(newSViv(DO_CLEAN)));
XPUSHs(options ? sv_2mortal(virtm_make_perl_hash(aTHX_ options, n_options)) : &PL_sv_undef);
XPUSHs(params ? sv_2mortal(newSVpv(params, 0)) : &PL_sv_undef);
XPUSHs(lines ? sv_2mortal(virtm_make_perl_array(aTHX_ lines, n_lines)) : &PL_sv_undef);
PUTBACK ;
nret = call_pv("VIRT::Embed::Persistent::eval_file", G_ARRAY | G_EVAL);
SPAGAIN;
}
if(SvTRUE(ERRSV))
{
sprintf(err, "%.*s\n", max_len, SvPV(ERRSV,n_a));
SPAGAIN;
retval = NULL;
}
else
{
SPAGAIN;
if (nret == 3)
{
char * ptr;
#define virtPOPpx (SvPVx(POPs, n_a))
ptr = virtPOPpx;
*diag_ret = malloc (n_a + 1);
strncpy (*diag_ret, ptr, n_a);
(*diag_ret)[n_a] = 0;
ptr = virtPOPpx;
*head_ret = malloc (n_a + 1);
strncpy (*head_ret, ptr, n_a);
(*head_ret)[n_a] = 0;
ptr = virtPOPpx;
retval = malloc (n_a + 1);
strncpy (retval, ptr, n_a);
retval[n_a] = 0;
}
}
PUTBACK;
FREETMPS ;
LEAVE ;
}
return retval;
}
void FCN(int* npar,double* grad,double* fval,double* xval,int* iflag,double* futil){
SV* funname;
int count,i;
double* x;
I32 ax ;
pdl* pgrad;
SV* pgradsv;
pdl* pxval;
SV* pxvalsv;
int ndims;
PDLA_Indx *pdims;
dSP;
ENTER;
SAVETMPS;
/* get name of function on the Perl side */
funname = mnfunname;
ndims = 1;
pdims = (PDLA_Indx *) PDLA->smalloc( (STRLEN) ((ndims) * sizeof(*pdims)) );
pdims[0] = (PDLA_Indx) ene;
PUSHMARK(SP);
XPUSHs(sv_2mortal(newSVpv("PDLA", 0)));
PUTBACK;
perl_call_method("initialize", G_SCALAR);
SPAGAIN;
pxvalsv = POPs;
PUTBACK;
pxval = PDLA->SvPDLAV(pxvalsv);
PDLA->converttype( &pxval, PDLA_D, PDLA_PERM );
PDLA->children_changesoon(pxval,PDLA_PARENTDIMSCHANGED|PDLA_PARENTDATACHANGED);
PDLA->setdims (pxval,pdims,ndims);
pxval->state &= ~PDLA_NOMYDIMS;
pxval->state |= PDLA_ALLOCATED | PDLA_DONTTOUCHDATA;
PDLA->changed(pxval,PDLA_PARENTDIMSCHANGED|PDLA_PARENTDATACHANGED,0);
PUSHMARK(SP);
XPUSHs(sv_2mortal(newSVpv("PDLA", 0)));
PUTBACK;
perl_call_method("initialize", G_SCALAR);
SPAGAIN;
pgradsv = POPs;
PUTBACK;
pgrad = PDLA->SvPDLAV(pgradsv);
PDLA->converttype( &pgrad, PDLA_D, PDLA_PERM );
PDLA->children_changesoon(pgrad,PDLA_PARENTDIMSCHANGED|PDLA_PARENTDATACHANGED);
PDLA->setdims (pgrad,pdims,ndims);
pgrad->state &= ~PDLA_NOMYDIMS;
pgrad->state |= PDLA_ALLOCATED | PDLA_DONTTOUCHDATA;
PDLA->changed(pgrad,PDLA_PARENTDIMSCHANGED|PDLA_PARENTDATACHANGED,0);
pxval->data = (void *) xval;
pgrad->data = (void *) grad;
PUSHMARK(SP);
XPUSHs(sv_2mortal(newSViv(*npar)));
XPUSHs(pgradsv);
XPUSHs(sv_2mortal(newSVnv(*fval)));
XPUSHs(pxvalsv);
XPUSHs(sv_2mortal(newSViv(*iflag)));
PUTBACK;
count=call_sv(funname,G_ARRAY);
SPAGAIN;
SP -= count ;
ax = (SP - PL_stack_base) + 1 ;
if (count!=2)
croak("error calling perl function\n");
pgradsv = ST(1);
pgrad = PDLA->SvPDLAV(pgradsv);
x = (double *) pgrad->data;
for(i=0;i<ene;i++)
grad[i] = x[i];
*fval = SvNV(ST(0));
PUTBACK;
FREETMPS;
LEAVE;
}
void DFF(int* n, double* xval, double* vector){
//this version tries just to get the output
SV* funname;
double* xpass; int i;
int count;
I32 ax ;
pdl* px;
SV* pxsv;
pdl* pvector;
SV* pvectorsv;
int ndims;
PDL_Indx *pdims;
dSP;
ENTER;
SAVETMPS;
ndims = 1;
pdims = (PDL_Indx *) PDL->smalloc((STRLEN) ((ndims) * sizeof(*pdims)) );
pdims[0] = (PDL_Indx) ene;
PUSHMARK(SP);
XPUSHs(sv_2mortal(newSVpv("PDL", 0)));
PUTBACK;
perl_call_method("initialize", G_SCALAR);
SPAGAIN;
pxsv = POPs;
PUTBACK;
px = PDL->SvPDLV(pxsv);
PDL->converttype( &px, PDL_D, PDL_PERM );
PDL->children_changesoon(px,PDL_PARENTDIMSCHANGED|PDL_PARENTDATACHANGED);
PDL->setdims (px,pdims,ndims);
px->state &= ~PDL_NOMYDIMS;
px->state |= PDL_ALLOCATED | PDL_DONTTOUCHDATA;
PDL->changed(px,PDL_PARENTDIMSCHANGED|PDL_PARENTDATACHANGED,0);
px->data = (void *) xval;
/* get function name on the perl side */
funname = ext_funname1;
PUSHMARK(SP);
XPUSHs(pxsv);
PUTBACK;
count=call_sv(funname,G_SCALAR);
SPAGAIN;
SP -= count ;
ax = (SP - PL_stack_base) + 1 ;
if (count!=1)
croak("error calling perl function\n");
/* recover output value */
pvectorsv = ST(0);
pvector = PDL->SvPDLV(pvectorsv);
PDL->make_physical(pvector);
xpass = (double *) pvector->data;
for(i=0;i<ene;i++) {
vector[i] = xpass[i];
}
PUTBACK;
FREETMPS;
LEAVE;
}
int
NsPerl2_ModInit(char *server, char *module)
{
extern perl_master_context *nsperl2_master_context;
int perl_exitstatus;
Ns_Log(Notice,"nsperl2: loading");
if (!(nsperl2_master_context = ns_malloc (sizeof(perl_master_context))))
return TCL_ERROR;
/* determine initial perl script */
nsperl2_master_context->param_path = Ns_ConfigGetPath(server, module, NULL);
nsperl2_master_context->init_script = Ns_ConfigGetValue(nsperl2_master_context->param_path, "init_script");
nsperl2_master_context->init_sub = Ns_ConfigGetValue(nsperl2_master_context->param_path, "init_sub");
nsperl2_master_context->server = Ns_ConfigGetValue(nsperl2_master_context->param_path, "server");
/* TODO: what to do if multiple servers? probably need a master context per server */
Ns_Log (Notice, "nsperl2: init_script is %s", nsperl2_master_context->init_script);
char *embedding[] = { "", nsperl2_master_context->init_script };
PerlInterpreter *perl_interp;
int perl_argc = 0;
char **perl_argv = NULL;
PERL_SYS_INIT3( &perl_argc, &perl_argv, environ_h );
/* create perl interpreter */
if((perl_interp = perl_alloc()) == NULL) {
Ns_Log (Error, "Couldn't alloc perl interp");
return TCL_ERROR;
}
perl_construct(perl_interp);
PL_exit_flags |= PERL_EXIT_DESTRUCT_END; /* run END blocks at destruction */
PERL_SET_CONTEXT (perl_interp);
perl_exitstatus = perl_parse(perl_interp, xs_init, 2, embedding, NULL);
/* TODO: check perl_exitstatus */
nsperl2_master_context->perl_master_interp = perl_interp;
/* call the init_sub - eg. where urls are registered etc.
you could do the same in a BEGIN block, but this is cleaner */
dSP;
PUSHMARK (SP);
Tcl_Interp *tcl_interp;
tcl_interp = Ns_TclAllocateInterp (server);
set_nsperl2_globals (perl_interp, tcl_interp, NULL);
call_pv (nsperl2_master_context->init_sub, G_NOARGS | G_VOID | G_DISCARD); /* not doing G_EVAL - if init_sub fails, we want to bail. */
/* should I destroy that tcl interp?? */
Ns_RegisterShutdown (nsperl2_free_master_context, NULL);
Ns_TclInitInterps(server,NsPerl2InitInterp, NULL);
return NS_OK;
}
