/* helper to return the stash for a svref, (Sv|Cv|Gv|GvE)STASH */
static HV*
S_guess_stash(pTHX_ SV* sv)
{
if (SvOBJECT(sv)) {
return SvSTASH(sv);
}
else {
HV *stash = NULL;
switch (SvTYPE(sv)) {
case SVt_PVCV:
if (CvGV(sv) && isGV(CvGV(sv)) && GvSTASH(CvGV(sv)))
return GvSTASH(CvGV(sv));
else if (/* !CvANON(sv) && */ CvSTASH(sv))
return CvSTASH(sv);
break;
case SVt_PVGV:
if (isGV_with_GP(sv) && GvGP(sv) && GvESTASH(MUTABLE_GV(sv)))
return GvESTASH(MUTABLE_GV(sv));
break;
default:
break;
}
return stash;
}
}
int
mop_get_code_info (SV *coderef, char **pkg, char **name)
{
if (!SvOK(coderef) || !SvROK(coderef) || SvTYPE(SvRV(coderef)) != SVt_PVCV) {
return 0;
}
coderef = SvRV(coderef);
/* sub is still being compiled */
if (!CvGV(coderef)) {
return 0;
}
/* I think this only gets triggered with a mangled coderef, but if
we hit it without the guard, we segfault. The slightly odd return
value strikes me as an improvement (mst)
*/
if ( isGV_with_GP(CvGV(coderef)) ) {
GV *gv = CvGV(coderef);
*pkg = HvNAME( GvSTASH(gv) ? GvSTASH(gv) : CvSTASH(coderef) );
*name = GvNAME( CvGV(coderef) );
} else {
*pkg = "__UNKNOWN__";
*name = "__ANON__";
}
return 1;
}
void unroll_this(pTHX_ OP* op) {
struct sljit_compiler* compiler = sljit_create_compiler();
HV* seenops = newHV();
#ifdef DEBUG
if (getenv("RUNOPS_OPTIMIZED_DEBUG")) {
CV *runcv = Perl_find_runcv(NULL);
sljit_compiler_verbose(compiler, stderr);
DEBUGf(("Unroll %s::%s cv=%p, op=%p (%s)\n", HvNAME_get(CvSTASH(runcv)),
GvENAME(CvGV(runcv)), runcv, op, sljit_get_platform_name()));
}
#endif
sljit_emit_enter(compiler, 0, 2, 1, 0);
unroll_tree(compiler, seenops, op, NULL);
fixup_jumps(compiler, needjumps, labels);
// This is needed for things that drop off the runloop without a
// return, e.g. S_sortcv. TODO: Make conditional?
sljit_emit_return(compiler, SLJIT_MEM, (sljit_w) &PL_op);
op->op_ppaddr = sljit_generate_code(compiler);
op->op_spare = 3;
DEBUGf(("Code at %p\n", op->op_ppaddr));
labels = NULL;
needjumps = NULL;
SvREFCNT_dec(seenops);
sljit_free_compiler(compiler);
}
void
Perl_gv_init(pTHX_ GV *gv, HV *stash, const char *name, STRLEN len, int multi)
{
register GP *gp;
bool doproto = SvTYPE(gv) > SVt_NULL;
char *proto = (doproto && SvPOK(gv)) ? SvPVX(gv) : NULL;
sv_upgrade((SV*)gv, SVt_PVGV);
if (SvLEN(gv)) {
if (proto) {
SvPVX(gv) = NULL;
SvLEN(gv) = 0;
SvPOK_off(gv);
} else
Safefree(SvPVX(gv));
}
Newz(602, gp, 1, GP);
GvGP(gv) = gp_ref(gp);
GvSV(gv) = NEWSV(72,0);
GvLINE(gv) = CopLINE(PL_curcop);
GvFILE(gv) = CopFILE(PL_curcop) ? CopFILE(PL_curcop) : "";
GvCVGEN(gv) = 0;
GvEGV(gv) = gv;
sv_magic((SV*)gv, (SV*)gv, '*', Nullch, 0);
GvSTASH(gv) = (HV*)SvREFCNT_inc(stash);
GvNAME(gv) = savepvn(name, len);
GvNAMELEN(gv) = len;
if (multi || doproto) /* doproto means it _was_ mentioned */
GvMULTI_on(gv);
if (doproto) { /* Replicate part of newSUB here. */
SvIOK_off(gv);
ENTER;
/* XXX unsafe for threads if eval_owner isn't held */
start_subparse(0,0); /* Create CV in compcv. */
GvCV(gv) = PL_compcv;
LEAVE;
PL_sub_generation++;
CvGV(GvCV(gv)) = gv;
CvFILE(GvCV(gv)) = CopFILE(PL_curcop);
CvSTASH(GvCV(gv)) = PL_curstash;
#ifdef USE_THREADS
CvOWNER(GvCV(gv)) = 0;
if (!CvMUTEXP(GvCV(gv))) {
New(666, CvMUTEXP(GvCV(gv)), 1, perl_mutex);
MUTEX_INIT(CvMUTEXP(GvCV(gv)));
}
#endif /* USE_THREADS */
if (proto) {
sv_setpv((SV*)GvCV(gv), proto);
Safefree(proto);
}
}
}
SV* THX_newMopMmV(pTHX_ SV* code, U32 flags) {
SV* method;
CV* cv = (CV*) newSV(0);
sv_upgrade((SV*) cv, SVt_PVCV);
CvISXSUB_on(cv);
CvXSUB(cv) = _MopMmV_wrapper;
CvXSUBANY(cv).any_uv = PTR2UV(code);
CvFILE(cv) = __FILE__;
CvANON_off(cv);
CvMETHOD_on(cv);
SvREFCNT_inc(code);
method = newMopOV(newRV_inc((SV*) cv));
if (flags & MopMmVf_STEAL_STASH) {
MopMmV_assign_to_stash(method, CvGV(SvRV(code)), CvSTASH(SvRV(code)));
}
return method;
}
GV*
Perl_gv_autoload4(pTHX_ HV *stash, const char *name, STRLEN len, I32 method)
{
char autoload[] = "AUTOLOAD";
STRLEN autolen = sizeof(autoload)-1;
GV* gv;
CV* cv;
HV* varstash;
GV* vargv;
SV* varsv;
char *packname = "";
if (len == autolen && strnEQ(name, autoload, autolen))
return Nullgv;
if (stash) {
if (SvTYPE(stash) < SVt_PVHV) {
packname = SvPV_nolen((SV*)stash);
stash = Nullhv;
}
else {
packname = HvNAME(stash);
}
}
if (!(gv = gv_fetchmeth(stash, autoload, autolen, FALSE)))
return Nullgv;
cv = GvCV(gv);
if (!(CvROOT(cv) || CvXSUB(cv)))
return Nullgv;
/*
* Inheriting AUTOLOAD for non-methods works ... for now.
*/
if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX) && !method &&
(GvCVGEN(gv) || GvSTASH(gv) != stash))
Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
"Use of inherited AUTOLOAD for non-method %s::%.*s() is deprecated",
packname, (int)len, name);
if (CvXSUB(cv)) {
/* rather than lookup/init $AUTOLOAD here
* only to have the XSUB do another lookup for $AUTOLOAD
* and split that value on the last '::',
* pass along the same data via some unused fields in the CV
*/
CvSTASH(cv) = stash;
SvPVX(cv) = (char *)name; /* cast to lose constness warning */
SvCUR(cv) = len;
return gv;
}
/*
* Given &FOO::AUTOLOAD, set $FOO::AUTOLOAD to desired function name.
* The subroutine's original name may not be "AUTOLOAD", so we don't
* use that, but for lack of anything better we will use the sub's
* original package to look up $AUTOLOAD.
*/
varstash = GvSTASH(CvGV(cv));
vargv = *(GV**)hv_fetch(varstash, autoload, autolen, TRUE);
ENTER;
if (!isGV(vargv))
gv_init(vargv, varstash, autoload, autolen, FALSE);
LEAVE;
varsv = GvSV(vargv);
sv_setpv(varsv, packname);
sv_catpvn(varsv, "::", 2);
sv_catpvn(varsv, name, len);
SvTAINTED_off(varsv);
return gv;
}
static GPtrArray *
do_marshal (CV *cv, I32 ax, I32 items,
CORBA_InterfaceDef_FullInterfaceDescription *desc, I32 index,
CORBA_Object obj, GIOPConnection *connection, GIOP_unsigned_long request_id)
{
OpNameData *operation_name_data;
static struct iovec operation_vec;
char *name = NULL;
GIOPSendBuffer *send_buffer = NULL;
SV *error_sv = NULL;
GPtrArray *return_types = NULL;
dTHR;
/* Determine the operation name used over GIOP
*/
if (index >= PORBIT_OPERATION_BASE && index < PORBIT_GETTER_BASE) {
name = g_strdup (desc->operations._buffer[index-PORBIT_OPERATION_BASE].name);
} else if (index >= PORBIT_GETTER_BASE && index < PORBIT_SETTER_BASE) {
name = g_strconcat ("_get_", desc->attributes._buffer[index-PORBIT_GETTER_BASE].name, NULL);
} else if (index >= PORBIT_SETTER_BASE) {
name = g_strconcat ("_set_", desc->attributes._buffer[index-PORBIT_SETTER_BASE].name, NULL);
}
/* Create a SendBuffer for the result
*/
operation_name_data = (OpNameData *)g_malloc (sizeof (OpNameData) + strlen(name));
operation_name_data->len = strlen(name) + 1;
strcpy (operation_name_data->opname, name);
operation_vec.iov_base = operation_name_data;
operation_vec.iov_len = sizeof(CORBA_unsigned_long) + operation_name_data->len;
send_buffer =
giop_send_request_buffer_use(connection, NULL, request_id,
!IS_ONEWAY(desc,index),
&(obj->active_profile->object_key_vec),
&operation_vec, &ORBit_default_principal_iovec);
if (!send_buffer) {
error_sv =
porbit_system_except ("IDL:omg.org/CORBA/COMM_FAILURE:1.0",
0, CORBA_COMPLETED_NO);
goto exception;
}
/* Do the marshalling. We accumulate the return types into an array for
* use while demarshalling.
*/
return_types = g_ptr_array_new();
if (index >= PORBIT_OPERATION_BASE && index < PORBIT_GETTER_BASE) {
CORBA_OperationDescription *opr = &desc->operations._buffer[index-PORBIT_OPERATION_BASE];
CORBA_unsigned_long i, st_index;
if (opr->result->kind != CORBA_tk_void)
g_ptr_array_add (return_types, opr->result);
st_index = 1;
for (i = 0 ; i<opr->parameters._length; i++) {
SV *arg = (st_index<(CORBA_unsigned_long)items) ? ST(st_index) : &PL_sv_undef;
switch (opr->parameters._buffer[i].mode) {
case CORBA_PARAM_IN:
if (!porbit_put_sv (send_buffer, opr->parameters._buffer[i].type, arg)) {
warn ("Error marshalling parameter '%s'",
opr->parameters._buffer[i].name);
error_sv =
porbit_system_except ("IDL:omg.org/CORBA/MARSHAL:1.0",
0, CORBA_COMPLETED_NO);
goto exception;
}
st_index++;
break;
case CORBA_PARAM_INOUT:
if (!SvROK(arg) ||
!porbit_put_sv (send_buffer, opr->parameters._buffer[i].type, SvRV (arg))) {
if (!SvROK (arg))
warn ("INOUT parameter must be a reference");
else
warn ("Error marshalling parameter '%s'", opr->parameters._buffer[i].name);
error_sv =
porbit_system_except ("IDL:omg.org/CORBA/MARSHAL:1.0",
0, CORBA_COMPLETED_NO);
goto exception;
}
st_index++;
/* Fall through */
case CORBA_PARAM_OUT:
g_ptr_array_add (return_types, opr->parameters._buffer[i].type);
break;
}
}
} else if (index >= PORBIT_GETTER_BASE && index < PORBIT_SETTER_BASE) {
g_ptr_array_add (return_types, desc->attributes._buffer[index-PORBIT_GETTER_BASE].type);
} else if (index >= PORBIT_SETTER_BASE) {
if (items < 2) {
warn("%s::%s called without second argument", HvNAME(CvSTASH(cv)), name);
error_sv =
porbit_system_except ("IDL:omg.org/CORBA/MARSHAL:1.0",
0, CORBA_COMPLETED_NO);
goto exception;
}
if (!porbit_put_sv (send_buffer,
desc->attributes._buffer[index-PORBIT_SETTER_BASE].type,
ST(1))) {
warn ("Error marshalling attribute value");
error_sv =
porbit_system_except ("IDL:omg.org/CORBA/MARSHAL:1.0",
0, CORBA_COMPLETED_NO);
goto exception;
}
}
/* Invoke the operation
*/
giop_send_buffer_write(send_buffer);
exception:
giop_send_buffer_unuse(send_buffer);
g_free (operation_name_data);
g_free (name);
if (error_sv) {
if (return_types)
g_ptr_array_free (return_types, TRUE);
porbit_throw (error_sv);
}
return return_types;
}
SV* THX_MopMmV_get_associated_class(pTHX_ SV* metamethod) {
return newRV_noinc((SV*) CvSTASH(SvRV(metamethod)));
}