magic type 'H'. This magic (itself) does nothing, but its presence causes
the values to gain magic type 'h', which has entries for set and clear.
C<Perl_magic_sethint> updates C<PL_compiling.cop_hints_hash> with a store
- record, with deletes written by C<Perl_magic_clearhint>. C<SAVE_HINTS>
+ record, with deletes written by C<Perl_magic_clearhint>. C<SAVEHINTS>
saves the current C<PL_compiling.cop_hints_hash> on the save stack, so that
it will be correctly restored when any inner compiling scope is exited.
*/
{
I32 * const * const ptr = (I32 **) op;
I32 * const slab = ptr[-1];
+
+ PERL_ARGS_ASSERT_SLAB_TO_RW;
+
assert( ptr-1 > (I32 **) slab );
assert( ptr < ( (I32 **) slab + PERL_SLAB_SIZE) );
assert( *slab > 0 );
PADOFFSET
Perl_op_refcnt_dec(pTHX_ OP *o)
{
+ PERL_ARGS_ASSERT_OP_REFCNT_DEC;
Slab_to_rw(o);
return --o->op_targ;
}
{
I32 * const * const ptr = (I32 **) op;
I32 * const slab = ptr[-1];
+ PERL_ARGS_ASSERT_SLAB_FREE;
assert( ptr-1 > (I32 **) slab );
assert( ptr < ( (I32 **) slab + PERL_SLAB_SIZE) );
assert( *slab > 0 );
S_gv_ename(pTHX_ GV *gv)
{
SV* const tmpsv = sv_newmortal();
+
+ PERL_ARGS_ASSERT_GV_ENAME;
+
gv_efullname3(tmpsv, gv, NULL);
return SvPV_nolen_const(tmpsv);
}
STATIC OP *
S_no_fh_allowed(pTHX_ OP *o)
{
+ PERL_ARGS_ASSERT_NO_FH_ALLOWED;
+
yyerror(Perl_form(aTHX_ "Missing comma after first argument to %s function",
OP_DESC(o)));
return o;
STATIC OP *
S_too_few_arguments(pTHX_ OP *o, const char *name)
{
+ PERL_ARGS_ASSERT_TOO_FEW_ARGUMENTS;
+
yyerror(Perl_form(aTHX_ "Not enough arguments for %s", name));
return o;
}
STATIC OP *
S_too_many_arguments(pTHX_ OP *o, const char *name)
{
+ PERL_ARGS_ASSERT_TOO_MANY_ARGUMENTS;
+
yyerror(Perl_form(aTHX_ "Too many arguments for %s", name));
return o;
}
STATIC void
S_bad_type(pTHX_ I32 n, const char *t, const char *name, const OP *kid)
{
+ PERL_ARGS_ASSERT_BAD_TYPE;
+
yyerror(Perl_form(aTHX_ "Type of arg %d to %s must be %s (not %s)",
(int)n, name, t, OP_DESC(kid)));
}
STATIC void
S_no_bareword_allowed(pTHX_ const OP *o)
{
+ PERL_ARGS_ASSERT_NO_BAREWORD_ALLOWED;
+
if (PL_madskills)
return; /* various ok barewords are hidden in extra OP_NULL */
qerror(Perl_mess(aTHX_
PADOFFSET off;
const bool is_our = (PL_parser->in_my == KEY_our);
+ PERL_ARGS_ASSERT_ALLOCMY;
+
/* complain about "my $<special_var>" etc etc */
if (*name &&
!(is_our ||
/* COP* is not cleared by op_clear() so that we may track line
* numbers etc even after null() */
- if (type == OP_NEXTSTATE || type == OP_SETSTATE || type == OP_DBSTATE) {
+ if (type == OP_NEXTSTATE || type == OP_DBSTATE) {
cop_free((COP*)o);
}
{
dVAR;
+
+ PERL_ARGS_ASSERT_OP_CLEAR;
+
#ifdef PERL_MAD
/* if (o->op_madprop && o->op_madprop->mad_next)
abort(); */
switch (o->op_type) {
case OP_NULL: /* Was holding old type, if any. */
if (PL_madskills && o->op_targ != OP_NULL) {
- o->op_type = o->op_targ;
+ o->op_type = (optype)o->op_targ;
o->op_targ = 0;
goto retry;
}
break;
case OP_METHOD_NAMED:
case OP_CONST:
+ case OP_HINTSEVAL:
SvREFCNT_dec(cSVOPo->op_sv);
cSVOPo->op_sv = NULL;
#ifdef USE_ITHREADS
*/
#ifdef USE_ITHREADS
if(PL_regex_pad) { /* We could be in destruction */
+ const IV offset = (cPMOPo)->op_pmoffset;
ReREFCNT_dec(PM_GETRE(cPMOPo));
- av_push((AV*) PL_regex_pad[0],
- (SV*) SvREFCNT_inc_simple_NN(PL_regex_pad[(cPMOPo)->op_pmoffset]));
- SvREADONLY_off(PL_regex_pad[(cPMOPo)->op_pmoffset]);
- PM_SETRE_OFFSET(cPMOPo, (cPMOPo)->op_pmoffset);
+ PL_regex_pad[offset] = &PL_sv_undef;
+ sv_catpvn_nomg(PL_regex_pad[0], (const char *)&offset,
+ sizeof(offset));
}
#else
ReREFCNT_dec(PM_GETRE(cPMOPo));
STATIC void
S_cop_free(pTHX_ COP* cop)
{
+ PERL_ARGS_ASSERT_COP_FREE;
+
CopLABEL_free(cop);
CopFILE_free(cop);
CopSTASH_free(cop);
)
{
HV * const pmstash = PmopSTASH(o);
+
+ PERL_ARGS_ASSERT_FORGET_PMOP;
+
if (pmstash && !SvIS_FREED(pmstash)) {
MAGIC * const mg = mg_find((SV*)pmstash, PERL_MAGIC_symtab);
if (mg) {
STATIC void
S_find_and_forget_pmops(pTHX_ OP *o)
{
+ PERL_ARGS_ASSERT_FIND_AND_FORGET_PMOPS;
+
if (o->op_flags & OPf_KIDS) {
OP *kid = cUNOPo->op_first;
while (kid) {
Perl_op_null(pTHX_ OP *o)
{
dVAR;
+
+ PERL_ARGS_ASSERT_OP_NULL;
+
if (o->op_type == OP_NULL)
return;
if (!PL_madskills)
{
OP *first;
+ PERL_ARGS_ASSERT_LINKLIST;
+
if (o->op_next)
return o->op_next;
S_scalarboolean(pTHX_ OP *o)
{
dVAR;
+
+ PERL_ARGS_ASSERT_SCALARBOOLEAN;
+
if (o->op_type == OP_SASSIGN && cBINOPo->op_first->op_type == OP_CONST) {
if (ckWARN(WARN_SYNTAX)) {
const line_t oldline = CopLINE(PL_curcop);
case OP_SORT:
if (ckWARN(WARN_VOID))
Perl_warner(aTHX_ packWARN(WARN_VOID), "Useless use of sort in scalar context");
+ break;
}
return o;
}
SV* sv;
U8 want;
+ PERL_ARGS_ASSERT_SCALARVOID;
+
/* trailing mad null ops don't count as "there" for void processing */
if (PL_madskills &&
o->op_type != OP_NULL &&
}
if (o->op_type == OP_NEXTSTATE
- || o->op_type == OP_SETSTATE
|| o->op_type == OP_DBSTATE
|| (o->op_type == OP_NULL && (o->op_targ == OP_NEXTSTATE
- || o->op_targ == OP_SETSTATE
|| o->op_targ == OP_DBSTATE)))
PL_curcop = (COP*)o; /* for warning below */
no_bareword_allowed(o);
else {
if (ckWARN(WARN_VOID)) {
- useless = "a constant";
+ if (SvOK(sv)) {
+ SV* msv = sv_2mortal(Perl_newSVpvf(aTHX_
+ "a constant (%"SVf")", sv));
+ useless = SvPV_nolen(msv);
+ }
+ else
+ useless = "a constant (undef)";
if (o->op_private & OPpCONST_ARYBASE)
useless = NULL;
/* don't warn on optimised away booleans, eg
STATIC bool
S_scalar_mod_type(const OP *o, I32 type)
{
+ PERL_ARGS_ASSERT_SCALAR_MOD_TYPE;
+
switch (type) {
case OP_SASSIGN:
if (o->op_type == OP_RV2GV)
STATIC bool
S_is_handle_constructor(const OP *o, I32 numargs)
{
+ PERL_ARGS_ASSERT_IS_HANDLE_CONSTRUCTOR;
+
switch (o->op_type) {
case OP_PIPE_OP:
case OP_SOCKPAIR:
dVAR;
OP *kid;
+ PERL_ARGS_ASSERT_DOREF;
+
if (!o || (PL_parser && PL_parser->error_count))
return o;
dVAR;
OP *rop;
+ PERL_ARGS_ASSERT_DUP_ATTRLIST;
+
/* An attrlist is either a simple OP_CONST or an OP_LIST with kids,
* where the first kid is OP_PUSHMARK and the remaining ones
* are OP_CONST. We need to push the OP_CONST values.
dVAR;
SV *stashsv;
+ PERL_ARGS_ASSERT_APPLY_ATTRS;
+
/* fake up C<use attributes $pkg,$rv,@attrs> */
ENTER; /* need to protect against side-effects of 'use' */
stashsv = stash ? newSVhek(HvNAME_HEK(stash)) : &PL_sv_no;
OP *pack, *imop, *arg;
SV *meth, *stashsv;
+ PERL_ARGS_ASSERT_APPLY_ATTRS_MY;
+
if (!attrs)
return;
{
OP *attrs = NULL;
+ PERL_ARGS_ASSERT_APPLY_ATTRS_STRING;
+
if (!len) {
len = strlen(attrstr);
}
dVAR;
I32 type;
+ PERL_ARGS_ASSERT_MY_KID;
+
if (!o || (PL_parser && PL_parser->error_count))
return o;
OP *rops;
int maybe_scalar = 0;
+ PERL_ARGS_ASSERT_MY_ATTRS;
+
/* [perl #17376]: this appears to be premature, and results in code such as
C< our(%x); > executing in list mode rather than void mode */
#if 0
OP *
Perl_my(pTHX_ OP *o)
{
+ PERL_ARGS_ASSERT_MY;
+
return my_attrs(o, NULL);
}
const OPCODE ltype = left->op_type;
const OPCODE rtype = right->op_type;
+ PERL_ARGS_ASSERT_BIND_MATCH;
+
if ( (ltype == OP_RV2AV || ltype == OP_RV2HV || ltype == OP_PADAV
|| ltype == OP_PADHV) && ckWARN(WARN_MISC))
{
Perl_newPROG(pTHX_ OP *o)
{
dVAR;
+
+ PERL_ARGS_ASSERT_NEWPROG;
+
if (PL_in_eval) {
if (PL_eval_root)
return;
Perl_localize(pTHX_ OP *o, I32 lex)
{
dVAR;
+
+ PERL_ARGS_ASSERT_LOCALIZE;
+
if (o->op_flags & OPf_PARENS)
/* [perl #17376]: this appears to be premature, and results in code such as
C< our(%x); > executing in list mode rather than void mode */
OP *
Perl_jmaybe(pTHX_ OP *o)
{
+ PERL_ARGS_ASSERT_JMAYBE;
+
if (o->op_type == OP_LIST) {
OP * const o2
= newSVREF(newGVOP(OP_GV, 0, gv_fetchpvs(";", GV_ADD|GV_NOTQUAL, SVt_PV)));
Perl_fold_constants(pTHX_ register OP *o)
{
dVAR;
- register OP *curop;
+ register OP * VOL curop;
OP *newop;
VOL I32 type = o->op_type;
SV * VOL sv = NULL;
OP *old_next;
SV * const oldwarnhook = PL_warnhook;
SV * const olddiehook = PL_diehook;
+ COP not_compiling;
dJMPENV;
+ PERL_ARGS_ASSERT_FOLD_CONSTANTS;
+
if (PL_opargs[type] & OA_RETSCALAR)
scalar(o);
if (PL_opargs[type] & OA_TARGET && !o->op_targ)
/* XXX what about the numeric ops? */
if (PL_hints & HINT_LOCALE)
goto nope;
+ break;
}
if (PL_parser && PL_parser->error_count)
oldscope = PL_scopestack_ix;
create_eval_scope(G_FAKINGEVAL);
+ /* Verify that we don't need to save it: */
+ assert(PL_curcop == &PL_compiling);
+ StructCopy(&PL_compiling, ¬_compiling, COP);
+ PL_curcop = ¬_compiling;
+ /* The above ensures that we run with all the correct hints of the
+ currently compiling COP, but that IN_PERL_RUNTIME is not true. */
+ assert(IN_PERL_RUNTIME);
PL_warnhook = PERL_WARNHOOK_FATAL;
PL_diehook = NULL;
JMPENV_PUSH(ret);
JMPENV_POP;
PL_warnhook = oldwarnhook;
PL_diehook = olddiehook;
+ PL_curcop = &PL_compiling;
if (PL_scopestack_ix > oldscope)
delete_eval_scope();
void
Perl_token_free(pTHX_ TOKEN* tk)
{
+ PERL_ARGS_ASSERT_TOKEN_FREE;
+
if (tk->tk_type != 12345)
return;
mad_free(tk->tk_mad);
{
MADPROP* mp;
MADPROP* tm;
+
+ PERL_ARGS_ASSERT_TOKEN_GETMAD;
+
if (tk->tk_type != 12345) {
Perl_warner(aTHX_ packWARN(WARN_MISC),
"Invalid TOKEN object ignored");
MADPROP *
Perl_newMADsv(pTHX_ char key, SV* sv)
{
+ PERL_ARGS_ASSERT_NEWMADSV;
+
return newMADPROP(key, MAD_SV, sv, 0);
}
const I32 squash = o->op_private & OPpTRANS_SQUASH;
I32 del = o->op_private & OPpTRANS_DELETE;
SV* swash;
+
+ PERL_ARGS_ASSERT_PMTRANS;
+
PL_hints |= HINT_BLOCK_SCOPE;
if (SvUTF8(tstr))
#ifdef USE_ITHREADS
- if (av_len((AV*) PL_regex_pad[0]) > -1) {
- SV * const repointer = av_pop((AV*)PL_regex_pad[0]);
- const IV offset = SvIV(repointer);
+ assert(SvPOK(PL_regex_pad[0]));
+ if (SvCUR(PL_regex_pad[0])) {
+ /* Pop off the "packed" IV from the end. */
+ SV *const repointer_list = PL_regex_pad[0];
+ const char *p = SvEND(repointer_list) - sizeof(IV);
+ const IV offset = *((IV*)p);
+
+ assert(SvCUR(repointer_list) % sizeof(IV) == 0);
+
+ SvEND_set(repointer_list, p);
+
pmop->op_pmoffset = offset;
- SvOK_off(repointer);
- assert(repointer == PL_regex_pad[offset]);
- /* One reference remains, in PL_regex_pad[offset] */
- SvREFCNT_dec(repointer);
+ /* This slot should be free, so assert this: */
+ assert(PL_regex_pad[offset] == &PL_sv_undef);
} else {
- SV * const repointer = newSViv(0);
+ SV * const repointer = &PL_sv_undef;
av_push(PL_regex_padav, repointer);
pmop->op_pmoffset = av_len(PL_regex_padav);
PL_regex_pad = AvARRAY(PL_regex_padav);
OP* repl = NULL;
bool reglist;
+ PERL_ARGS_ASSERT_PMRUNTIME;
+
if (o->op_type == OP_SUBST || o->op_type == OP_TRANS) {
/* last element in list is the replacement; pop it */
OP* kid;
{
dVAR;
SVOP *svop;
+
+ PERL_ARGS_ASSERT_NEWSVOP;
+
NewOp(1101, svop, 1, SVOP);
svop->op_type = (OPCODE)type;
svop->op_ppaddr = PL_ppaddr[type];
{
dVAR;
PADOP *padop;
+
+ PERL_ARGS_ASSERT_NEWPADOP;
+
NewOp(1101, padop, 1, PADOP);
padop->op_type = (OPCODE)type;
padop->op_ppaddr = PL_ppaddr[type];
Perl_newGVOP(pTHX_ I32 type, I32 flags, GV *gv)
{
dVAR;
- assert(gv);
+
+ PERL_ARGS_ASSERT_NEWGVOP;
+
#ifdef USE_ITHREADS
GvIN_PAD_on(gv);
return newPADOP(type, flags, SvREFCNT_inc_simple_NN(gv));
OP *pegop;
#endif
+ PERL_ARGS_ASSERT_PACKAGE;
+
save_hptr(&PL_curstash);
save_item(PL_curstname);
OP *pegop = newOP(OP_NULL,0);
#endif
+ PERL_ARGS_ASSERT_UTILIZE;
+
if (idop->op_type != OP_CONST)
Perl_croak(aTHX_ "Module name must be constant");
Perl_load_module(pTHX_ U32 flags, SV *name, SV *ver, ...)
{
va_list args;
+
+ PERL_ARGS_ASSERT_LOAD_MODULE;
+
va_start(args, ver);
vload_module(flags, name, ver, &args);
va_end(args);
{
dTHX;
va_list args;
+ PERL_ARGS_ASSERT_LOAD_MODULE_NOCONTEXT;
va_start(args, ver);
vload_module(flags, name, ver, &args);
va_end(args);
{
dVAR;
OP *veop, *imop;
-
OP * const modname = newSVOP(OP_CONST, 0, name);
+
+ PERL_ARGS_ASSERT_VLOAD_MODULE;
+
modname->op_private |= OPpCONST_BARE;
if (ver) {
veop = newSVOP(OP_CONST, 0, ver);
OP *doop;
GV *gv = NULL;
+ PERL_ARGS_ASSERT_DOFILE;
+
if (!force_builtin) {
gv = gv_fetchpvs("do", GV_NOTQUAL, SVt_PVCV);
if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
Perl_newLOGOP(pTHX_ I32 type, I32 flags, OP *first, OP *other)
{
dVAR;
+
+ PERL_ARGS_ASSERT_NEWLOGOP;
+
return new_logop(type, flags, &first, &other);
}
OP *first = *firstp;
OP * const other = *otherp;
+ PERL_ARGS_ASSERT_NEW_LOGOP;
+
if (type == OP_XOR) /* Not short circuit, but here by precedence. */
return newBINOP(type, flags, scalar(first), scalar(other));
OP *start;
OP *o;
+ PERL_ARGS_ASSERT_NEWCONDOP;
+
if (!falseop)
return newLOGOP(OP_AND, 0, first, trueop);
if (!trueop)
OP *leftstart;
OP *o;
+ PERL_ARGS_ASSERT_NEWRANGE;
+
NewOp(1101, range, 1, LOGOP);
range->op_type = OP_RANGE;
I32 iterpflags = 0;
OP *madsv = NULL;
+ PERL_ARGS_ASSERT_NEWFOROP;
+
if (sv) {
if (sv->op_type == OP_RV2SV) { /* symbol table variable */
iterpflags = sv->op_private & OPpOUR_INTRO; /* for our $x () */
dVAR;
OP *o;
+ PERL_ARGS_ASSERT_NEWLOOPEX;
+
if (type != OP_GOTO || label->op_type == OP_CONST) {
/* "last()" means "last" */
if (label->op_type == OP_STUB && (label->op_flags & OPf_PARENS))
LOGOP *enterop;
OP *o;
+ PERL_ARGS_ASSERT_NEWGIVWHENOP;
+
NewOp(1101, enterop, 1, LOGOP);
- enterop->op_type = enter_opcode;
+ enterop->op_type = (optype)enter_opcode;
enterop->op_ppaddr = PL_ppaddr[enter_opcode];
enterop->op_flags = (U8) OPf_KIDS;
enterop->op_targ = ((entertarg == NOT_IN_PAD) ? 0 : entertarg);
S_looks_like_bool(pTHX_ const OP *o)
{
dVAR;
+
+ PERL_ARGS_ASSERT_LOOKS_LIKE_BOOL;
+
switch(o->op_type) {
case OP_OR:
return looks_like_bool(cLOGOPo->op_first);
Perl_newGIVENOP(pTHX_ OP *cond, OP *block, PADOFFSET defsv_off)
{
dVAR;
- assert( cond );
+ PERL_ARGS_ASSERT_NEWGIVENOP;
return newGIVWHENOP(
ref_array_or_hash(cond),
block,
const bool cond_llb = (!cond || looks_like_bool(cond));
OP *cond_op;
+ PERL_ARGS_ASSERT_NEWWHENOP;
+
if (cond_llb)
cond_op = cond;
else {
{
dVAR;
+ PERL_ARGS_ASSERT_CV_UNDEF;
+
DEBUG_X(PerlIO_printf(Perl_debug_log,
"CV undef: cv=0x%"UVxf" comppad=0x%"UVxf"\n",
PTR2UV(cv), PTR2UV(PL_comppad))
Perl_cv_ckproto_len(pTHX_ const CV *cv, const GV *gv, const char *p,
const STRLEN len)
{
+ PERL_ARGS_ASSERT_CV_CKPROTO_LEN;
+
/* Can't just use a strcmp on the prototype, as CONSTSUBs "cheat" by
relying on SvCUR, and doubling up the buffer to hold CvFILE(). */
if (((!p != !SvPOK(cv)) /* One has prototype, one has not. */
const char *const colon = strrchr(fullname,':');
const char *const name = colon ? colon + 1 : fullname;
+ PERL_ARGS_ASSERT_PROCESS_SPECIAL_BLOCKS;
+
if (*name == 'B') {
if (strEQ(name, "BEGIN")) {
const I32 oldscope = PL_scopestack_ix;
{
CV *cv = newXS(name, subaddr, filename);
+ PERL_ARGS_ASSERT_NEWXS_FLAGS;
+
if (flags & XS_DYNAMIC_FILENAME) {
/* We need to "make arrangements" (ie cheat) to ensure that the
filename lasts as long as the PVCV we just created, but also doesn't
GV_ADDMULTI, SVt_PVCV);
register CV *cv;
+ PERL_ARGS_ASSERT_NEWXS;
+
if (!subaddr)
Perl_croak(aTHX_ "panic: no address for '%s' in '%s'", name, filename);
Perl_oopsAV(pTHX_ OP *o)
{
dVAR;
+
+ PERL_ARGS_ASSERT_OOPSAV;
+
switch (o->op_type) {
case OP_PADSV:
o->op_type = OP_PADAV;
Perl_oopsHV(pTHX_ OP *o)
{
dVAR;
+
+ PERL_ARGS_ASSERT_OOPSHV;
+
switch (o->op_type) {
case OP_PADSV:
case OP_PADAV:
Perl_newAVREF(pTHX_ OP *o)
{
dVAR;
+
+ PERL_ARGS_ASSERT_NEWAVREF;
+
if (o->op_type == OP_PADANY) {
o->op_type = OP_PADAV;
o->op_ppaddr = PL_ppaddr[OP_PADAV];
Perl_newHVREF(pTHX_ OP *o)
{
dVAR;
+
+ PERL_ARGS_ASSERT_NEWHVREF;
+
if (o->op_type == OP_PADANY) {
o->op_type = OP_PADHV;
o->op_ppaddr = PL_ppaddr[OP_PADHV];
Perl_newSVREF(pTHX_ OP *o)
{
dVAR;
+
+ PERL_ARGS_ASSERT_NEWSVREF;
+
if (o->op_type == OP_PADANY) {
o->op_type = OP_PADSV;
o->op_ppaddr = PL_ppaddr[OP_PADSV];
OP *
Perl_ck_anoncode(pTHX_ OP *o)
{
+ PERL_ARGS_ASSERT_CK_ANONCODE;
+
cSVOPo->op_targ = pad_add_anon(cSVOPo->op_sv, o->op_type);
if (!PL_madskills)
cSVOPo->op_sv = NULL;
Perl_ck_bitop(pTHX_ OP *o)
{
dVAR;
+
+ PERL_ARGS_ASSERT_CK_BITOP;
+
#define OP_IS_NUMCOMPARE(op) \
((op) == OP_LT || (op) == OP_I_LT || \
(op) == OP_GT || (op) == OP_I_GT || \
Perl_ck_concat(pTHX_ OP *o)
{
const OP * const kid = cUNOPo->op_first;
+
+ PERL_ARGS_ASSERT_CK_CONCAT;
PERL_UNUSED_CONTEXT;
+
if (kid->op_type == OP_CONCAT && !(kid->op_private & OPpTARGET_MY) &&
!(kUNOP->op_first->op_flags & OPf_MOD))
o->op_flags |= OPf_STACKED;
Perl_ck_spair(pTHX_ OP *o)
{
dVAR;
+
+ PERL_ARGS_ASSERT_CK_SPAIR;
+
if (o->op_flags & OPf_KIDS) {
OP* newop;
OP* kid;
OP *
Perl_ck_delete(pTHX_ OP *o)
{
+ PERL_ARGS_ASSERT_CK_DELETE;
+
o = ck_fun(o);
o->op_private = 0;
if (o->op_flags & OPf_KIDS) {
OP *
Perl_ck_die(pTHX_ OP *o)
{
+ PERL_ARGS_ASSERT_CK_DIE;
+
#ifdef VMS
if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
#endif
{
dVAR;
+ PERL_ARGS_ASSERT_CK_EOF;
+
if (o->op_flags & OPf_KIDS) {
if (cLISTOPo->op_first->op_type == OP_STUB) {
OP * const newop
Perl_ck_eval(pTHX_ OP *o)
{
dVAR;
+
+ PERL_ARGS_ASSERT_CK_EVAL;
+
PL_hints |= HINT_BLOCK_SCOPE;
if (o->op_flags & OPf_KIDS) {
SVOP * const kid = (SVOP*)cUNOPo->op_first;
}
o->op_targ = (PADOFFSET)PL_hints;
if ((PL_hints & HINT_LOCALIZE_HH) != 0 && GvHV(PL_hintgv)) {
- /* Store a copy of %^H that pp_entereval can pick up.
- OPf_SPECIAL flags the opcode as being for this purpose,
- so that it in turn will return a copy at every
- eval.*/
- OP *hhop = newSVOP(OP_CONST, OPf_SPECIAL,
+ /* Store a copy of %^H that pp_entereval can pick up. */
+ OP *hhop = newSVOP(OP_HINTSEVAL, 0,
(SV*)Perl_hv_copy_hints_hv(aTHX_ GvHV(PL_hintgv)));
cUNOPo->op_first->op_sibling = hhop;
o->op_private |= OPpEVAL_HAS_HH;
OP *
Perl_ck_exit(pTHX_ OP *o)
{
+ PERL_ARGS_ASSERT_CK_EXIT;
+
#ifdef VMS
HV * const table = GvHV(PL_hintgv);
if (table) {
OP *
Perl_ck_exec(pTHX_ OP *o)
{
+ PERL_ARGS_ASSERT_CK_EXEC;
+
if (o->op_flags & OPf_STACKED) {
OP *kid;
o = ck_fun(o);
Perl_ck_exists(pTHX_ OP *o)
{
dVAR;
+
+ PERL_ARGS_ASSERT_CK_EXISTS;
+
o = ck_fun(o);
if (o->op_flags & OPf_KIDS) {
OP * const kid = cUNOPo->op_first;
dVAR;
SVOP * const kid = (SVOP*)cUNOPo->op_first;
+ PERL_ARGS_ASSERT_CK_RVCONST;
+
o->op_private |= (PL_hints & HINT_STRICT_REFS);
if (o->op_type == OP_RV2CV)
o->op_private &= ~1;
dVAR;
const I32 type = o->op_type;
+ PERL_ARGS_ASSERT_CK_FTST;
+
if (o->op_flags & OPf_REF) {
NOOP;
}
#endif
return newop;
}
- if ((PL_hints & HINT_FILETEST_ACCESS) && OP_IS_FILETEST_ACCESS(o))
+ if ((PL_hints & HINT_FILETEST_ACCESS) && OP_IS_FILETEST_ACCESS(o->op_type))
o->op_private |= OPpFT_ACCESS;
if (PL_check[kidtype] == MEMBER_TO_FPTR(Perl_ck_ftst)
&& kidtype != OP_STAT && kidtype != OP_LSTAT)
const int type = o->op_type;
register I32 oa = PL_opargs[type] >> OASHIFT;
+ PERL_ARGS_ASSERT_CK_FUN;
+
if (o->op_flags & OPf_STACKED) {
if ((oa & OA_OPTIONAL) && (oa >> 4) && !((oa >> 4) & OA_OPTIONAL))
oa &= ~OA_OPTIONAL;
dVAR;
GV *gv;
+ PERL_ARGS_ASSERT_CK_GLOB;
+
o = ck_fun(o);
if ((o->op_flags & OPf_KIDS) && !cLISTOPo->op_first->op_sibling)
append_elem(OP_GLOB, o, newDEFSVOP());
const OPCODE type = o->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE;
PADOFFSET offset;
+ PERL_ARGS_ASSERT_CK_GREP;
+
o->op_ppaddr = PL_ppaddr[OP_GREPSTART];
/* don't allocate gwop here, as we may leak it if PL_parser->error_count > 0 */
OP *
Perl_ck_index(pTHX_ OP *o)
{
+ PERL_ARGS_ASSERT_CK_INDEX;
+
if (o->op_flags & OPf_KIDS) {
OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
if (kid)
}
OP *
-Perl_ck_lengthconst(pTHX_ OP *o)
-{
- /* XXX length optimization goes here */
- return ck_fun(o);
-}
-
-OP *
Perl_ck_lfun(pTHX_ OP *o)
{
const OPCODE type = o->op_type;
+
+ PERL_ARGS_ASSERT_CK_LFUN;
+
return modkids(ck_fun(o), type);
}
OP *
Perl_ck_defined(pTHX_ OP *o) /* 19990527 MJD */
{
+ PERL_ARGS_ASSERT_CK_DEFINED;
+
if ((o->op_flags & OPf_KIDS) && ckWARN2(WARN_DEPRECATED, WARN_SYNTAX)) {
switch (cUNOPo->op_first->op_type) {
case OP_RV2AV:
OP *
Perl_ck_readline(pTHX_ OP *o)
{
+ PERL_ARGS_ASSERT_CK_READLINE;
+
if (!(o->op_flags & OPf_KIDS)) {
OP * const newop
= newUNOP(OP_READLINE, 0, newGVOP(OP_GV, 0, PL_argvgv));
Perl_ck_rfun(pTHX_ OP *o)
{
const OPCODE type = o->op_type;
+
+ PERL_ARGS_ASSERT_CK_RFUN;
+
return refkids(ck_fun(o), type);
}
{
register OP *kid;
+ PERL_ARGS_ASSERT_CK_LISTIOB;
+
kid = cLISTOPo->op_first;
if (!kid) {
o = force_list(o);
{
dVAR;
OP * const kid = cLISTOPo->op_first;
+
+ PERL_ARGS_ASSERT_CK_SASSIGN;
+
/* has a disposable target? */
if ((PL_opargs[kid->op_type] & OA_TARGLEX)
&& !(kid->op_flags & OPf_STACKED)
Perl_ck_match(pTHX_ OP *o)
{
dVAR;
+
+ PERL_ARGS_ASSERT_CK_MATCH;
+
if (o->op_type != OP_QR && PL_compcv) {
const PADOFFSET offset = pad_findmy("$_");
if (offset != NOT_IN_PAD && !(PAD_COMPNAME_FLAGS_isOUR(offset))) {
Perl_ck_method(pTHX_ OP *o)
{
OP * const kid = cUNOPo->op_first;
+
+ PERL_ARGS_ASSERT_CK_METHOD;
+
if (kid->op_type == OP_CONST) {
SV* sv = kSVOP->op_sv;
const char * const method = SvPVX_const(sv);
OP *
Perl_ck_null(pTHX_ OP *o)
{
+ PERL_ARGS_ASSERT_CK_NULL;
PERL_UNUSED_CONTEXT;
return o;
}
{
dVAR;
HV * const table = GvHV(PL_hintgv);
+
+ PERL_ARGS_ASSERT_CK_OPEN;
+
if (table) {
SV **svp = hv_fetchs(table, "open_IN", FALSE);
if (svp && *svp) {
OP *
Perl_ck_repeat(pTHX_ OP *o)
{
+ PERL_ARGS_ASSERT_CK_REPEAT;
+
if (cBINOPo->op_first->op_flags & OPf_PARENS) {
o->op_private |= OPpREPEAT_DOLIST;
cBINOPo->op_first = force_list(cBINOPo->op_first);
dVAR;
GV* gv = NULL;
+ PERL_ARGS_ASSERT_CK_REQUIRE;
+
if (o->op_flags & OPf_KIDS) { /* Shall we supply missing .pm? */
SVOP * const kid = (SVOP*)cUNOPo->op_first;
Perl_ck_return(pTHX_ OP *o)
{
dVAR;
+
+ PERL_ARGS_ASSERT_CK_RETURN;
+
if (CvLVALUE(PL_compcv)) {
OP *kid;
for (kid = cLISTOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
{
dVAR;
OP* kid;
+
+ PERL_ARGS_ASSERT_CK_SELECT;
+
if (o->op_flags & OPf_KIDS) {
kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
if (kid && kid->op_sibling) {
dVAR;
const I32 type = o->op_type;
+ PERL_ARGS_ASSERT_CK_SHIFT;
+
if (!(o->op_flags & OPf_KIDS)) {
OP *argop;
/* FIXME - this can be refactored to reduce code in #ifdefs */
dVAR;
OP *firstkid;
+ PERL_ARGS_ASSERT_CK_SORT;
+
if (o->op_type == OP_SORT && (PL_hints & HINT_LOCALIZE_HH) != 0) {
HV * const hinthv = GvHV(PL_hintgv);
if (hinthv) {
int descending;
GV *gv;
const char *gvname;
+
+ PERL_ARGS_ASSERT_SIMPLIFY_SORT;
+
if (!(o->op_flags & OPf_STACKED))
return;
GvMULTI_on(gv_fetchpvs("a", GV_ADD|GV_NOTQUAL, SVt_PV));
dVAR;
register OP *kid;
+ PERL_ARGS_ASSERT_CK_SPLIT;
+
if (o->op_flags & OPf_STACKED)
return no_fh_allowed(o);
Perl_ck_join(pTHX_ OP *o)
{
const OP * const kid = cLISTOPo->op_first->op_sibling;
+
+ PERL_ARGS_ASSERT_CK_JOIN;
+
if (kid && kid->op_type == OP_MATCH) {
if (ckWARN(WARN_SYNTAX)) {
const REGEXP *re = PM_GETRE(kPMOP);
const char *e = NULL;
bool delete_op = 0;
+ PERL_ARGS_ASSERT_CK_SUBR;
+
o->op_private |= OPpENTERSUB_HASTARG;
for (cvop = o2; cvop->op_sibling; cvop = cvop->op_sibling) ;
if (cvop->op_type == OP_RV2CV) {
OP *
Perl_ck_svconst(pTHX_ OP *o)
{
+ PERL_ARGS_ASSERT_CK_SVCONST;
PERL_UNUSED_CONTEXT;
SvREADONLY_on(cSVOPo->op_sv);
return o;
OP *
Perl_ck_trunc(pTHX_ OP *o)
{
+ PERL_ARGS_ASSERT_CK_TRUNC;
+
if (o->op_flags & OPf_KIDS) {
SVOP *kid = (SVOP*)cUNOPo->op_first;
Perl_ck_unpack(pTHX_ OP *o)
{
OP *kid = cLISTOPo->op_first;
+
+ PERL_ARGS_ASSERT_CK_UNPACK;
+
if (kid->op_sibling) {
kid = kid->op_sibling;
if (!kid->op_sibling)
OP *
Perl_ck_substr(pTHX_ OP *o)
{
+ PERL_ARGS_ASSERT_CK_SUBSTR;
+
o = ck_fun(o);
if ((o->op_flags & OPf_KIDS) && (o->op_private == 4)) {
OP *kid = cLISTOPo->op_first;
dVAR;
OP *kid = cLISTOPo->op_first;
+ PERL_ARGS_ASSERT_CK_EACH;
+
if (kid->op_type == OP_PADAV || kid->op_type == OP_RV2AV) {
const unsigned new_type = o->op_type == OP_EACH ? OP_AEACH
: o->op_type == OP_KEYS ? OP_AKEYS : OP_AVALUES;
o->op_opt = 1;
PL_op = o;
switch (o->op_type) {
- case OP_SETSTATE:
case OP_NEXTSTATE:
case OP_DBSTATE:
PL_curcop = ((COP*)o); /* for warnings */
if (cSVOPo->op_private & OPpCONST_STRICT)
no_bareword_allowed(o);
#ifdef USE_ITHREADS
+ case OP_HINTSEVAL:
case OP_METHOD_NAMED:
/* Relocate sv to the pad for thread safety.
* Despite being a "constant", the SV is written to,
* for reference counts, sv_upgrade() etc. */
if (cSVOP->op_sv) {
const PADOFFSET ix = pad_alloc(OP_CONST, SVs_PADTMP);
- if (o->op_type == OP_CONST && SvPADTMP(cSVOPo->op_sv)) {
+ if (o->op_type != OP_METHOD_NAMED && SvPADTMP(cSVOPo->op_sv)) {
/* If op_sv is already a PADTMP then it is being used by
* some pad, so make a copy. */
sv_setsv(PAD_SVl(ix),cSVOPo->op_sv);
SvREADONLY_on(PAD_SVl(ix));
SvREFCNT_dec(cSVOPo->op_sv);
}
- else if (o->op_type == OP_CONST
+ else if (o->op_type != OP_METHOD_NAMED
&& cSVOPo->op_sv == &PL_sv_undef) {
/* PL_sv_undef is hack - it's unsafe to store it in the
AV that is the pad, because av_fetch treats values of
goto nothin;
case OP_NULL:
if (o->op_targ == OP_NEXTSTATE
- || o->op_targ == OP_DBSTATE
- || o->op_targ == OP_SETSTATE)
+ || o->op_targ == OP_DBSTATE)
{
PL_curcop = ((COP*)o);
}
SV* keysv;
HE* he;
+ PERL_ARGS_ASSERT_CUSTOM_OP_NAME;
+
if (!PL_custom_op_names) /* This probably shouldn't happen */
return (char *)PL_op_name[OP_CUSTOM];
SV* keysv;
HE* he;
+ PERL_ARGS_ASSERT_CUSTOM_OP_DESC;
+
if (!PL_custom_op_descs)
return (char *)PL_op_desc[OP_CUSTOM];