int
Perl_runops_debug(pTHX)
{
#ifdef DEBUGGING
if (!PL_op) {
if (ckWARN_d(WARN_DEBUGGING))
Perl_warner(aTHX_ WARN_DEBUGGING, "NULL OP IN RUN");
return 0;
}
do {
PERL_ASYNC_CHECK();
if (PL_debug) {
if (PL_watchaddr != 0 && *PL_watchaddr != PL_watchok)
PerlIO_printf(Perl_debug_log,
"WARNING: %"UVxf" changed from %"UVxf" to %"UVxf"\n",
PTR2UV(PL_watchaddr), PTR2UV(PL_watchok),
PTR2UV(*PL_watchaddr));
DEBUG_s(debstack());
DEBUG_t(debop(PL_op));
DEBUG_P(debprof(PL_op));
}
} while ((PL_op = CALL_FPTR(PL_op->op_ppaddr)(aTHX)));
TAINT_NOT;
return 0;
#else
return runops_standard();
#endif /* DEBUGGING */
}
void
Perl_watch(pTHX_ char **addr)
{
#ifdef DEBUGGING
PL_watchaddr = addr;
PL_watchok = *addr;
PerlIO_printf(Perl_debug_log, "WATCHING, %"UVxf" is currently %"UVxf"\n",
PTR2UV(PL_watchaddr), PTR2UV(PL_watchok));
#endif /* DEBUGGING */
}
SV *
PLCB__viewhandle_new(PLCB_t *parent,
const char *ddoc, const char *view, const char *options, int flags)
{
AV *req = NULL;
SV *blessed;
lcb_CMDVIEWQUERY cmd = { 0 };
lcb_VIEWHANDLE vh = NULL;
lcb_error_t rc;
req = newAV();
rowreq_init_common(parent, req);
blessed = newRV_noinc((SV*)req);
sv_bless(blessed, parent->view_stash);
lcb_view_query_initcmd(&cmd, ddoc, view, options, viewrow_callback);
cmd.cmdflags = flags; /* Trust lcb on this */
cmd.handle = &vh;
rc = lcb_view_query(parent->instance, req, &cmd);
if (rc != LCB_SUCCESS) {
SvREFCNT_dec(blessed);
die("Couldn't issue view query: (0x%x): %s", rc, lcb_strerror(NULL, rc));
} else {
SvREFCNT_inc(req); /* For the callback */
av_store(req, PLCB_VHIDX_VHANDLE, newSVuv(PTR2UV(vh)));
}
return blessed;
}
static int eca_mg_dup(pTHX_ MAGIC *mg, CLONE_PARAMS *param) {
SV *sv = mg->mg_obj;
ECAslot *dup = eca_dup(sv2slot(sv));
sv_setuv(sv, PTR2UV(dup));
PERL_UNUSED_VAR(param);
return 0;
}
static SV *eca_new_sv(char *name, ECAtype type, SV *value, SV *check,
bool is_ro, SV *inject) {
dTHX;
ECAslot *slot = eca_init(name, type, value, check, is_ro, inject);
SV *result_sv = newSVuv(PTR2UV(slot));
MAGIC *mg =
sv_magicext(result_sv, result_sv, PERL_MAGIC_ext, &ECA_TBL, NULL, 0);
mg->mg_flags |= MGf_DUP; // to invoke attrs_dup
return result_sv;
}
void
Perl_mro_register(pTHX_ const struct mro_alg *mro) {
SV *wrapper = newSVuv(PTR2UV(mro));
PERL_ARGS_ASSERT_MRO_REGISTER;
if (!Perl_hv_common(aTHX_ PL_registered_mros, NULL,
mro->name, mro->length, mro->kflags,
HV_FETCH_ISSTORE, wrapper, mro->hash)) {
SvREFCNT_dec(wrapper);
Perl_croak(aTHX_ "panic: hv_store() failed in mro_register() "
"for '%.*s' %d", (int) mro->length, mro->name, mro->kflags);
}
}
LISTOP *
pj_prepare_jit_op(pTHX_ const unsigned int nvariables, OP *origop)
{
LISTOP *jitop;
pj_jitop_aux_t *jit_aux;
NewOp(1101, jitop, 1, LISTOP);
jitop->op_type = (OPCODE)OP_CUSTOM;
jitop->op_next = jitop;
jitop->op_private = 0;
jitop->op_flags = (nvariables > 0 ? (OPf_STACKED|OPf_KIDS) : 0);
if (origop->op_private & OPpTARGET_MY) {
/* If OPpTARGET_MY is set on the original OP, then we have a nasty situation.
* In a nutshell, this is set as an optimization for scalar assignment
* to a pad (== lexical) variable. If set, the addop will directly
* assign to whichever pad variable would otherwise be set by the sassign
* op. It won't bother putting a separate var on the stack.
* This is great, but it uses the op_targ member of the OP struct to
* define the offset into the pad where the output variable is to be found.
* That's a problem because we're using op_targ to hang the jit aux struct
* off of.
*/
jitop->op_private |= OPpTARGET_MY;
}
/* Set it's implementation ptr */
jitop->op_ppaddr = pj_pp_jit;
/* Init jit_aux */
jit_aux = malloc(sizeof(pj_jitop_aux_t));
jit_aux->paramslist = (NV *)malloc(sizeof(NV) * nvariables);
jit_aux->nparams = nvariables;
jit_aux->jit_fun = NULL;
jit_aux->saved_op_targ = origop->op_targ; /* save in case needed for sassign optimization */
/* FIXME is copying op_targ good enough? */
/* It may turn out that op_targ is not safe to use for custom OPs because
* some core functions may meddle with it. But chances are it's fine.
* If not, we'll need to become extra-creative... */
jitop->op_targ = (PADOFFSET)PTR2UV(jit_aux);
return jitop;
}
I32
Perl_debstackptrs(pTHX)
{
#ifdef DEBUGGING
dVAR;
PerlIO_printf(Perl_debug_log,
"%8"UVxf" %8"UVxf" %8"IVdf" %8"IVdf" %8"IVdf"\n",
PTR2UV(PL_curstack), PTR2UV(PL_stack_base),
(IV)*PL_markstack_ptr, (IV)(PL_stack_sp-PL_stack_base),
(IV)(PL_stack_max-PL_stack_base));
PerlIO_printf(Perl_debug_log,
"%8"UVxf" %8"UVxf" %8"UVuf" %8"UVuf" %8"UVuf"\n",
PTR2UV(PL_mainstack), PTR2UV(AvARRAY(PL_curstack)),
PTR2UV(PL_mainstack), PTR2UV(AvFILLp(PL_curstack)),
PTR2UV(AvMAX(PL_curstack)));
#endif /* DEBUGGING */
return 0;
}
STATIC void
S_croak_xs_usage(pTHX_ const CV *const cv, const char *const params)
{
const GV *const gv = CvGV(cv);
PERL_ARGS_ASSERT_CROAK_XS_USAGE;
if (gv) {
const char *const gvname = GvNAME(gv);
const HV *const stash = GvSTASH(gv);
const char *const hvname = stash ? HvNAME(stash) : NULL;
if (hvname)
Perl_croak(aTHX_ "Usage: %s::%s(%s)", hvname, gvname, params);
else
Perl_croak(aTHX_ "Usage: %s(%s)", gvname, params);
} else {
/* Pants. I don't think that it should be possible to get here. */
Perl_croak(aTHX_ "Usage: CODE(0x%"UVxf")(%s)", PTR2UV(cv), params);
}
}
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;
}
void c_test (int max){
int i;
for (f=1)
}
#line 23 "ko_6_1_0_perllint_01cc.c"
#ifndef PERL_UNUSED_VAR
# define PERL_UNUSED_VAR(var) if (0) var = var
#endif
#ifndef PERL_ARGS_ASSERT_CROAK_XS_USAGE
#define PERL_ARGS_ASSERT_CROAK_XS_USAGE assert(cv); assert(params)
/* prototype to pass -Wmissing-prototypes */
STATIC void
S_croak_xs_usage(pTHX_ const CV *const cv, const char *const params);
STATIC void
S_croak_xs_usage(pTHX_ const CV *const cv, const char *const params)
{
const GV *const gv = CvGV(cv);
PERL_ARGS_ASSERT_CROAK_XS_USAGE;
if (gv) {
const char *const gvname = GvNAME(gv);
const HV *const stash = GvSTASH(gv);
const char *const hvname = stash ? HvNAME(stash) : NULL;
if (hvname)
Perl_croak(aTHX_ "Usage: %s::%s(%s)", hvname, gvname, params);
else
Perl_croak(aTHX_ "Usage: %s(%s)", gvname, params);
} else {
/* Pants. I don't think that it should be possible to get here. */
Perl_croak(aTHX_ "Usage: CODE(0x%"UVxf")(%s)", PTR2UV(cv), params);
}
}
#undef PERL_ARGS_ASSERT_CROAK_XS_USAGE
#ifdef PERL_IMPLICIT_CONTEXT
#define croak_xs_usage(a,b) S_croak_xs_usage(aTHX_ a,b)
#else
#define croak_xs_usage S_croak_xs_usage
#endif
#endif
/* NOTE: the prototype of newXSproto() is different in versions of perls,
* so we define a portable version of newXSproto()
*/
#ifdef newXS_flags
#define newXSproto_portable(name, c_impl, file, proto) newXS_flags(name, c_impl, file, proto, 0)
#else
#define newXSproto_portable(name, c_impl, file, proto) (PL_Sv=(SV*)newXS(name, c_impl, file), sv_setpv(PL_Sv, proto), (CV*)PL_Sv)
#endif /* !defined(newXS_flags) */
#line 75 "ko_6_1_0_perllint_01cc.c"
XS(XS_main_c_test); /* prototype to pass -Wmissing-prototypes */
XS(XS_main_c_test)
{
#ifdef dVAR
dVAR; dXSARGS;
#else
dXSARGS;
#endif
if (items != 1)
croak_xs_usage(cv, "max");
PERL_UNUSED_VAR(ax); /* -Wall */
SP -= items;
{
int max = (int)SvIV(ST(0));
#line 22 "ko_6_1_0_perllint_01cc.xs"
I32* temp;
#line 93 "ko_6_1_0_perllint_01cc.c"
#line 24 "ko_6_1_0_perllint_01cc.xs"
temp = PL_markstack_ptr++;
c_test(max);
if (PL_markstack_ptr != temp) {
/* truly void, because dXSARGS not invoked */
PL_markstack_ptr = temp;
XSRETURN_EMPTY; /* return empty stack */
}
/* must have used dXSARGS; list context implied */
return; /* assume stack size is correct */
#line 104 "ko_6_1_0_perllint_01cc.c"
PUTBACK;
return;
}
}
#ifdef __cplusplus
extern "C"
#endif
XS(boot_ko_6_1_0_perllint_01cc); /* prototype to pass -Wmissing-prototypes */
XS(boot_ko_6_1_0_perllint_01cc)
{
#ifdef dVAR
dVAR; dXSARGS;
#else
dXSARGS;
#endif
#if (PERL_REVISION == 5 && PERL_VERSION < 9)
char* file = __FILE__;
#else
const char* file = __FILE__;
#endif
PERL_UNUSED_VAR(cv); /* -W */
PERL_UNUSED_VAR(items); /* -W */
XS_VERSION_BOOTCHECK ;
newXS("main::c_test", XS_main_c_test, file);
#if (PERL_REVISION == 5 && PERL_VERSION >= 9)
if (PL_unitcheckav)
call_list(PL_scopestack_ix, PL_unitcheckav);
#endif
XSRETURN_YES;
}
