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; }