void CroakOptsHash(char * name, char * value, HV * o)
{
dTHR;
SV * result = sv_newmortal();
HE * he;
int i=0;
sv_catpv(result, "invalid ");
sv_catpv(result, name);
sv_catpv(result, " ");
sv_catpv(result, value);
sv_catpv(result, ", expecting");
hv_iterinit(o);
he = hv_iternext(o);
while(he) {
I32 len;
char * key = hv_iterkey(he, &len);
he = hv_iternext(o);
if (i==0)
sv_catpv(result," '");
else if (he)
sv_catpv(result,"', '");
else
sv_catpv(result,"', or '");
i=1;
sv_catpvn(result, key, len);
}
sv_catpv(result,"'");
croak(SvPV(result, PL_na));
}
void
scan_search_entry_response(const char** src, const char* max, HV *out) {
SV *dn, *key;
STRLEN len;
dn = newSV(0);
hv_stores(out, "dn", dn);
scan_string_utf8(src, max, dn);
scan_sequence(src, max, &len);
if (len != max - *src)
croak("scan_search_entry_response: packet too short");
key = sv_newmortal();
while (*src < max) {
const char *attribute_max;
AV *values;
scan_sequence(src, max, &len);
attribute_max = *src + len;
scan_string_utf8(src, max, key);
values = newAV();
hv_store_ent(out, key, newRV_noinc((SV*)values), 0);
scan_set(src, max, &len);
if (attribute_max != *src + len)
croak("bad packet");
while (*src < attribute_max) {
SV *v = newSV(0);
av_push(values, v);
scan_string_utf8(src, attribute_max, v);
}
}
}
int modperl_require_module(pTHX_ const char *pv, int logfailure)
{
SV *sv;
dSP;
PUSHSTACKi(PERLSI_REQUIRE);
ENTER;SAVETMPS;
PUTBACK;
sv = sv_newmortal();
sv_setpv(sv, "require ");
sv_catpv(sv, pv);
eval_sv(sv, G_DISCARD);
SPAGAIN;
POPSTACK;
FREETMPS;LEAVE;
if (SvTRUE(ERRSV)) {
if (logfailure) {
(void)modperl_errsv(aTHX_ HTTP_INTERNAL_SERVER_ERROR,
NULL, NULL);
}
return FALSE;
}
return TRUE;
}
wchar_t normalize(const wchar_t c) const
{
SV* obj = SvRV(obj_ref);
m.pushArgument(newSVpv("next", 4));
m.call(obj, "can");
SV* ret = m.shiftReturn();
m.finish();
if (SvTRUE(ret)) {
wchar_t *ret1, ret2;
wchar_t ch[2];
ch[0] = c;
ch[1] = 0;
SV* pch = WCharToSv((wchar_t*)ch, sv_newmortal());
m.pushArgument(pch);
m.call(obj, "normalize");
SV* ret = m.shiftReturn();
m.finish();
ret1 = SvToWChar(ret);
ret2 = ret1[0];
Safefree(ret1);
return ret2;
}
else
return CharTokenizer::normalize(c);
}
static void
dl_init(pTHX)
{
char *file = __FILE__;
dTARG;
dSP;
/* Dynamicboot strapping code*/
SAVETMPS;
targ=sv_newmortal();
FREETMPS;
/* end Dynamic bootstrapping code */
}
static
XS(epoc_getcwd) /* more or less stolen from win32.c */
{
dXSARGS;
/* Make the host for current directory */
char *buffer;
int buflen = 256;
char *ptr;
buffer = (char *) malloc( buflen);
if (buffer == NULL) {
XSRETURN_UNDEF;
}
while ((NULL == ( ptr = getcwd( buffer, buflen))) && (errno == ERANGE)) {
buflen *= 2;
if (NULL == realloc( buffer, buflen)) {
XSRETURN_UNDEF;
}
}
/*
* If ptr != Nullch
* then it worked, set PV valid,
* else return 'undef'
*/
if (ptr) {
SV *sv = sv_newmortal();
char *tptr;
for (tptr = ptr; *tptr != '\0'; tptr++) {
if (*tptr == '\\') {
*tptr = '/';
}
}
sv_setpv(sv, ptr);
free( buffer);
EXTEND(SP,1);
SvPOK_on(sv);
ST(0) = sv;
#ifndef INCOMPLETE_TAINTS
SvTAINTED_on(ST(0));
#endif
XSRETURN(1);
}
free( buffer);
XSRETURN_UNDEF;
}
bool isTokenChar(wchar_t c) const
{
SV* obj = SvRV(obj_ref);
wchar_t ch[2];
ch[0] = c;
ch[1] = 0;
SV* pch = WCharToSv((wchar_t*)ch, sv_newmortal());
m.pushArgument(pch);
m.call(obj, "isTokenChar");
SV* ret = m.shiftReturn();
m.finish();
if (SvTRUE(ret))
return true;
return false;
}
static SV *err_to_SV(pTHX_ int err)
{
SV *ret = sv_newmortal();
SvUPGRADE(ret, SVt_PVNV);
if(err) {
const char *error = gai_strerror(err);
sv_setpv(ret, error);
}
else {
sv_setpv(ret, "");
}
SvIV_set(ret, err); SvIOK_on(ret);
return ret;
}
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));
}
bool next(Token* token)
{
SV* obj = SvRV(obj_ref);
m.pushArgument(newSVpv("next", 4));
m.call(obj, "can");
SV* ret = m.shiftReturn();
m.finish();
if (SvTRUE(ret)) {
SV* perl_token = PtrToSv("Lucene::Analysis::Token", (void*)token, sv_newmortal());
m.pushArgument(perl_token);
m.call(obj, "next");
SV* ret = m.shiftReturn();
m.finish();
if (SvTRUE(ret))
return true;
return false;
}
else
return CharTokenizer::next(token);
}
MP_INLINE static void
modperl_io_perlio_override_stdhandle(pTHX_ request_rec *r, int mode)
{
dHANDLE(mode == O_RDONLY ? "STDIN" : "STDOUT");
int status;
SV *sv = sv_newmortal();
MP_TRACE_o(MP_FUNC, "start STD%s", mode == O_RDONLY ? "IN" : "OUT");
save_gp(handle, 1);
sv_setref_pv(sv, "Apache2::RequestRec", (void*)r);
status = do_open9(handle, mode == O_RDONLY ? "<:Apache2" : ">:Apache2",
9, FALSE, mode, 0, (PerlIO *)NULL, sv, 1);
if (status == 0) {
Perl_croak(aTHX_ "Failed to open STD%s: %" SVf,
mode == O_RDONLY ? "IN" : "OUT", get_sv("!", TRUE));
}
MP_TRACE_o(MP_FUNC, "end STD%s", mode==O_RDONLY ? "IN" : "OUT");
}
long SvEFValueLookup (GtkEnumValue * vals, char* name, GtkType type) {
GtkEnumValue *v;
dTHR;
if (!name)
croak("Need a value in lookup");
if (*name == '-')
name++;
v = vals;
while (v && v->value_nick) {
if (hystrEQ(name, v->value_nick))
return v->value;
v++;
}
{
SV * r;
char * endc=NULL;
long val;
/* last chanche: integer value... */
val = strtol(name, &endc, 0);
if (*name && endc && *endc == '\0')
return val;
v = vals;
r = sv_newmortal();
sv_catpv(r, "invalid ");
sv_catpv(r, gtk_type_name(type));
sv_catpv(r, " value ");
sv_catpv(r, name);
sv_catpv(r, ", expecting: ");
while (v && v->value_nick) {
sv_catpv(r, v->value_nick);
if (++v)
sv_catpv(r, ", ");
}
croak(SvPV(r, PL_na));
return 0;
}
}
/* yanked from perl.c */
static void
xs_init(pTHX)
{
char *file = __FILE__;
dTARG;
dSP;
#ifdef USE_DYNAMIC_LOADING
newXS("DynaLoader::boot_DynaLoader", boot_DynaLoader, file);
#endif
/* bootstrapping code*/
SAVETMPS;
targ=sv_newmortal();
#ifdef USE_DYNAMIC_LOADING
PUSHMARK(sp);
XPUSHp("DynaLoader",strlen("DynaLoader"));
PUTBACK;
boot_DynaLoader(aTHX_ NULL);
SPAGAIN;
#endif
FREETMPS;
/* end bootstrapping code */
}
void CroakOpts(char * name, char * value, struct opts * o)
{
dTHR;
SV * result = sv_newmortal();
int i;
sv_catpv(result, "invalid ");
sv_catpv(result, name);
sv_catpv(result, " ");
sv_catpv(result, value);
sv_catpv(result, ", expecting");
for(i=0;o[i].name;i++) {
if (i==0)
sv_catpv(result," '");
else if (o[i+1].name)
sv_catpv(result,"', '");
else
sv_catpv(result,"', or '");
sv_catpv(result, o[i].name);
}
sv_catpv(result,"'");
croak(SvPV(result, PL_na));
}
JSBool PJS_invoke_perl_property_getter(JSContext *cx, JSObject *obj, jsval id, jsval *vp) {
dSP;
PJS_Context *pcx;
PJS_Class *pcls;
PJS_Property *pprop;
SV *caller;
char *name;
jsint slot;
U8 invocation_mode;
if (!(JSVAL_IS_INT(id) || JSVAL_IS_STRING(id))) {
return JS_TRUE;
}
if((pcx = PJS_GET_CONTEXT(cx)) == NULL) {
JS_ReportError(cx, "Can't find context %d", cx);
return JS_FALSE;
}
if (JS_TypeOfValue(cx, OBJECT_TO_JSVAL(obj)) == JSTYPE_OBJECT) {
/* Called as instsance */
JSClass *clasp = PJS_GET_CLASS(cx, obj);
name = (char *) clasp->name;
invocation_mode = 1;
}
else {
/* Called as static */
JSFunction *parent_jfunc = JS_ValueToFunction(cx, OBJECT_TO_JSVAL(obj));
if (parent_jfunc == NULL) {
JS_ReportError(cx, "Failed to extract class for static property getter");
return JS_FALSE;
}
name = (char *) JS_GetFunctionName(parent_jfunc);
invocation_mode = 0;
}
if ((pcls = PJS_GetClassByName(pcx, name)) == NULL) {
JS_ReportError(cx, "Can't find class '%s'", name);
return JS_FALSE;
}
if (invocation_mode) {
caller = (SV *) JS_GetPrivate(cx, obj);
}
else {
caller = newSVpv(pcls->pkg, 0);
}
if (JSVAL_IS_INT(id)) {
slot = JSVAL_TO_INT(id);
if ((pprop = PJS_get_property_by_id(pcls, (int8) slot)) == NULL) {
if (SvTRUE(pcls->property_getter)) {
if (perl_call_sv_with_jsvals(cx, obj, pcls->property_getter, caller, 1, &id, vp) < 0) {
return JS_FALSE;
}
return JS_TRUE;
}
JS_ReportError(cx, "Can't find property handler");
return JS_FALSE;
}
if (pprop->getter == NULL) {
JS_ReportError(cx, "Property is write-only");
return JS_FALSE;
}
if (perl_call_sv_with_jsvals(cx, obj, pprop->getter, caller, 0, NULL, vp) < 0) {
return JS_FALSE;
}
}
else if (JSVAL_IS_STRING(id) && SvTRUE(pcls->property_getter)) {
SV *sv = sv_newmortal();
#ifdef JS_C_STRINGS_ARE_UTF8
char *tmp = JS_smprintf("%hs", JS_GetStringChars(JSVAL_TO_STRING(id)));
sv_setpv(sv, tmp);
SvUTF8_on(sv);
free(tmp);
#else
sv_setpv(sv, JS_GetStringBytes(JSVAL_TO_STRING(id)));
#endif
if (PJS_get_method_by_name(pcls, SvPV_nolen(sv))) {
return JS_TRUE;
}
if (perl_call_sv_with_jsvals(cx, obj, pcls->property_getter, caller, 1, &id, vp) < 0) {
return JS_FALSE;
}
}
return JS_TRUE;
}
void
LUCY_RegexTokenizer_Tokenize_Utf8_IMP(lucy_RegexTokenizer *self,
const char *string, size_t string_len,
lucy_Inversion *inversion) {
dTHX;
lucy_RegexTokenizerIVARS *const ivars = lucy_RegexTokenizer_IVARS(self);
uint32_t num_code_points = 0;
SV *wrapper = sv_newmortal();
#if (PERL_VERSION > 10)
REGEXP *rx = (REGEXP*)ivars->token_re;
regexp *rx_struct = (regexp*)SvANY(rx);
#else
REGEXP *rx = (REGEXP*)ivars->token_re;
regexp *rx_struct = rx;
#endif
char *string_beg = (char*)string;
char *string_end = string_beg + string_len;
char *string_arg = string_beg;
// Fake up an SV wrapper to feed to the regex engine.
sv_upgrade(wrapper, SVt_PV);
SvREADONLY_on(wrapper);
SvLEN(wrapper) = 0;
SvUTF8_on(wrapper);
// Wrap the string in an SV to please the regex engine.
SvPVX(wrapper) = string_beg;
SvCUR_set(wrapper, string_len);
SvPOK_on(wrapper);
while (pregexec(rx, string_arg, string_end, string_arg, 1, wrapper, 1)) {
#if ((PERL_VERSION >= 10) || (PERL_VERSION == 9 && PERL_SUBVERSION >= 5))
char *const start_ptr = string_arg + rx_struct->offs[0].start;
char *const end_ptr = string_arg + rx_struct->offs[0].end;
#else
char *const start_ptr = string_arg + rx_struct->startp[0];
char *const end_ptr = string_arg + rx_struct->endp[0];
#endif
uint32_t start, end;
// Get start and end offsets in Unicode code points.
for (; string_arg < start_ptr; num_code_points++) {
string_arg += cfish_StrHelp_UTF8_COUNT[(uint8_t)(*string_arg)];
if (string_arg > string_end) {
THROW(CFISH_ERR, "scanned past end of '%s'", string_beg);
}
}
start = num_code_points;
for (; string_arg < end_ptr; num_code_points++) {
string_arg += cfish_StrHelp_UTF8_COUNT[(uint8_t)(*string_arg)];
if (string_arg > string_end) {
THROW(CFISH_ERR, "scanned past end of '%s'", string_beg);
}
}
end = num_code_points;
// Add a token to the new inversion.
LUCY_Inversion_Append(inversion,
lucy_Token_new(
start_ptr,
(end_ptr - start_ptr),
start,
end,
1.0f, // boost always 1 for now
1 // position increment
)
);
}
}
/*
* Run function, with current SIP message as a parameter
*/
int perl_exec(struct sip_msg* _msg, str* _fnc_s, str* mystr)
{
int retval;
SV *m;
str reason;
str pfnc, pparam;
char *fnc;
fnc = pkg_malloc(_fnc_s->len);
if (!fnc) {
LM_ERR("No more pkg mem!\n");
return -1;
}
memcpy(fnc, _fnc_s->s, _fnc_s->len);
fnc[_fnc_s->len] = 0;
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");
}
goto error;
}
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");
}
goto error;
}
break;
case SIP_REPLY:
break;
default:
LM_ERR("invalid firstline\n");
goto error;
}
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->s, mystr->len)));
/* 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;
error:
pkg_free(fnc);
return -1;
}
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 );
}
int perl_exec2(struct sip_msg* _msg, char* fnc, char* mystr) {
int retval;
SV *m;
str reason;
app_perl_reset_interpreter();
dSP;
if (!perl_checkfnc(fnc)) {
LM_ERR("unknown perl function called.\n");
reason.s = "Internal error";
reason.len = sizeof("Internal error")-1;
if (slb.freply(_msg, 500, &reason) == -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 (slb.freply(_msg, 400, &reason) == -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();
sv_setref_pv(m, "Kamailio::Message", (void *)_msg);
SvREADONLY_on(SvRV(m));
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;
}
SV *single_hook_call(pTHX_ SV *self, const char *hook_id_str, const char *id_pre,
const char *id, const SingleHook *hook, SV *in, int mortal)
{
dSP;
int count;
SV *out;
CT_DEBUG(MAIN, ("single_hook_call(hid='%s', id='%s%s', hook=%p, in=%p(%d), mortal=%d)",
hook_id_str, id_pre, id, hook, in, in ? (int) SvREFCNT(in) : 0, mortal));
assert(self != NULL);
assert(hook != NULL);
if (hook->sub == NULL)
return in;
ENTER;
SAVETMPS;
PUSHMARK(SP);
if (hook->arg)
{
I32 ix, len;
len = av_len(hook->arg);
for (ix = 0; ix <= len; ++ix)
{
SV **pSV = av_fetch(hook->arg, ix, 0);
SV *sv;
if (pSV == NULL)
fatal("NULL returned by av_fetch() in single_hook_call()");
if (SvROK(*pSV) && sv_isa(*pSV, ARGTYPE_PACKAGE))
{
HookArgType type = (HookArgType) SvIV(SvRV(*pSV));
switch (type)
{
case HOOK_ARG_SELF:
sv = sv_mortalcopy(self);
break;
case HOOK_ARG_DATA:
assert(in != NULL);
sv = sv_mortalcopy(in);
break;
case HOOK_ARG_TYPE:
assert(id != NULL);
sv = sv_newmortal();
if (id_pre)
{
sv_setpv(sv, id_pre);
sv_catpv(sv, CONST_CHAR(id));
}
else
sv_setpv(sv, id);
break;
case HOOK_ARG_HOOK:
if (hook_id_str)
{
sv = sv_newmortal();
sv_setpv(sv, hook_id_str);
}
else
{
sv = &PL_sv_undef;
}
break;
default:
fatal("Invalid hook argument type (%d) in single_hook_call()", type);
break;
}
}
else
sv = sv_mortalcopy(*pSV);
XPUSHs(sv);
}
}
else
{
if (in)
{
/* only push the data argument */
XPUSHs(in);
}
}
PUTBACK;
count = call_sv(hook->sub, G_SCALAR);
SPAGAIN;
if (count != 1)
fatal("Hook returned %d elements instead of 1", count);
out = POPs;
CT_DEBUG(MAIN, ("single_hook_call: in=%p(%d), out=%p(%d)",
in, in ? (int) SvREFCNT(in) : 0, out, (int) SvREFCNT(out)));
if (!mortal && in != NULL)
SvREFCNT_dec(in);
SvREFCNT_inc(out);
PUTBACK;
FREETMPS;
LEAVE;
if (mortal)
sv_2mortal(out);
CT_DEBUG(MAIN, ("single_hook_call: out=%p(%d)", out, (int) SvREFCNT(out)));
return out;
}
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;
}
IV
PerlIOEncode_flush(pTHX_ PerlIO * f)
{
PerlIOEncode *e = PerlIOSelf(f, PerlIOEncode);
IV code = 0;
if (e->bufsv) {
dSP;
SV *str;
char *s;
STRLEN len;
SSize_t count = 0;
if ((PerlIOBase(f)->flags & PERLIO_F_WRBUF) && (e->base.ptr > e->base.buf)) {
if (e->inEncodeCall) return 0;
/* Write case - encode the buffer and write() to layer below */
PUSHSTACKi(PERLSI_MAGIC);
SPAGAIN;
ENTER;
SAVETMPS;
PUSHMARK(sp);
XPUSHs(e->enc);
SvCUR_set(e->bufsv, e->base.ptr - e->base.buf);
SvUTF8_on(e->bufsv);
XPUSHs(e->bufsv);
XPUSHs(e->chk);
PUTBACK;
e->inEncodeCall = 1;
if (call_method("encode", G_SCALAR) != 1) {
e->inEncodeCall = 0;
Perl_die(aTHX_ "panic: encode did not return a value");
}
e->inEncodeCall = 0;
SPAGAIN;
str = POPs;
PUTBACK;
s = SvPV(str, len);
count = PerlIO_write(PerlIONext(f),s,len);
if ((STRLEN)count != len) {
code = -1;
}
FREETMPS;
LEAVE;
POPSTACK;
if (PerlIO_flush(PerlIONext(f)) != 0) {
code = -1;
}
if (SvCUR(e->bufsv)) {
/* Did not all translate */
e->base.ptr = e->base.buf+SvCUR(e->bufsv);
return code;
}
}
else if ((PerlIOBase(f)->flags & PERLIO_F_RDBUF)) {
/* read case */
/* if we have any untranslated stuff then unread that first */
/* FIXME - unread is fragile is there a better way ? */
if (e->dataSV && SvCUR(e->dataSV)) {
s = SvPV(e->dataSV, len);
count = PerlIO_unread(PerlIONext(f),s,len);
if ((STRLEN)count != len) {
code = -1;
}
SvCUR_set(e->dataSV,0);
}
/* See if there is anything left in the buffer */
if (e->base.ptr < e->base.end) {
if (e->inEncodeCall) return 0;
/* Bother - have unread data.
re-encode and unread() to layer below
*/
PUSHSTACKi(PERLSI_MAGIC);
SPAGAIN;
ENTER;
SAVETMPS;
str = sv_newmortal();
sv_upgrade(str, SVt_PV);
SvPV_set(str, (char*)e->base.ptr);
SvLEN_set(str, 0);
SvCUR_set(str, e->base.end - e->base.ptr);
SvPOK_only(str);
SvUTF8_on(str);
PUSHMARK(sp);
XPUSHs(e->enc);
XPUSHs(str);
XPUSHs(e->chk);
PUTBACK;
e->inEncodeCall = 1;
if (call_method("encode", G_SCALAR) != 1) {
e->inEncodeCall = 0;
Perl_die(aTHX_ "panic: encode did not return a value");
}
e->inEncodeCall = 0;
SPAGAIN;
str = POPs;
PUTBACK;
s = SvPV(str, len);
count = PerlIO_unread(PerlIONext(f),s,len);
if ((STRLEN)count != len) {
code = -1;
}
FREETMPS;
LEAVE;
POPSTACK;
}
}
e->base.ptr = e->base.end = e->base.buf;
PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF | PERLIO_F_WRBUF);
}
return code;
}
