static void modify_event_perl(PLCBA_t *async,
PLCBA_c_event *cevent,
PLCBA_evaction_t action,
short flags)
{
SV **tmpsv;
tmpsv = av_fetch(cevent->pl_event, PLCBA_EVIDX_FD, 1);
if (SvIOK(*tmpsv)) {
if (SvIV(*tmpsv) != cevent->fd) {
/*file descriptor mismatch!*/
av_delete(cevent->pl_event, PLCBA_EVIDX_DUPFH, G_DISCARD);
}
} else {
sv_setiv(*tmpsv, cevent->fd);
}
plcb_call_sv_with_args_noret(async->cv_evmod,
1,
3,
newRV_inc( (SV*)(cevent->pl_event)),
newSViv(action),
newSViv(flags));
/*set the current flags*/
if (action != PLCBA_EVACTION_SUSPEND && action != PLCBA_EVACTION_RESUME) {
sv_setiv( *(av_fetch(cevent->pl_event, PLCBA_EVIDX_WATCHFLAGS, 1)),
flags);
}
/*set the current state*/
sv_setiv( *(av_fetch(cevent->pl_event, PLCBA_EVIDX_STATEFLAGS, 1)),
cevent->state);
}
SV *
PLCBA_construct(const char *pkg, AV *options)
{
PLCBA_t *async;
char *host, *username, *password, *bucket;
libcouchbase_t instance;
SV *blessed_obj;
Newxz(async, 1, PLCBA_t);
extract_async_options(async, options);
plcb_ctor_conversion_opts(&async->base, options);
plcb_ctor_cbc_opts(options, &host, &username, &password, &bucket);
instance = libcouchbase_create(host, username, password, bucket,
plcba_make_io_opts(async));
if(!instance) {
die("Couldn't create instance!");
}
plcb_ctor_init_common(&async->base, instance, options);
plcba_setup_callbacks(async);
async->base_rv = newRV_inc(newSViv(PTR2IV(&(async->base))));
blessed_obj = newSV(0);
sv_setiv(newSVrv(blessed_obj, pkg), PTR2IV(async));
return blessed_obj;
}
SV*
newPerlPyObject_noinc(PyObject *pyo)
{
SV* rv;
SV* sv;
MAGIC *mg;
dCTXP;
ASSERT_LOCK_PERL;
if (!pyo)
croak("Missing pyo reference argument");
rv = newSV(0);
sv = newSVrv(rv, "Python::Object");
sv_setiv(sv, (IV)pyo);
sv_magic(sv, 0, '~', 0, 0);
mg = mg_find(sv, '~');
if (!mg) {
SvREFCNT_dec(rv);
croak("Can't assign magic to Python::Object");
}
mg->mg_virtual = &vtbl_free_pyo;
SvREADONLY(sv);
#ifdef REF_TRACE
printf("Bind pyo %p\n", pyo);
#endif
ASSERT_LOCK_PERL;
return rv;
}
static void
S_lazy_init_host_obj(kino_Obj *self)
{
SV *inner_obj = newSV(0);
SvOBJECT_on(inner_obj);
PL_sv_objcount++;
SvUPGRADE(inner_obj, SVt_PVMG);
sv_setiv(inner_obj, PTR2IV(self));
// Connect class association.
kino_CharBuf *class_name = Kino_VTable_Get_Name(self->vtable);
HV *stash = gv_stashpvn((char*)Kino_CB_Get_Ptr8(class_name),
Kino_CB_Get_Size(class_name), TRUE);
SvSTASH_set(inner_obj, (HV*)SvREFCNT_inc(stash));
/* Up till now we've been keeping track of the refcount in
* self->ref.count. We're replacing ref.count with ref.host_obj, which
* will assume responsibility for maintaining the refcount. ref.host_obj
* starts off with a refcount of 1, so we need to transfer any refcounts
* in excess of that. */
size_t old_refcount = self->ref.count;
self->ref.host_obj = inner_obj;
while (old_refcount > 1) {
SvREFCNT_inc_simple_void_NN(inner_obj);
old_refcount--;
}
}
static void
modify_event_perl(plcb_IOPROCS *async, plcb_EVENT *cevent, short flags)
{
SV **tmpsv;
tmpsv = av_fetch(cevent->pl_event, PLCB_EVIDX_FD, 1);
if (SvIOK(*tmpsv)) {
SvIVX(*tmpsv) = cevent->fd;
} else {
sv_setiv(*tmpsv, cevent->fd);
}
SvIVX(async->flags_sv) = flags;
/* Figure out the proper masks */
SvIVX(async->sched_r_sv) = flags & LCB_READ_EVENT && (cevent->flags & LCB_READ_EVENT) == 0;
SvIVX(async->sched_w_sv) = flags & LCB_WRITE_EVENT && (cevent->flags & LCB_WRITE_EVENT) == 0;
SvIVX(async->stop_r_sv) = (flags & LCB_READ_EVENT) == 0 && cevent->flags & LCB_READ_EVENT;
SvIVX(async->stop_w_sv) = (flags & LCB_WRITE_EVENT) == 0 && cevent->flags & LCB_WRITE_EVENT;
cb_args_noret(async->cv_evmod, 0, 7,
async->userdata, cevent->rv_event, async->flags_sv,
async->sched_r_sv, async->sched_w_sv,
async->stop_r_sv, async->stop_w_sv);
cevent->flags = flags;
tmpsv = av_fetch(cevent->pl_event, PLCB_EVIDX_WATCHFLAGS, 1);
SvIVX(*tmpsv) = cevent->flags;
}
static void
init_help_consts (void)
{
/* Export our constants as global variables. */
const struct {
const char *name;
int value;
} consts[] = {
{ "GNM_FUNC_HELP_NAME", GNM_FUNC_HELP_NAME },
{ "GNM_FUNC_HELP_ARG", GNM_FUNC_HELP_ARG },
{ "GNM_FUNC_HELP_DESCRIPTION", GNM_FUNC_HELP_DESCRIPTION },
{ "GNM_FUNC_HELP_NOTE", GNM_FUNC_HELP_NOTE },
{ "GNM_FUNC_HELP_EXAMPLES", GNM_FUNC_HELP_EXAMPLES },
{ "GNM_FUNC_HELP_SEEALSO", GNM_FUNC_HELP_SEEALSO },
{ "GNM_FUNC_HELP_EXTREF", GNM_FUNC_HELP_EXTREF },
{ "GNM_FUNC_HELP_EXCEL", GNM_FUNC_HELP_EXCEL },
{ "GNM_FUNC_HELP_ODF", GNM_FUNC_HELP_ODF }
};
unsigned ui;
for (ui = 0; ui < G_N_ELEMENTS (consts); ui++) {
SV* x = get_sv (consts[ui].name, TRUE);
sv_setiv (x, consts[ui].value);
}
}
static int xsDecode(HV* hv, AV* av, SV* src, bool useIO) {
csv_t csv;
int result;
SetupCsv(&csv, hv);
if ((csv.useIO = useIO)) {
csv.tmp = NULL;
csv.size = 0;
} else {
STRLEN size;
csv.tmp = src;
csv.bptr = SvPV(src, size);
csv.size = size;
}
result = Decode(&csv, src, av);
if (result && csv.types) {
I32 i, len = av_len(av);
SV** svp;
for (i = 0; i <= len && i <= csv.types_len; i++) {
if ((svp = av_fetch(av, i, 0)) && *svp && SvOK(*svp)) {
switch (csv.types[i]) {
case CSV_XS_TYPE_IV:
sv_setiv(*svp, SvIV(*svp));
break;
case CSV_XS_TYPE_NV:
sv_setnv(*svp, SvIV(*svp));
break;
}
}
}
}
return result;
}
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;
}
SV* P_newSVqv2(pTHX_ int i, const char* (*func)(int i,int* len)){
int len;
const char* s=(*func)(i,&len);
SV* m=newSVpv(s,len);
sv_setiv(m,i);
SvPOK_on(m);
return m;
}
void decode_tinyint(pTHX_ unsigned char *input, STRLEN len, struct cc_type *type, SV *output)
{
if (UNLIKELY(len != 1))
croak("decode_tinyint: len != 1");
int8_t number = *input;
sv_setiv(output, number);
}
int IntToScalar(PERL_CALL SV *string, int val)
{
if(!string)
return 0;
sv_setiv(string, val);
return 1;
}
/*
* Create a new ::Object by wrapping an ea_object_t in a perl SV. This is used
* to wrap exacct records that have been read from a file, or packed records
* that have been inflated.
*/
SV *
new_xs_ea_object(ea_object_t *ea_obj)
{
xs_ea_object_t *xs_obj;
SV *sv_obj;
/* Allocate space - use perl allocator. */
New(0, xs_obj, 1, xs_ea_object_t);
PERL_ASSERT(xs_obj != NULL);
xs_obj->ea_obj = ea_obj;
xs_obj->perl_obj = NULL;
sv_obj = NEWSV(0, 0);
PERL_ASSERT(sv_obj != NULL);
/*
* Initialise according to the type of the passed exacct object,
* and bless the perl object into the appropriate class.
*/
if (ea_obj->eo_type == EO_ITEM) {
if ((ea_obj->eo_catalog & EXT_TYPE_MASK) == EXT_EXACCT_OBJECT) {
INIT_EMBED_ITEM_FLAGS(xs_obj);
} else {
INIT_PLAIN_ITEM_FLAGS(xs_obj);
}
sv_setiv(newSVrv(sv_obj, NULL), PTR2IV(xs_obj));
sv_bless(sv_obj, Sun_Solaris_Exacct_Object_Item_stash);
} else {
INIT_GROUP_FLAGS(xs_obj);
sv_setiv(newSVrv(sv_obj, NULL), PTR2IV(xs_obj));
sv_bless(sv_obj, Sun_Solaris_Exacct_Object_Group_stash);
}
/*
* We are passing back a pointer masquerading as a perl IV,
* so make sure it can't be modified.
*/
SvREADONLY_on(SvRV(sv_obj));
return (sv_obj);
}
void decode_int(pTHX_ unsigned char *input, STRLEN len, struct cc_type *type, SV *output)
{
union {
unsigned char bytes[4];
int32_t i;
} bytes_or_int;
if (UNLIKELY(len != 4))
croak("decode_int: len != 4");
memcpy(bytes_or_int.bytes, input, 4);
bswap4(bytes_or_int.bytes);
sv_setiv(output, bytes_or_int.i);
}
void decode_bigint(pTHX_ unsigned char *input, STRLEN len, struct cc_type *type, SV *output)
{
union {
unsigned char bytes[8];
int64_t bigint;
} bytes_or_bigint;
if (UNLIKELY(len != 8))
croak("decode_bigint: len != 8");
memcpy(bytes_or_bigint.bytes, input, 8);
bswap8(bytes_or_bigint.bytes);
sv_setiv(output, bytes_or_bigint.bigint);
}
void decode_smallint(pTHX_ unsigned char *input, STRLEN len, struct cc_type *type, SV *output)
{
union {
unsigned char bytes[2];
int16_t i;
} bytes_or_smallint;
if (UNLIKELY(len != 2))
croak("decode_smallint: len != 2");
memcpy(bytes_or_smallint.bytes, input, 2);
bswap2(bytes_or_smallint.bytes);
sv_setiv(output, bytes_or_smallint.i);
}
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;
}
void
Perl_av_extend(pTHX_ AV *av, SSize_t key)
{
MAGIC *mg;
PERL_ARGS_ASSERT_AV_EXTEND;
assert(SvTYPE(av) == SVt_PVAV);
mg = SvTIED_mg((const SV *)av, PERL_MAGIC_tied);
if (UNLIKELY(mg)) {
SV *arg1 = sv_newmortal();
sv_setiv(arg1, (IV)(key + 1));
Perl_magic_methcall(aTHX_ MUTABLE_SV(av), mg, SV_CONST(EXTEND), G_DISCARD, 1,
arg1);
return;
}
av_extend_guts(av,key,&AvMAX(av),&AvALLOC(av),&AvARRAY(av));
}
SV *
ithread_to_SV(pTHX_ SV *obj, ithread *thread, char *classname, bool inc)
{
SV *sv;
MAGIC *mg;
if (inc) {
MUTEX_LOCK(&thread->mutex);
thread->count++;
MUTEX_UNLOCK(&thread->mutex);
}
if (!obj)
obj = newSV(0);
sv = newSVrv(obj,classname);
sv_setiv(sv,PTR2IV(thread));
mg = sv_magicext(sv,Nullsv,PERL_MAGIC_shared_scalar,&ithread_vtbl,(char *)thread,0);
mg->mg_flags |= MGf_DUP;
SvREADONLY_on(sv);
return obj;
}
PJS_EXTERN SV *
PJS_CallPerlMethod(
pTHX_
JSContext *cx,
const char *method,
...
) {
dSP;
va_list ap;
SV *arg, *ret;
PJS_Context *pcx = PJS_GET_CONTEXT(cx);
ENTER;
SAVETMPS;
PUSHMARK(SP);
sv_setiv(save_scalar(PJS_Context_SV), PTR2IV(pcx));
va_start(ap, method);
while( (arg = va_arg(ap, SV*)) ) XPUSHs(arg);
va_end(ap);
PUTBACK;
call_method(method, G_SCALAR | G_EVAL);
ret = newSVsv(*PL_stack_sp--);
FREETMPS;
LEAVE;
if (SvTRUE(ERRSV)) {
sv_free(ret); // Don't want leaks
propagate2JS(aTHX_ pcx, NULL);
return NULL;
}
return sv_2mortal(ret);
}
int perl_trapd_handler( netsnmp_pdu *pdu,
netsnmp_transport *transport,
netsnmp_trapd_handler *handler)
{
trapd_cb_data *cb_data;
SV *pcallback;
netsnmp_variable_list *vb;
netsnmp_oid *o;
SV *arg;
SV *rarg;
SV **tmparray;
int i, c = 0;
u_char *outbuf;
size_t ob_len = 0, oo_len = 0;
AV *varbinds;
HV *pduinfo;
dSP;
ENTER;
SAVETMPS;
if (!pdu || !handler)
return 0;
/* nuke v1 PDUs */
if (pdu->command == SNMP_MSG_TRAP)
pdu = convert_v1pdu_to_v2(pdu);
cb_data = handler->handler_data;
if (!cb_data || !cb_data->perl_cb)
return 0;
pcallback = cb_data->perl_cb;
/* get PDU related info */
pduinfo = newHV();
#define STOREPDU(n, v) hv_store(pduinfo, n, strlen(n), v, 0)
#define STOREPDUi(n, v) STOREPDU(n, newSViv(v))
#define STOREPDUs(n, v) STOREPDU(n, newSVpv(v, 0))
STOREPDUi("version", pdu->version);
STOREPDUs("notificationtype", ((pdu->command == SNMP_MSG_INFORM) ? "INFORM":"TRAP"));
STOREPDUi("requestid", pdu->reqid);
STOREPDUi("messageid", pdu->msgid);
STOREPDUi("transactionid", pdu->transid);
STOREPDUi("errorstatus", pdu->errstat);
STOREPDUi("errorindex", pdu->errindex);
if (pdu->version == 3) {
STOREPDUi("securitymodel", pdu->securityModel);
STOREPDUi("securitylevel", pdu->securityLevel);
STOREPDU("contextName",
newSVpv(pdu->contextName, pdu->contextNameLen));
STOREPDU("contextEngineID",
newSVpv(pdu->contextEngineID,
pdu->contextEngineIDLen));
STOREPDU("securityEngineID",
newSVpv(pdu->securityEngineID,
pdu->securityEngineIDLen));
STOREPDU("securityName",
newSVpv(pdu->securityName, pdu->securityNameLen));
} else {
STOREPDU("community",
newSVpv(pdu->community, pdu->community_len));
}
if (transport && transport->f_fmtaddr) {
char *tstr = transport->f_fmtaddr(transport, pdu->transport_data,
pdu->transport_data_length);
STOREPDUs("receivedfrom", tstr);
free(tstr);
}
/*
* collect OID objects in a temp array first
*/
/* get VARBIND related info */
i = count_varbinds(pdu->variables);
tmparray = malloc(sizeof(*tmparray) * i);
for(vb = pdu->variables; vb; vb = vb->next_variable) {
/* get the oid */
o = SNMP_MALLOC_TYPEDEF(netsnmp_oid);
o->name = o->namebuf;
o->len = vb->name_length;
memcpy(o->name, vb->name, vb->name_length * sizeof(oid));
#undef CALL_EXTERNAL_OID_NEW
#ifdef CALL_EXTERNAL_OID_NEW
PUSHMARK(sp);
rarg = sv_2mortal(newSViv((IV) 0));
arg = sv_2mortal(newSVrv(rarg, "netsnmp_oidPtr"));
sv_setiv(arg, (IV) o);
XPUSHs(rarg);
PUTBACK;
i = perl_call_pv("NetSNMP::OID::newwithptr", G_SCALAR);
SPAGAIN;
if (i != 1) {
snmp_log(LOG_ERR, "unhandled OID error.\n");
/* ack XXX */
}
/* get the value */
tmparray[c++] = POPs;
SvREFCNT_inc(tmparray[c-1]);
PUTBACK;
#else /* build it and bless ourselves */
{
HV *hv = newHV();
SV *rv = newRV_noinc((SV *) hv);
SV *rvsub = newRV_noinc((SV *) newSViv((UV) o));
SV *sv;
rvsub = sv_bless(rvsub, gv_stashpv("netsnmp_oidPtr", 1));
hv_store(hv, "oidptr", 6, rvsub, 0);
rv = sv_bless(rv, gv_stashpv("NetSNMP::OID", 1));
tmparray[c++] = rv;
}
#endif /* build oid ourselves */
}
/*
* build the varbind lists
*/
varbinds = newAV();
for(vb = pdu->variables, i = 0; vb; vb = vb->next_variable, i++) {
/* push the oid */
AV *vba;
vba = newAV();
/* get the value */
outbuf = NULL;
ob_len = 0;
oo_len = 0;
sprint_realloc_by_type(&outbuf, &ob_len, &oo_len, 1,
vb, 0, 0, 0);
av_push(vba,tmparray[i]);
av_push(vba,newSVpvn(outbuf, oo_len));
free(outbuf);
av_push(vba,newSViv(vb->type));
av_push(varbinds, (SV *) newRV_noinc((SV *) vba));
}
PUSHMARK(sp);
/* store the collected information on the stack */
XPUSHs(sv_2mortal(newRV_noinc((SV*) pduinfo)));
XPUSHs(sv_2mortal(newRV_noinc((SV*) varbinds)));
/* put the stack back in order */
PUTBACK;
/* actually call the callback function */
if (SvTYPE(pcallback) == SVt_PVCV) {
perl_call_sv(pcallback, G_DISCARD);
/* XXX: it discards the results, which isn't right */
} else if (SvROK(pcallback) && SvTYPE(SvRV(pcallback)) == SVt_PVCV) {
/* reference to code */
perl_call_sv(SvRV(pcallback), G_DISCARD);
} else {
snmp_log(LOG_ERR, " tried to call a perl function but failed to understand its type: (ref = %x, svrok: %lu, SVTYPE: %lu)\n", (uintptr_t)pcallback, SvROK(pcallback), SvTYPE(pcallback));
}
#ifdef DUMPIT
fprintf(stderr, "DUMPDUMPDUMPDUMPDUMPDUMP\n");
sv_dump(pduinfo);
fprintf(stderr, "--------------------\n");
sv_dump(varbinds);
#endif
/* svREFCNT_dec((SV *) pduinfo); */
#ifdef NOT_THIS
{
SV *vba;
while(vba = av_pop(varbinds)) {
av_undef((AV *) vba);
}
}
av_undef(varbinds);
#endif
free(tmparray);
/* Not needed because of the G_DISCARD flag (I think) */
/* SPAGAIN; */
/* PUTBACK; */
#ifndef __x86_64__
FREETMPS; /* FIXME: known to cause a segfault on x86-64 */
#endif
LEAVE;
return NETSNMPTRAPD_HANDLER_OK;
}
PJS_EXTERN JSBool
PJS_Call_sv_with_jsvals_rsv(
pTHX_
JSContext *cx,
JSObject *obj,
SV *code,
SV *caller, /* Will be disposed inside */
uintN argc,
jsval *argv,
SV **rsv,
I32 flag
) {
dSP;
JSBool ok = JS_TRUE;
uintN arg;
I32 rcount = caller ? 1 : 0;
PJS_Context *pcx = PJS_GET_CONTEXT(cx);
if(SvROK(code) && SvTYPE(SvRV(code)) == SVt_PVCV) {
ENTER; SAVETMPS;
PUSHMARK(SP) ;
sv_setiv(save_scalar(PJS_Context_SV), PTR2IV(pcx));
EXTEND(SP, argc + rcount);
PUTBACK;
/* From here we are working with the global stack,
* a) at PUSH time we can fail, so we need to abort the call
* b) Want to avoid copying local <=> global SP at every single PUSH
*
* Before 'call_sv', rcount is the number of SVs pushed so far
*/
if(caller) *++PL_stack_sp = sv_2mortal(caller);
if(argv && !(flag & G_NOARGS)) {
/* HACK: We use G_NOARGS as a guard against use argv[-1] to get This.
* Needed for the use in PJS_invoke_perl_property_setter where given
* argc is faked
*/
SV *This;
ok = PJS_ReflectJS2Perl(aTHX_ cx, argv[-1], &This, 0);
if(ok) sv_setsv(save_scalar(PJS_This), sv_2mortal(This));
else goto forget;
}
else flag &= ~G_NOARGS;
for(arg = 0; arg < argc; arg++) {
SV *sv;
ok = PJS_ReflectJS2Perl(aTHX_ cx, argv[arg], &sv, 1);
if(!ok) {
rcount += arg;
goto forget;
}
*++PL_stack_sp = sv_2mortal(sv);
}
rcount = call_sv(code, flag | G_EVAL);
if(rsv) {
if(flag == G_SCALAR || rcount == 1)
*rsv = SvREFCNT_inc_simple_NN(*PL_stack_sp);
else
*rsv = newRV((SV *)av_make(rcount, PL_stack_sp-rcount+1));
SAVEMORTALIZESV(*rsv);
}
forget:
PL_stack_sp -= rcount;
FREETMPS; LEAVE;
if(ok && SvTRUE(ERRSV)) {
propagate2JS(aTHX_ pcx, obj);
ok = JS_FALSE;
}
}
else croak("Not a coderef");
return ok;
}
/****************************
* SV* Py2Pl(PyObject *obj)
*
* Converts arbitrary Python data structures to Perl data structures
* Note on references: does not Py_DECREF(obj).
*
* Modifications by Eric Wilhelm 2004-07-11 marked as elw
*
****************************/
SV *Py2Pl(PyObject * const obj) {
/* elw: see what python says things are */
#if PY_MAJOR_VERSION >= 3
int const is_string = PyBytes_Check(obj) || PyUnicode_Check(obj);
#else
int const is_string = PyString_Check(obj) || PyUnicode_Check(obj);
#endif
#ifdef I_PY_DEBUG
PyObject *this_type = PyObject_Type(obj); /* new reference */
PyObject *t_string = PyObject_Str(this_type); /* new reference */
#if PY_MAJOR_VERSION >= 3
PyObject *type_str_bytes = PyUnicode_AsUTF8String(t_string); /* new reference */
char *type_str = PyBytes_AsString(type_str_bytes);
#else
char *type_str = PyString_AsString(t_string);
#endif
Printf(("type is %s\n", type_str));
printf("Py2Pl object:\n\t");
PyObject_Print(obj, stdout, Py_PRINT_RAW);
printf("\ntype:\n\t");
PyObject_Print(this_type, stdout, Py_PRINT_RAW);
printf("\n");
Printf(("String check: %i\n", is_string));
Printf(("Number check: %i\n", PyNumber_Check(obj)));
Printf(("Int check: %i\n", PyInt_Check(obj)));
Printf(("Long check: %i\n", PyLong_Check(obj)));
Printf(("Float check: %i\n", PyFloat_Check(obj)));
Printf(("Type check: %i\n", PyType_Check(obj)));
#if PY_MAJOR_VERSION < 3
Printf(("Class check: %i\n", PyClass_Check(obj)));
Printf(("Instance check: %i\n", PyInstance_Check(obj)));
#endif
Printf(("Dict check: %i\n", PyDict_Check(obj)));
Printf(("Mapping check: %i\n", PyMapping_Check(obj)));
Printf(("Sequence check: %i\n", PySequence_Check(obj)));
Printf(("Iter check: %i\n", PyIter_Check(obj)));
Printf(("Function check: %i\n", PyFunction_Check(obj)));
Printf(("Module check: %i\n", PyModule_Check(obj)));
Printf(("Method check: %i\n", PyMethod_Check(obj)));
#if PY_MAJOR_VERSION < 3
if ((obj->ob_type->tp_flags & Py_TPFLAGS_HEAPTYPE))
printf("heaptype true\n");
if ((obj->ob_type->tp_flags & Py_TPFLAGS_HAVE_CLASS))
printf("has class\n");
#else
Py_DECREF(type_str_bytes);
#endif
Py_DECREF(t_string);
Py_DECREF(this_type);
#endif
/* elw: this needs to be early */
/* None (like undef) */
if (!obj || obj == Py_None) {
Printf(("Py2Pl: Py_None\n"));
return &PL_sv_undef;
}
else
#ifdef EXPOSE_PERL
/* unwrap Perl objects */
if (PerlObjObject_Check(obj)) {
Printf(("Py2Pl: Obj_object\n"));
return ((PerlObj_object *) obj)->obj;
}
/* unwrap Perl code refs */
else if (PerlSubObject_Check(obj)) {
Printf(("Py2Pl: Sub_object\n"));
SV * ref = ((PerlSub_object *) obj)->ref;
if (! ref) { /* probably an inherited method */
if (! ((PerlSub_object *) obj)->obj)
croak("Error: could not find a code reference or object method for PerlSub");
SV * const sub_obj = (SV*)SvRV(((PerlSub_object *) obj)->obj);
HV * const pkg = SvSTASH(sub_obj);
#if PY_MAJOR_VERSION >= 3
char * const sub = PyBytes_AsString(((PerlSub_object *) obj)->sub);
#else
PyObject *obj_sub_str = PyObject_Str(((PerlSub_object *) obj)->sub); /* new ref. */
char * const sub = PyString_AsString(obj_sub_str);
#endif
GV * const gv = Perl_gv_fetchmethod_autoload(aTHX_ pkg, sub, TRUE);
if (gv && isGV(gv)) {
ref = (SV *)GvCV(gv);
}
#if PY_MAJOR_VERSION < 3
Py_DECREF(obj_sub_str);
#endif
}
return newRV_inc((SV *) ref);
}
else
#endif
/* wrap an instance of a Python class */
/* elw: here we need to make these look like instances: */
if ((obj->ob_type->tp_flags & Py_TPFLAGS_HEAPTYPE)
#if PY_MAJOR_VERSION < 3
|| PyInstance_Check(obj)
#endif
) {
/* This is a Python class instance -- bless it into an
* Inline::Python::Object. If we're being called from an
* Inline::Python class, it will be re-blessed into whatever
* class that is.
*/
SV * const inst_ptr = newSViv(0);
SV * const inst = newSVrv(inst_ptr, "Inline::Python::Object");;
_inline_magic priv;
/* set up magic */
priv.key = INLINE_MAGIC_KEY;
sv_magic(inst, inst, PERL_MAGIC_ext, (char *) &priv, sizeof(priv));
MAGIC * const mg = mg_find(inst, PERL_MAGIC_ext);
mg->mg_virtual = &inline_mg_vtbl;
sv_setiv(inst, (IV) obj);
/*SvREADONLY_on(inst); */ /* to uncomment this means I can't
re-bless it */
Py_INCREF(obj);
Printf(("Py2Pl: Instance. Obj: %p, inst_ptr: %p\n", obj, inst_ptr));
sv_2mortal(inst_ptr);
return inst_ptr;
}
/* a tuple or a list */
else if (PySequence_Check(obj) && !is_string) {
AV * const retval = newAV();
int i;
int const sz = PySequence_Length(obj);
Printf(("sequence (%i)\n", sz));
for (i = 0; i < sz; i++) {
PyObject * const tmp = PySequence_GetItem(obj, i); /* new reference */
SV * const next = Py2Pl(tmp);
av_push(retval, next);
if (sv_isobject(next)) // needed because objects get mortalized in Py2Pl
SvREFCNT_inc(next);
Py_DECREF(tmp);
}
if (PyTuple_Check(obj)) {
_inline_magic priv;
priv.key = TUPLE_MAGIC_KEY;
sv_magic((SV * const)retval, (SV * const)NULL, PERL_MAGIC_ext, (char *) &priv, sizeof(priv));
}
return newRV_noinc((SV *) retval);
}
/* a dictionary or fake Mapping object */
/* elw: PyMapping_Check() now returns true for strings */
else if (! is_string && PyMapping_Check(obj)) {
HV * const retval = newHV();
int i;
int const sz = PyMapping_Length(obj);
PyObject * const keys = PyMapping_Keys(obj); /* new reference */
PyObject * const vals = PyMapping_Values(obj); /* new reference */
Printf(("Py2Pl: dict/map\n"));
Printf(("mapping (%i)\n", sz));
for (i = 0; i < sz; i++) {
PyObject * const key = PySequence_GetItem(keys, i), /* new reference */
* const val = PySequence_GetItem(vals, i); /* new reference */
SV * const sv_val = Py2Pl(val);
char * key_val;
if (PyUnicode_Check(key)) {
PyObject * const utf8_string = PyUnicode_AsUTF8String(key); /* new reference */
#if PY_MAJOR_VERSION >= 3
key_val = PyBytes_AsString(utf8_string);
SV * const utf8_key = newSVpv(key_val, PyBytes_Size(utf8_string));
#else
key_val = PyString_AsString(utf8_string);
SV * const utf8_key = newSVpv(key_val, PyString_Size(utf8_string));
#endif
SvUTF8_on(utf8_key);
hv_store_ent(retval, utf8_key, sv_val, 0);
Py_DECREF(utf8_string);
}
else {
PyObject * s = NULL;
#if PY_MAJOR_VERSION >= 3
PyObject * s_bytes = NULL;
if (PyBytes_Check(key)) {
key_val = PyBytes_AsString(key);
#else
if (PyString_Check(key)) {
key_val = PyString_AsString(key);
#endif
}
else {
/* Warning -- encountered a non-string key value while converting a
* Python dictionary into a Perl hash. Perl can only use strings as
* key values. Using Python's string representation of the key as
* Perl's key value.
*/
s = PyObject_Str(key); /* new reference */
#if PY_MAJOR_VERSION >= 3
s_bytes = PyUnicode_AsUTF8String(s); /* new reference */
key_val = PyBytes_AsString(s_bytes);
#else
key_val = PyString_AsString(s);
#endif
Py_DECREF(s);
if (PL_dowarn)
warn("Stringifying non-string hash key value: '%s'",
key_val);
}
if (!key_val) {
croak("Invalid key on key %i of mapping\n", i);
}
hv_store(retval, key_val, strlen(key_val), sv_val, 0);
#if PY_MAJOR_VERSION >= 3
Py_XDECREF(s_bytes);
#endif
Py_XDECREF(s);
}
if (sv_isobject(sv_val)) // needed because objects get mortalized in Py2Pl
SvREFCNT_inc(sv_val);
Py_DECREF(key);
Py_DECREF(val);
}
Py_DECREF(keys);
Py_DECREF(vals);
return newRV_noinc((SV *) retval);
}
/* a boolean */
else if (PyBool_Check(obj)) {
void
Tcl_SetBooleanObj (Tcl_Obj *objPtr, int value)
{
dTHX;
sv_setiv(ForceScalarLvalue(aTHX_ objPtr),value != 0);
}
SV* P_newSVqv(pTHX_ const char* s, int i){
SV* m=newSVpv(s,strlen(s));
sv_setiv(m,i);
SvPOK_on(m);
return m;
}
void
Tcl_SetIntObj (Tcl_Obj *objPtr, int value)
{
dTHX;
sv_setiv(ForceScalarLvalue(aTHX_ objPtr),value);
}
void
Tcl_SetLongObj (Tcl_Obj *objPtr, long value)
{
dTHX;
sv_setiv(ForceScalarLvalue(aTHX_ objPtr),value);
}
SV* P_newSVqvn(pTHX_ const char* s, STRLEN len, int i){
SV* m=newSVpv(s,len);
sv_setiv(m,i);
SvPOK_on(m);
return m;
}
void
ffi_pl_closure_call(ffi_cif *ffi_cif, void *result, void **arguments, void *user)
{
dSP;
ffi_pl_closure *closure = (ffi_pl_closure*) user;
ffi_pl_type_extra_closure *extra = &closure->type->extra[0].closure;
int flags = extra->flags;
int i;
int count;
SV *sv;
SV **svp;
if(!(flags & G_NOARGS))
{
ENTER;
SAVETMPS;
}
PUSHMARK(SP);
if(!(flags & G_NOARGS))
{
for(i=0; i< ffi_cif->nargs; i++)
{
if(extra->argument_types[i]->platypus_type == FFI_PL_NATIVE)
{
switch(extra->argument_types[i]->ffi_type->type)
{
case FFI_TYPE_VOID:
break;
case FFI_TYPE_UINT8:
sv = sv_newmortal();
sv_setuv(sv, *((uint8_t*)arguments[i]));
XPUSHs(sv);
break;
case FFI_TYPE_SINT8:
sv = sv_newmortal();
sv_setiv(sv, *((int8_t*)arguments[i]));
XPUSHs(sv);
break;
case FFI_TYPE_UINT16:
sv = sv_newmortal();
sv_setuv(sv, *((uint16_t*)arguments[i]));
XPUSHs(sv);
break;
case FFI_TYPE_SINT16:
sv = sv_newmortal();
sv_setiv(sv, *((int16_t*)arguments[i]));
XPUSHs(sv);
break;
case FFI_TYPE_UINT32:
sv = sv_newmortal();
sv_setuv(sv, *((uint32_t*)arguments[i]));
XPUSHs(sv);
break;
case FFI_TYPE_SINT32:
sv = sv_newmortal();
sv_setiv(sv, *((int32_t*)arguments[i]));
XPUSHs(sv);
break;
case FFI_TYPE_UINT64:
sv = sv_newmortal();
#ifdef HAVE_IV_IS_64
sv_setuv(sv, *((uint64_t*)arguments[i]));
#else
sv_setu64(sv, *((uint64_t*)arguments[i]));
#endif
XPUSHs(sv);
break;
case FFI_TYPE_SINT64:
sv = sv_newmortal();
#ifdef HAVE_IV_IS_64
sv_setiv(sv, *((int64_t*)arguments[i]));
#else
sv_seti64(sv, *((int64_t*)arguments[i]));
#endif
XPUSHs(sv);
break;
case FFI_TYPE_FLOAT:
sv = sv_newmortal();
sv_setnv(sv, *((float*)arguments[i]));
XPUSHs(sv);
break;
case FFI_TYPE_DOUBLE:
sv = sv_newmortal();
sv_setnv(sv, *((double*)arguments[i]));
XPUSHs(sv);
break;
case FFI_TYPE_POINTER:
sv = sv_newmortal();
if( *((void**)arguments[i]) != NULL)
sv_setiv(sv, PTR2IV( *((void**)arguments[i]) ));
XPUSHs(sv);
break;
}
}
else if(extra->argument_types[i]->platypus_type == FFI_PL_STRING)
{
sv = sv_newmortal();
if( *((char**)arguments[i]) != NULL)
{
if(extra->argument_types[i]->extra[0].string.platypus_string_type == FFI_PL_STRING_FIXED)
sv_setpvn(sv, *((char**)arguments[i]), extra->argument_types[i]->extra[0].string.size);
else
sv_setpv(sv, *((char**)arguments[i]));
}
XPUSHs(sv);
}
}
PUTBACK;
}
svp = hv_fetch((HV *)SvRV((SV *)closure->coderef), "code", 4, 0);
if (svp)
count = call_sv(*svp, flags | G_EVAL);
else
count = 0;
if(SvTRUE(ERRSV))
{
#ifdef warn_sv
warn_sv(ERRSV);
#else
warn("%s", SvPV_nolen(ERRSV));
#endif
}
if(!(flags & G_DISCARD))
{
SPAGAIN;
if(count != 1)
sv = &PL_sv_undef;
else
sv = POPs;
if(extra->return_type->platypus_type == FFI_PL_NATIVE)
{
switch(extra->return_type->ffi_type->type)
{
case FFI_TYPE_UINT8:
#ifdef FFI_PL_PROBE_BIGENDIAN
((uint8_t*)result)[3] = SvUV(sv);
#else
*((uint8_t*)result) = SvUV(sv);
#endif
break;
case FFI_TYPE_SINT8:
#ifdef FFI_PL_PROBE_BIGENDIAN
((int8_t*)result)[3] = SvIV(sv);
#else
*((int8_t*)result) = SvIV(sv);
#endif
break;
case FFI_TYPE_UINT16:
#ifdef FFI_PL_PROBE_BIGENDIAN
((uint16_t*)result)[1] = SvUV(sv);
#else
*((uint16_t*)result) = SvUV(sv);
#endif
break;
case FFI_TYPE_SINT16:
#ifdef FFI_PL_PROBE_BIGENDIAN
((int16_t*)result)[1] = SvIV(sv);
#else
*((int16_t*)result) = SvIV(sv);
#endif
break;
case FFI_TYPE_UINT32:
*((uint32_t*)result) = SvUV(sv);
break;
case FFI_TYPE_SINT32:
*((int32_t*)result) = SvIV(sv);
break;
case FFI_TYPE_UINT64:
#ifdef HAVE_IV_IS_64
*((uint64_t*)result) = SvUV(sv);
#else
*((uint64_t*)result) = SvU64(sv);
#endif
break;
case FFI_TYPE_SINT64:
#ifdef HAVE_IV_IS_64
*((int64_t*)result) = SvIV(sv);
#else
*((int64_t*)result) = SvI64(sv);
#endif
break;
case FFI_TYPE_FLOAT:
*((float*)result) = SvNV(sv);
break;
case FFI_TYPE_DOUBLE:
*((double*)result) = SvNV(sv);
break;
case FFI_TYPE_POINTER:
*((void**)result) = SvOK(sv) ? INT2PTR(void*, SvIV(sv)) : NULL;
break;
}
}
PUTBACK;
}
I32 magic_c_int_get(IV num, SV *sv) {
MAGIC *mg = mg_find(sv, (int)'U');
sv_setiv(sv, *((int *)(SvIV(mg->mg_obj))));
return 1;
}
/*
* 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 const *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;
HV *rad_state_hv;
#ifdef WITH_PROXY
HV *rad_request_proxy_hv;
HV *rad_request_proxy_reply_hv;
#endif
SV *rad_requestp_sv;
/*
* 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);
rad_state_hv = get_hv("RAD_STATE", 1);
rad_requestp_sv = get_sv("RAD___REQUESTP", 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->config, rad_check_hv, "RAD_CHECK", "control");
perl_store_vps(request, request, &request->config, 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 != NULL) {
perl_store_vps(request->proxy, request, &request->proxy->vps, rad_request_proxy_hv,
"RAD_REQUEST_PROXY", "proxy-request");
} else {
hv_undef(rad_request_proxy_hv);
}
if (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 xlat works
* We mark it read-only for interpreter so end users will not be
* in posession to change it and crash radiusd with bogus pointer
*/
SvREADONLY_off(rad_requestp_sv);
sv_setiv(rad_requestp_sv, PTR2IV(request));
SvREADONLY_on(rad_requestp_sv);
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)) {
RDEBUG("perl_embed:: module = %s , func = %s exit status= %s\n",
inst->module, function_name, SvPV(ERRSV,n_a));
(void)POPs;
count = 0;
exitstatus = RLM_MODULE_FAIL;
}
if (count == 1) {
exitstatus = POPi;
if (exitstatus >= 100 || exitstatus < 0) {
exitstatus = RLM_MODULE_FAIL;
}
}
PUTBACK;
FREETMPS;
LEAVE;
vp = NULL;
get_hv_content(request->packet, request, rad_request_hv, &vp, "RAD_REQUEST", "request");
if (vp) {
fr_pair_list_free(&request->packet->vps);
request->packet->vps = vp;
vp = NULL;
/*
* Update cached copies
*/
request->username = fr_pair_find_by_num(request->packet->vps, PW_USER_NAME, 0, TAG_ANY);
request->password = fr_pair_find_by_num(request->packet->vps, PW_USER_PASSWORD, 0, TAG_ANY);
if (!request->password)
request->password = fr_pair_find_by_num(request->packet->vps, PW_CHAP_PASSWORD, 0, TAG_ANY);
}
get_hv_content(request->reply, request, rad_reply_hv, &vp, "RAD_REPLY", "reply");
if (vp) {
fr_pair_list_free(&request->reply->vps);
request->reply->vps = vp;
vp = NULL;
}
get_hv_content(request, request, rad_check_hv, &vp, "RAD_CHECK", "control");
if (vp) {
fr_pair_list_free(&request->config);
request->config = vp;
vp = NULL;
}
get_hv_content(request->state_ctx, request, rad_state_hv, &vp, "RAD_STATE", "session-state");
if (vp) {
fr_pair_list_free(&request->state);
request->state = vp;
vp = NULL;
}
#ifdef WITH_PROXY
if (request->proxy) {
get_hv_content(request->proxy, request, rad_request_proxy_hv, &vp,
"RAD_REQUEST_PROXY", "proxy-request");
if (vp) {
fr_pair_list_free(&request->proxy->vps);
request->proxy->vps = vp;
vp = NULL;
}
}
if (request->proxy_reply) {
get_hv_content(request->proxy_reply, request, rad_request_proxy_reply_hv, &vp,
"RAD_REQUEST_PROXY_REPLY", "proxy-reply");
if (vp) {
fr_pair_list_free(&request->proxy_reply->vps);
request->proxy_reply->vps = vp;
vp = NULL;
}
}
#endif
}
return exitstatus;
}
