void
Perl_Slab_Free(pTHX_ void *op)
{
- I32 **ptr = (I32 **) op;
- I32 *slab = ptr[-1];
+ I32 * const * const ptr = (I32 **) op;
+ I32 * const slab = ptr[-1];
assert( ptr-1 > (I32 **) slab );
assert( ptr < ( (I32 **) slab + PERL_SLAB_SIZE) );
assert( *slab > 0 );
STATIC const char*
S_gv_ename(pTHX_ GV *gv)
{
- SV* tmpsv = sv_newmortal();
+ SV* const tmpsv = sv_newmortal();
gv_efullname3(tmpsv, gv, Nullch);
return SvPV_nolen_const(tmpsv);
}
PADOFFSET off;
/* complain about "my $<special_var>" etc etc */
- if (!(PL_in_my == KEY_our ||
+ if (*name &&
+ !(PL_in_my == KEY_our ||
isALPHA(name[1]) ||
(USE_UTF8_IN_NAMES && UTF8_IS_START(name[1])) ||
- (name[1] == '_' && (*name == '$' || (int)strlen(name) > 2))))
+ (name[1] == '_' && (*name == '$' || name[2]))))
{
+ /* name[2] is true if strlen(name) > 2 */
if (!isPRINT(name[1]) || strchr("\t\n\r\f", name[1])) {
/* 1999-02-27 mjd@plover.com */
char *p;
case OP_QR:
clear_pmop:
{
- HV *pmstash = PmopSTASH(cPMOPo);
- if (pmstash && SvREFCNT(pmstash)) {
- MAGIC *mg = mg_find((SV*)pmstash, PERL_MAGIC_symtab);
+ HV * const pmstash = PmopSTASH(cPMOPo);
+ if (pmstash && !SvIS_FREED(pmstash)) {
+ MAGIC * const mg = mg_find((SV*)pmstash, PERL_MAGIC_symtab);
if (mg) {
PMOP *pmop = (PMOP*) mg->mg_obj;
PMOP *lastpmop = NULL;
OP *kid;
/* assumes no premature commitment */
- if (!o || (o->op_flags & OPf_WANT) || PL_error_count
+ if (!o || PL_error_count || (o->op_flags & OPf_WANT)
|| o->op_type == OP_RETURN)
{
return o;
o->op_ppaddr = PL_ppaddr[OP_PREDEC];
break;
+ case OP_I_POSTINC:
+ o->op_type = OP_I_PREINC; /* pre-increment is faster */
+ o->op_ppaddr = PL_ppaddr[OP_I_PREINC];
+ break;
+
+ case OP_I_POSTDEC:
+ o->op_type = OP_I_PREDEC; /* pre-decrement is faster */
+ o->op_ppaddr = PL_ppaddr[OP_I_PREDEC];
+ break;
+
case OP_OR:
case OP_AND:
case OP_DOR:
}
OP *
-Perl_ref(pTHX_ OP *o, I32 type)
+Perl_doref(pTHX_ OP *o, I32 type, bool set_op_ref)
{
dVAR;
OP *kid;
case OP_COND_EXPR:
for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
- ref(kid, type);
+ doref(kid, type, set_op_ref);
break;
case OP_RV2SV:
if (type == OP_DEFINED)
o->op_flags |= OPf_SPECIAL; /* don't create GV */
- ref(cUNOPo->op_first, o->op_type);
+ doref(cUNOPo->op_first, o->op_type, set_op_ref);
/* FALL THROUGH */
case OP_PADSV:
if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
case OP_RV2AV:
case OP_RV2HV:
- o->op_flags |= OPf_REF;
+ if (set_op_ref)
+ o->op_flags |= OPf_REF;
/* FALL THROUGH */
case OP_RV2GV:
if (type == OP_DEFINED)
o->op_flags |= OPf_SPECIAL; /* don't create GV */
- ref(cUNOPo->op_first, o->op_type);
+ doref(cUNOPo->op_first, o->op_type, set_op_ref);
break;
case OP_PADAV:
case OP_PADHV:
- o->op_flags |= OPf_REF;
+ if (set_op_ref)
+ o->op_flags |= OPf_REF;
break;
case OP_SCALAR:
case OP_NULL:
if (!(o->op_flags & OPf_KIDS))
break;
- ref(cBINOPo->op_first, type);
+ doref(cBINOPo->op_first, type, set_op_ref);
break;
case OP_AELEM:
case OP_HELEM:
- ref(cBINOPo->op_first, o->op_type);
+ doref(cBINOPo->op_first, o->op_type, set_op_ref);
if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
: type == OP_RV2HV ? OPpDEREF_HV
case OP_SCOPE:
case OP_LEAVE:
+ set_op_ref = FALSE;
+ /* FALL THROUGH */
case OP_ENTER:
case OP_LIST:
if (!(o->op_flags & OPf_KIDS))
break;
- ref(cLISTOPo->op_last, type);
+ doref(cLISTOPo->op_last, type, set_op_ref);
break;
default:
break;
STATIC OP *
S_dup_attrlist(pTHX_ OP *o)
{
- OP *rop = Nullop;
+ OP *rop;
/* 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
rop = newSVOP(OP_CONST, o->op_flags, SvREFCNT_inc(cSVOPo->op_sv));
else {
assert((o->op_type == OP_LIST) && (o->op_flags & OPf_KIDS));
+ rop = Nullop;
for (o = cLISTOPo->op_first; o; o=o->op_sibling) {
if (o->op_type == OP_CONST)
rop = append_elem(OP_LIST, rop,
if (for_my) {
/* Don't force the C<use> if we don't need it. */
- SV **svp = hv_fetch(GvHVn(PL_incgv), ATTRSMODULE_PM,
+ SV * const * const svp = hv_fetch(GvHVn(PL_incgv), ATTRSMODULE_PM,
sizeof(ATTRSMODULE_PM)-1, 0);
if (svp && *svp != &PL_sv_undef)
; /* already in %INC */
while (len) {
for (; isSPACE(*attrstr) && len; --len, ++attrstr) ;
if (len) {
- const char *sstr = attrstr;
+ const char * const sstr = attrstr;
for (; !isSPACE(*attrstr) && len; --len, ++attrstr) ;
attrs = append_elem(OP_LIST, attrs,
newSVOP(OP_CONST, 0,
yyerror(Perl_form(aTHX_ "Can't declare %s in %s",
OP_DESC(o), PL_in_my == KEY_our ? "our" : "my"));
} else if (attrs) {
- GV *gv = cGVOPx_gv(cUNOPo->op_first);
+ GV * const gv = cGVOPx_gv(cUNOPo->op_first);
PL_in_my = FALSE;
PL_in_my_stash = Nullhv;
apply_attrs(GvSTASH(gv),
OP *
Perl_my_attrs(pTHX_ OP *o, OP *attrs)
{
- OP *rops = Nullop;
+ OP *rops;
int maybe_scalar = 0;
/* [perl #17376]: this appears to be premature, and results in code such as
#endif
if (attrs)
SAVEFREEOP(attrs);
+ rops = Nullop;
o = my_kid(o, attrs, &rops);
if (rops) {
if (maybe_scalar && o->op_type == OP_PADSV) {
OP *o;
bool ismatchop = 0;
- if (ckWARN(WARN_MISC) &&
- (left->op_type == OP_RV2AV ||
+ if ( (left->op_type == OP_RV2AV ||
left->op_type == OP_RV2HV ||
left->op_type == OP_PADAV ||
- left->op_type == OP_PADHV)) {
- const char *desc = PL_op_desc[(right->op_type == OP_SUBST ||
+ left->op_type == OP_PADHV)
+ && ckWARN(WARN_MISC))
+ {
+ const char * const desc = PL_op_desc[(right->op_type == OP_SUBST ||
right->op_type == OP_TRANS)
? right->op_type : OP_MATCH];
- const char *sample = ((left->op_type == OP_RV2AV ||
+ const char * const sample = ((left->op_type == OP_RV2AV ||
left->op_type == OP_PADAV)
? "@array" : "%hash");
Perl_warner(aTHX_ packWARN(WARN_MISC),
o->op_type = OP_SCOPE;
o->op_ppaddr = PL_ppaddr[OP_SCOPE];
kid = ((LISTOP*)o)->op_first;
- if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE)
+ if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
op_null(kid);
+
+ /* The following deals with things like 'do {1 for 1}' */
+ kid = kid->op_sibling;
+ if (kid &&
+ (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE))
+ op_null(kid);
+ }
}
else
o = newLISTOP(OP_SCOPE, 0, o, Nullop);
return o;
}
-/* XXX kept for BINCOMPAT only */
-void
-Perl_save_hints(pTHX)
-{
- Perl_croak(aTHX_ "internal error: obsolete function save_hints() called");
-}
-
int
Perl_block_start(pTHX_ int full)
{
Perl_block_end(pTHX_ I32 floor, OP *seq)
{
const int needblockscope = PL_hints & HINT_BLOCK_SCOPE;
- OP* retval = scalarseq(seq);
+ OP* const retval = scalarseq(seq);
LEAVE_SCOPE(floor);
PL_compiling.op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
if (needblockscope)
return newSVREF(newGVOP(OP_GV, 0, PL_defgv));
}
else {
- OP *o = newOP(OP_PADSV, 0);
+ OP * const o = newOP(OP_PADSV, 0);
o->op_targ = offset;
return o;
}
/* Register with debugger */
if (PERLDB_INTER) {
- CV *cv = get_cv("DB::postponed", FALSE);
+ CV * const cv = get_cv("DB::postponed", FALSE);
if (cv) {
dSP;
PUSHMARK(SP);
;
#endif
else {
- if (ckWARN(WARN_PARENTHESIS)
- && PL_bufptr > PL_oldbufptr && PL_bufptr[-1] == ',')
+ if ( PL_bufptr > PL_oldbufptr && PL_bufptr[-1] == ','
+ && ckWARN(WARN_PARENTHESIS))
{
char *s = PL_bufptr;
bool sigil = FALSE;
/* XXX might want a ck_negate() for this */
cUNOPo->op_first->op_private &= ~OPpCONST_STRICT;
break;
- case OP_SPRINTF:
case OP_UCFIRST:
case OP_LCFIRST:
case OP_UC:
listop->op_first = first;
listop->op_last = last;
if (type == OP_LIST) {
- OP* pushop;
- pushop = newOP(OP_PUSHMARK, 0);
+ OP* const pushop = newOP(OP_PUSHMARK, 0);
pushop->op_sibling = first;
listop->op_first = pushop;
listop->op_flags |= OPf_KIDS;
unop->op_type = (OPCODE)type;
unop->op_ppaddr = PL_ppaddr[type];
unop->op_first = first;
- unop->op_flags = flags | OPf_KIDS;
+ unop->op_flags = (U8)(flags | OPf_KIDS);
unop->op_private = (U8)(1 | (flags >> 8));
unop = (UNOP*) CHECKOP(type, unop);
if (unop->op_next)
binop->op_type = (OPCODE)type;
binop->op_ppaddr = PL_ppaddr[type];
binop->op_first = first;
- binop->op_flags = flags | OPf_KIDS;
+ binop->op_flags = (U8)(flags | OPf_KIDS);
if (!last) {
last = first;
binop->op_private = (U8)(1 | (flags >> 8));
OP *
Perl_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
{
- SV *tstr = ((SVOP*)expr)->op_sv;
- SV *rstr = ((SVOP*)repl)->op_sv;
+ SV * const tstr = ((SVOP*)expr)->op_sv;
+ SV * const rstr = ((SVOP*)repl)->op_sv;
STRLEN tlen;
STRLEN rlen;
const U8 *t = (U8*)SvPV_const(tstr, tlen);
const U8 *r = (U8*)SvPV_const(rstr, rlen);
register I32 i;
register I32 j;
- I32 del;
- I32 complement;
- I32 squash;
I32 grows = 0;
register short *tbl;
+ const I32 complement = o->op_private & OPpTRANS_COMPLEMENT;
+ const I32 squash = o->op_private & OPpTRANS_SQUASH;
+ I32 del = o->op_private & OPpTRANS_DELETE;
PL_hints |= HINT_BLOCK_SCOPE;
- complement = o->op_private & OPpTRANS_COMPLEMENT;
- del = o->op_private & OPpTRANS_DELETE;
- squash = o->op_private & OPpTRANS_SQUASH;
if (SvUTF8(tstr))
o->op_private |= OPpTRANS_FROM_UTF;
o->op_private |= OPpTRANS_TO_UTF;
if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
- SV* listsv = newSVpvn("# comment\n",10);
+ SV* const listsv = newSVpvn("# comment\n",10);
SV* transv = 0;
const U8* tend = t + tlen;
const U8* rend = r + rlen;
I32 bits;
I32 havefinal = 0;
U32 final = 0;
- I32 from_utf = o->op_private & OPpTRANS_FROM_UTF;
- I32 to_utf = o->op_private & OPpTRANS_TO_UTF;
+ const I32 from_utf = o->op_private & OPpTRANS_FROM_UTF;
+ const I32 to_utf = o->op_private & OPpTRANS_TO_UTF;
U8* tsave = NULL;
U8* rsave = NULL;
j = rlen - 1;
else
cPVOPo->op_pv = (char*)Renew(tbl, 0x101+rlen-j, short);
- tbl[0x100] = rlen - j;
+ tbl[0x100] = (short)(rlen - j);
for (i=0; i < (I32)rlen - j; i++)
tbl[0x101+i] = r[j+i];
}
pmop->op_pmflags = pmop->op_pmpermflags;
#ifdef USE_ITHREADS
- {
- SV* repointer;
- if(av_len((AV*) PL_regex_pad[0]) > -1) {
- repointer = av_pop((AV*)PL_regex_pad[0]);
- pmop->op_pmoffset = SvIV(repointer);
- SvREPADTMP_off(repointer);
- sv_setiv(repointer,0);
- } else {
- repointer = newSViv(0);
- av_push(PL_regex_padav,SvREFCNT_inc(repointer));
- pmop->op_pmoffset = av_len(PL_regex_padav);
- PL_regex_pad = AvARRAY(PL_regex_padav);
- }
+ if (av_len((AV*) PL_regex_pad[0]) > -1) {
+ SV * const repointer = av_pop((AV*)PL_regex_pad[0]);
+ pmop->op_pmoffset = SvIV(repointer);
+ SvREPADTMP_off(repointer);
+ sv_setiv(repointer,0);
+ } else {
+ SV * const repointer = newSViv(0);
+ av_push(PL_regex_padav,SvREFCNT_inc(repointer));
+ pmop->op_pmoffset = av_len(PL_regex_padav);
+ PL_regex_pad = AvARRAY(PL_regex_padav);
}
#endif
cLISTOPx(expr)->op_first->op_sibling == cLISTOPx(expr)->op_last)
{
/* convert single element list to element */
- OP* oe = expr;
+ OP* const oe = expr;
expr = cLISTOPx(oe)->op_first->op_sibling;
cLISTOPx(oe)->op_first->op_sibling = Nullop;
cLISTOPx(oe)->op_last = Nullop;
veop = Nullop;
- if (version != Nullop) {
- SV *vesv = ((SVOP*)version)->op_sv;
+ if (version) {
+ SV * const vesv = ((SVOP*)version)->op_sv;
- if (arg == Nullop && !SvNIOKp(vesv)) {
+ if (!arg && !SvNIOKp(vesv)) {
arg = version;
}
else {
imop = arg; /* no import on explicit () */
else if (SvNIOKp(((SVOP*)idop)->op_sv)) {
imop = Nullop; /* use 5.0; */
+ if (!aver)
+ idop->op_private |= OPpCONST_NOVER;
}
else {
SV *meth;
void
Perl_vload_module(pTHX_ U32 flags, SV *name, SV *ver, va_list *args)
{
- OP *modname, *veop, *imop;
+ OP *veop, *imop;
- modname = newSVOP(OP_CONST, 0, name);
+ OP * const modname = newSVOP(OP_CONST, 0, name);
modname->op_private |= OPpCONST_BARE;
if (ver) {
veop = newSVOP(OP_CONST, 0, ver);
}
OP *
-Perl_dofile(pTHX_ OP *term)
+Perl_dofile(pTHX_ OP *term, I32 force_builtin)
{
OP *doop;
- GV *gv;
+ GV *gv = Nullgv;
- gv = gv_fetchpv("do", FALSE, SVt_PVCV);
- if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv)))
- gv = gv_fetchpv("CORE::GLOBAL::do", FALSE, SVt_PVCV);
+ if (!force_builtin) {
+ gv = gv_fetchpv("do", FALSE, SVt_PVCV);
+ if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
+ GV * const * const gvp = (GV**)hv_fetch(PL_globalstash, "do", 2, FALSE);
+ gv = gvp ? *gvp : Nullgv;
+ }
+ }
if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
doop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
/* Result of assignment is always 1 (or we'd be dead already) */
return newSVOP(OP_CONST, 0, newSViv(1));
}
- /* optimise C<my @x = ()> to C<my @x>, and likewise for hashes */
- if ((left->op_type == OP_PADAV || left->op_type == OP_PADHV)
- && right->op_type == OP_STUB
- && (left->op_private & OPpLVAL_INTRO))
- {
- op_free(right);
- left->op_flags &= ~(OPf_REF|OPf_SPECIAL);
- return left;
- }
curop = list(force_list(left));
o = newBINOP(OP_AASSIGN, flags, list(force_list(right)), curop);
o->op_private = (U8)(0 | (flags >> 8));
if ((tmpop = ((LISTOP*)right)->op_first) &&
tmpop->op_type == OP_PUSHRE)
{
- PMOP *pm = (PMOP*)tmpop;
+ PMOP * const pm = (PMOP*)tmpop;
if (left->op_type == OP_RV2AV &&
!(left->op_private & OPpLVAL_INTRO) &&
!(o->op_private & OPpASSIGN_COMMON) )
CopSTASH_set(cop, PL_curstash);
if (PERLDB_LINE && PL_curstash != PL_debstash) {
- SV **svp = av_fetch(CopFILEAV(PL_curcop), (I32)CopLINE(cop), FALSE);
- if (svp && *svp != &PL_sv_undef ) {
- (void)SvIOK_on(*svp);
+ SV * const * const svp = av_fetch(CopFILEAV(PL_curcop), (I32)CopLINE(cop), FALSE);
+ if (svp && *svp != &PL_sv_undef ) {
+ (void)SvIOK_on(*svp);
SvIV_set(*svp, PTR2IV(cop));
}
}
LOGOP *logop;
OP *o;
OP *first = *firstp;
- OP *other = *otherp;
+ OP * const other = *otherp;
if (type == OP_XOR) /* Not short circuit, but here by precedence. */
return newBINOP(type, flags, scalar(first), scalar(other));
if (first->op_type == OP_CONST) {
if (first->op_private & OPpCONST_STRICT)
no_bareword_allowed(first);
- else if (ckWARN(WARN_BAREWORD) && (first->op_private & OPpCONST_BARE))
+ else if ((first->op_private & OPpCONST_BARE) && ckWARN(WARN_BAREWORD))
Perl_warner(aTHX_ packWARN(WARN_BAREWORD), "Bareword found in conditional");
if ((type == OP_AND && SvTRUE(((SVOP*)first)->op_sv)) ||
(type == OP_OR && !SvTRUE(((SVOP*)first)->op_sv)) ||
return first;
}
}
- else if (ckWARN(WARN_MISC) && (first->op_flags & OPf_KIDS) &&
- type != OP_DOR) /* [#24076] Don't warn for <FH> err FOO. */
+ else if ((first->op_flags & OPf_KIDS) && type != OP_DOR
+ && ckWARN(WARN_MISC)) /* [#24076] Don't warn for <FH> err FOO. */
{
- const OP *k1 = ((UNOP*)first)->op_first;
- const OP *k2 = k1->op_sibling;
+ const OP * const k1 = ((UNOP*)first)->op_first;
+ const OP * const k2 = k1->op_sibling;
OPCODE warnop = 0;
switch (first->op_type)
{
logop->op_type = (OPCODE)type;
logop->op_ppaddr = PL_ppaddr[type];
logop->op_first = first;
- logop->op_flags = flags | OPf_KIDS;
+ logop->op_flags = (U8)(flags | OPf_KIDS);
logop->op_other = LINKLIST(other);
logop->op_private = (U8)(1 | (flags >> 8));
scalarboolean(first);
if (first->op_type == OP_CONST) {
if (first->op_private & OPpCONST_BARE &&
- first->op_private & OPpCONST_STRICT) {
- no_bareword_allowed(first);
- }
+ first->op_private & OPpCONST_STRICT) {
+ no_bareword_allowed(first);
+ }
if (SvTRUE(((SVOP*)first)->op_sv)) {
op_free(first);
op_free(falseop);
logop->op_type = OP_COND_EXPR;
logop->op_ppaddr = PL_ppaddr[OP_COND_EXPR];
logop->op_first = first;
- logop->op_flags = flags | OPf_KIDS;
+ logop->op_flags = (U8)(flags | OPf_KIDS);
logop->op_private = (U8)(1 | (flags >> 8));
logop->op_other = LINKLIST(trueop);
logop->op_next = LINKLIST(falseop);
OP* o;
const bool once = block && block->op_flags & OPf_SPECIAL &&
(block->op_type == OP_ENTERSUB || block->op_type == OP_NULL);
- (void)debuggable;
+
+ PERL_UNUSED_ARG(debuggable);
if (expr) {
if (once && expr->op_type == OP_CONST && !SvTRUE(((SVOP*)expr)->op_sv))
expr = newUNOP(OP_DEFINED, 0,
newASSIGNOP(0, newDEFSVOP(), 0, expr) );
} else if (expr->op_flags & OPf_KIDS) {
- const OP *k1 = ((UNOP*)expr)->op_first;
- const OP *k2 = (k1) ? k1->op_sibling : NULL;
+ const OP * const k1 = ((UNOP*)expr)->op_first;
+ const OP * const k2 = k1 ? k1->op_sibling : NULL;
switch (expr->op_type) {
case OP_NULL:
if (k2 && k2->op_type == OP_READLINE
OP *listop;
OP *o;
U8 loopflags = 0;
- (void)debuggable;
-
- if (expr && (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
- || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB))) {
- expr = newUNOP(OP_DEFINED, 0,
- newASSIGNOP(0, newDEFSVOP(), 0, expr) );
- } else if (expr && (expr->op_flags & OPf_KIDS)) {
- const OP *k1 = ((UNOP*)expr)->op_first;
- const OP *k2 = (k1) ? k1->op_sibling : NULL;
- switch (expr->op_type) {
- case OP_NULL:
- if (k2 && k2->op_type == OP_READLINE
- && (k2->op_flags & OPf_STACKED)
- && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
- expr = newUNOP(OP_DEFINED, 0, expr);
- break;
- case OP_SASSIGN:
- if (k1->op_type == OP_READDIR
- || k1->op_type == OP_GLOB
- || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
- || k1->op_type == OP_EACH)
- expr = newUNOP(OP_DEFINED, 0, expr);
- break;
+ PERL_UNUSED_ARG(debuggable);
+
+ if (expr) {
+ if (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
+ || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
+ expr = newUNOP(OP_DEFINED, 0,
+ newASSIGNOP(0, newDEFSVOP(), 0, expr) );
+ } else if (expr->op_flags & OPf_KIDS) {
+ const OP * const k1 = ((UNOP*)expr)->op_first;
+ const OP * const k2 = (k1) ? k1->op_sibling : NULL;
+ switch (expr->op_type) {
+ case OP_NULL:
+ if (k2 && k2->op_type == OP_READLINE
+ && (k2->op_flags & OPf_STACKED)
+ && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
+ expr = newUNOP(OP_DEFINED, 0, expr);
+ break;
+
+ case OP_SASSIGN:
+ if (k1->op_type == OP_READDIR
+ || k1->op_type == OP_GLOB
+ || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
+ || k1->op_type == OP_EACH)
+ expr = newUNOP(OP_DEFINED, 0, expr);
+ break;
+ }
}
}
next = LINKLIST(cont);
}
if (expr) {
- OP *unstack = newOP(OP_UNSTACK, 0);
+ OP * const unstack = newOP(OP_UNSTACK, 0);
if (!next)
next = unstack;
cont = append_elem(OP_LINESEQ, cont, unstack);
* set the STACKED flag to indicate that these values are to be
* treated as min/max values by 'pp_iterinit'.
*/
- UNOP* flip = (UNOP*)((UNOP*)((BINOP*)expr)->op_first)->op_first;
- LOGOP* range = (LOGOP*) flip->op_first;
+ UNOP* const flip = (UNOP*)((UNOP*)((BINOP*)expr)->op_first)->op_first;
+ LOGOP* const range = (LOGOP*) flip->op_first;
OP* const left = range->op_first;
OP* const right = left->op_sibling;
LISTOP* listop;
Perl_cv_ckproto(pTHX_ const CV *cv, const GV *gv, const char *p)
{
if (((!p != !SvPOK(cv)) || (p && strNE(p, SvPVX_const(cv)))) && ckWARN_d(WARN_PROTOTYPE)) {
- SV* msg = sv_newmortal();
+ SV* const msg = sv_newmortal();
SV* name = Nullsv;
if (gv)
o = cLISTOPo->op_first->op_sibling;
for (; o; o = o->op_next) {
- OPCODE type = o->op_type;
+ const OPCODE type = o->op_type;
if (sv && o->op_next == o)
return sv;
void
Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
{
- (void)floor;
+ PERL_UNUSED_ARG(floor);
+
if (o)
SAVEFREEOP(o);
if (proto)
ps = Nullch;
if (!name && PERLDB_NAMEANON && CopLINE(PL_curcop)) {
- SV *sv = sv_newmortal();
+ SV * const sv = sv_newmortal();
Perl_sv_setpvf(aTHX_ sv, "%s[%s:%"IVdf"]",
PL_curstash ? "__ANON__" : "__ANON__::__ANON__",
CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
SAVEFREESV(PL_compcv);
goto done;
}
- /* ahem, death to those who redefine active sort subs */
- if (PL_curstackinfo->si_type == PERLSI_SORT && PL_sortcop == CvSTART(cv))
- Perl_croak(aTHX_ "Can't redefine active sort subroutine %s", name);
if (block) {
if (ckWARN(WARN_REDEFINE)
|| (CvCONST(cv)
if (name || aname) {
const char *s;
- const char *tname = (name ? name : aname);
+ const char * const tname = (name ? name : aname);
if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
- SV *sv = NEWSV(0,0);
- SV *tmpstr = sv_newmortal();
- GV *db_postponed = gv_fetchpv("DB::postponed", GV_ADDMULTI, SVt_PVHV);
- CV *pcv;
+ SV * const sv = NEWSV(0,0);
+ SV * const tmpstr = sv_newmortal();
+ GV * const db_postponed = gv_fetchpv("DB::postponed", GV_ADDMULTI, SVt_PVHV);
HV *hv;
Perl_sv_setpvf(aTHX_ sv, "%s:%ld-%ld",
gv_efullname3(tmpstr, gv, Nullch);
hv_store(GvHV(PL_DBsub), SvPVX_const(tmpstr), SvCUR(tmpstr), sv, 0);
hv = GvHVn(db_postponed);
- if (HvFILL(hv) > 0 && hv_exists(hv, SvPVX_const(tmpstr), SvCUR(tmpstr))
- && (pcv = GvCV(db_postponed)))
- {
- dSP;
- PUSHMARK(SP);
- XPUSHs(tmpstr);
- PUTBACK;
- call_sv((SV*)pcv, G_DISCARD);
+ if (HvFILL(hv) > 0 && hv_exists(hv, SvPVX_const(tmpstr), SvCUR(tmpstr))) {
+ CV * const pcv = GvCV(db_postponed);
+ if (pcv) {
+ dSP;
+ PUSHMARK(SP);
+ XPUSHs(tmpstr);
+ PUTBACK;
+ call_sv((SV*)pcv, G_DISCARD);
+ }
}
}
CvCONST_on(cv);
sv_setpvn((SV*)cv, "", 0); /* prototype is "" */
+#ifdef USE_ITHREADS
if (stash)
CopSTASH_free(PL_curcop);
-
+#endif
LEAVE;
return cv;
CV *
Perl_newXS(pTHX_ const char *name, XSUBADDR_t subaddr, const char *filename)
{
- GV *gv = gv_fetchpv(name ? name :
+ GV * const gv = gv_fetchpv(name ? name :
(PL_curstash ? "__ANON__" : "__ANON__::__ANON__"),
GV_ADDMULTI, SVt_PVCV);
register CV *cv;
Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block)
{
register CV *cv;
- GV *gv;
- if (o)
- gv = gv_fetchsv(cSVOPo->op_sv, TRUE, SVt_PVFM);
- else
- gv = gv_fetchpv("STDOUT", TRUE, SVt_PVFM);
-
+ GV * const gv = o
+ ? gv_fetchsv(cSVOPo->op_sv, TRUE, SVt_PVFM)
+ : gv_fetchpv("STDOUT", TRUE, SVt_PVFM);
+
#ifdef GV_UNIQUE_CHECK
if (GvUNIQUE(gv)) {
Perl_croak(aTHX_ "Bad symbol for form (GV is unique)");
}
OP *
-Perl_oopsCV(pTHX_ OP *o)
-{
- Perl_croak(aTHX_ "NOT IMPL LINE %d",__LINE__);
- /* STUB */
- (void)o;
- NORETURN_FUNCTION_END;
-}
-
-OP *
Perl_newCVREF(pTHX_ I32 flags, OP *o)
{
return newUNOP(OP_RV2CV, flags, scalar(o));
OP *
Perl_ck_concat(pTHX_ OP *o)
{
- const OP *kid = cUNOPo->op_first;
+ const OP * const kid = cUNOPo->op_first;
if (kid->op_type == OP_CONCAT && !(kid->op_private & OPpTARGET_MY) &&
!(kUNOP->op_first->op_flags & OPf_MOD))
o->op_flags |= OPf_STACKED;
o = ck_fun(o);
o->op_private = 0;
if (o->op_flags & OPf_KIDS) {
- OP *kid = cUNOPo->op_first;
+ OP * const kid = cUNOPo->op_first;
switch (kid->op_type) {
case OP_ASLICE:
o->op_flags |= OPf_SPECIAL;
dVAR;
PL_hints |= HINT_BLOCK_SCOPE;
if (o->op_flags & OPf_KIDS) {
- SVOP *kid = (SVOP*)cUNOPo->op_first;
+ SVOP * const kid = (SVOP*)cUNOPo->op_first;
if (!kid) {
o->op_flags &= ~OPf_KIDS;
Perl_ck_exit(pTHX_ OP *o)
{
#ifdef VMS
- HV *table = GvHV(PL_hintgv);
+ HV * const table = GvHV(PL_hintgv);
if (table) {
- SV **svp = hv_fetch(table, "vmsish_exit", 11, FALSE);
+ SV * const * const svp = hv_fetch(table, "vmsish_exit", 11, FALSE);
if (svp && *svp && SvTRUE(*svp))
o->op_private |= OPpEXIT_VMSISH;
}
{
o = ck_fun(o);
if (o->op_flags & OPf_KIDS) {
- OP *kid = cUNOPo->op_first;
+ OP * const kid = cUNOPo->op_first;
if (kid->op_type == OP_ENTERSUB) {
(void) ref(kid, o->op_type);
if (kid->op_type != OP_RV2CV && !PL_error_count)
Perl_ck_rvconst(pTHX_ register OP *o)
{
dVAR;
- SVOP *kid = (SVOP*)cUNOPo->op_first;
+ SVOP * const kid = (SVOP*)cUNOPo->op_first;
o->op_private |= (PL_hints & HINT_STRICT_REFS);
if (kid->op_type == OP_CONST) {
/* Is it a constant from cv_const_sv()? */
if (SvROK(kidsv) && SvREADONLY(kidsv)) {
- SV *rsv = SvRV(kidsv);
+ SV * const rsv = SvRV(kidsv);
const int svtype = SvTYPE(rsv);
const char *badtype = Nullch;
/* nothing */
}
else if (o->op_flags & OPf_KIDS && cUNOPo->op_first->op_type != OP_STUB) {
- SVOP *kid = (SVOP*)cUNOPo->op_first;
+ SVOP * const kid = (SVOP*)cUNOPo->op_first;
if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
- OP *newop = newGVOP(type, OPf_REF,
+ OP * const newop = newGVOP(type, OPf_REF,
gv_fetchsv(kid->op_sv, TRUE, SVt_PVIO));
op_free(o);
o = newop;
if (kid->op_type == OP_CONST &&
(kid->op_private & OPpCONST_BARE))
{
- OP *newop = newAVREF(newGVOP(OP_GV, 0,
+ OP * const newop = newAVREF(newGVOP(OP_GV, 0,
gv_fetchsv(((SVOP*)kid)->op_sv, TRUE, SVt_PVAV) ));
if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
if (kid->op_type == OP_CONST &&
(kid->op_private & OPpCONST_BARE))
{
- OP *newop = newHVREF(newGVOP(OP_GV, 0,
+ OP * const newop = newHVREF(newGVOP(OP_GV, 0,
gv_fetchsv(((SVOP*)kid)->op_sv, TRUE, SVt_PVHV) ));
if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
break;
case OA_CVREF:
{
- OP *newop = newUNOP(OP_NULL, 0, kid);
+ OP * const newop = newUNOP(OP_NULL, 0, kid);
kid->op_sibling = 0;
linklist(kid);
newop->op_next = newop;
if (kid->op_type == OP_CONST &&
(kid->op_private & OPpCONST_BARE))
{
- OP *newop = newGVOP(OP_GV, 0,
+ OP * const newop = newGVOP(OP_GV, 0,
gv_fetchsv(((SVOP*)kid)->op_sv, TRUE, SVt_PVIO) );
if (!(o->op_private & 1) && /* if not unop */
kid == cLISTOPo->op_last)
else if (kid->op_type == OP_RV2SV
&& kUNOP->op_first->op_type == OP_GV)
{
- GV *gv = cGVOPx_gv(kUNOP->op_first);
+ GV * const gv = cGVOPx_gv(kUNOP->op_first);
name = GvNAME(gv);
len = GvNAMELEN(gv);
}
else if (kid->op_type == OP_AELEM
|| kid->op_type == OP_HELEM)
{
- OP *op;
-
+ OP *op = ((BINOP*)kid)->op_first;
name = 0;
- if ((op = ((BINOP*)kid)->op_first)) {
+ if (op) {
SV *tmpstr = Nullsv;
- const char *a =
+ const char * const a =
kid->op_type == OP_AELEM ?
"[]" : "{}";
if (((op->op_type == OP_RV2AV) ||
(op = ((UNOP*)op)->op_first) &&
(op->op_type == OP_GV)) {
/* packagevar $a[] or $h{} */
- GV *gv = cGVOPx_gv(op);
+ GV * const gv = cGVOPx_gv(op);
if (gv)
tmpstr =
Perl_newSVpvf(aTHX_
else if (op->op_type == OP_PADAV
|| op->op_type == OP_PADHV) {
/* lexicalvar $a[] or $h{} */
- const char *padname =
+ const char * const padname =
PAD_COMPNAME_PV(op->op_targ);
if (padname)
tmpstr =
"%s%c...%c",
padname + 1,
a[0], a[1]);
-
}
if (tmpstr) {
name = SvPV_const(tmpstr, len);
/* Cannot steal the second time! */
&& !(kid->op_private & OPpTARGET_MY))
{
- OP *kkid = kid->op_sibling;
+ OP * const kkid = kid->op_sibling;
/* Can just relocate the target. */
if (kkid && kkid->op_type == OP_PADSV
return kid;
}
}
- /* optimise C<my $x = undef> to C<my $x> */
- if (kid->op_type == OP_UNDEF) {
- OP *kkid = kid->op_sibling;
- if (kkid && kkid->op_type == OP_PADSV
- && (kkid->op_private & OPpLVAL_INTRO))
- {
- cLISTOPo->op_first = NULL;
- kid->op_sibling = NULL;
- op_free(o);
- op_free(kid);
- return kkid;
- }
- }
return o;
}
OP *
Perl_ck_method(pTHX_ OP *o)
{
- OP *kid = cUNOPo->op_first;
+ OP * const kid = cUNOPo->op_first;
if (kid->op_type == OP_CONST) {
SV* sv = kSVOP->op_sv;
if (!(strchr(SvPVX_const(sv), ':') || strchr(SvPVX_const(sv), '\''))) {
OP *
Perl_ck_open(pTHX_ OP *o)
{
- HV *table = GvHV(PL_hintgv);
+ HV * const table = GvHV(PL_hintgv);
if (table) {
- SV **svp;
- I32 mode;
- svp = hv_fetch(table, "open_IN", 7, FALSE);
+ SV **svp = hv_fetch(table, "open_IN", 7, FALSE);
if (svp && *svp) {
- mode = mode_from_discipline(*svp);
+ const I32 mode = mode_from_discipline(*svp);
if (mode & O_BINARY)
o->op_private |= OPpOPEN_IN_RAW;
else if (mode & O_TEXT)
svp = hv_fetch(table, "open_OUT", 8, FALSE);
if (svp && *svp) {
- mode = mode_from_discipline(*svp);
+ const I32 mode = mode_from_discipline(*svp);
if (mode & O_BINARY)
o->op_private |= OPpOPEN_OUT_RAW;
else if (mode & O_TEXT)
{
/* In case of three-arg dup open remove strictness
* from the last arg if it is a bareword. */
- OP *first = cLISTOPx(o)->op_first; /* The pushmark. */
- OP *last = cLISTOPx(o)->op_last; /* The bareword. */
+ OP * const first = cLISTOPx(o)->op_first; /* The pushmark. */
+ OP * const last = cLISTOPx(o)->op_last; /* The bareword. */
OP *oa;
const char *mode;
(last->op_private & OPpCONST_STRICT) &&
(oa = first->op_sibling) && /* The fh. */
(oa = oa->op_sibling) && /* The mode. */
+ (oa->op_type == OP_CONST) &&
SvPOK(((SVOP*)oa)->op_sv) &&
(mode = SvPVX_const(((SVOP*)oa)->op_sv)) &&
mode[0] == '>' && mode[1] == '&' && /* A dup open. */
OP *
Perl_ck_require(pTHX_ OP *o)
{
- GV* gv;
+ GV* gv = Nullgv;
if (o->op_flags & OPf_KIDS) { /* Shall we supply missing .pm? */
- SVOP *kid = (SVOP*)cUNOPo->op_first;
+ SVOP * const kid = (SVOP*)cUNOPo->op_first;
if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
- SV *sv = kid->op_sv;
+ SV * const sv = kid->op_sv;
U32 was_readonly = SvREADONLY(sv);
char *s;
for (s = SvPVX(sv); *s; s++) {
if (*s == ':' && s[1] == ':') {
+ const STRLEN len = strlen(s+2)+1;
*s = '/';
- Move(s+2, s+1, strlen(s+2)+1, char);
+ Move(s+2, s+1, len, char);
SvCUR_set(sv, SvCUR(sv) - 1);
}
}
}
}
- /* handle override, if any */
- gv = gv_fetchpv("require", FALSE, SVt_PVCV);
- if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv)))
- gv = gv_fetchpv("CORE::GLOBAL::require", FALSE, SVt_PVCV);
+ if (!(o->op_flags & OPf_SPECIAL)) { /* Wasn't written as CORE::require */
+ /* handle override, if any */
+ gv = gv_fetchpv("require", FALSE, SVt_PVCV);
+ if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
+ GV * const * const gvp = (GV**)hv_fetch(PL_globalstash, "require", 7, FALSE);
+ gv = gvp ? *gvp : Nullgv;
+ }
+ }
if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
- OP *kid = cUNOPo->op_first;
+ OP * const kid = cUNOPo->op_first;
cUNOPo->op_first = 0;
op_free(o);
return ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
return o;
}
-#if 0
-OP *
-Perl_ck_retarget(pTHX_ OP *o)
-{
- Perl_croak(aTHX_ "NOT IMPL LINE %d",__LINE__);
- /* STUB */
- return o;
-}
-#endif
-
OP *
Perl_ck_select(pTHX_ OP *o)
{
}
if (kid->op_type != OP_MATCH || kid->op_flags & OPf_STACKED) {
- OP *sibl = kid->op_sibling;
+ OP * const sibl = kid->op_sibling;
kid->op_sibling = 0;
kid = pmruntime( newPMOP(OP_MATCH, OPf_SPECIAL), kid, 0);
if (cLISTOPo->op_first == cLISTOPo->op_last)
kid->op_type = OP_PUSHRE;
kid->op_ppaddr = PL_ppaddr[OP_PUSHRE];
scalar(kid);
- if (ckWARN(WARN_REGEXP) && ((PMOP *)kid)->op_pmflags & PMf_GLOBAL) {
+ if (((PMOP *)kid)->op_pmflags & PMf_GLOBAL && ckWARN(WARN_REGEXP)) {
Perl_warner(aTHX_ packWARN(WARN_REGEXP),
"Use of /g modifier is meaningless in split");
}
OP *
Perl_ck_join(pTHX_ OP *o)
{
- if (ckWARN(WARN_SYNTAX)) {
- const OP *kid = cLISTOPo->op_first->op_sibling;
- if (kid && kid->op_type == OP_MATCH) {
+ const OP * const kid = cLISTOPo->op_first->op_sibling;
+ if (kid && kid->op_type == OP_MATCH) {
+ if (ckWARN(WARN_SYNTAX)) {
const REGEXP *re = PM_GETRE(kPMOP);
const char *pmstr = re ? re->precomp : "STRING";
Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
}
else {
delete_op = 1;
- if (ckWARN(WARN_ASSERTIONS) && !(PL_hints & HINT_ASSERTIONSSEEN)) {
+ if (!(PL_hints & HINT_ASSERTIONSSEEN) && ckWARN(WARN_ASSERTIONS)) {
Perl_warner(aTHX_ packWARN(WARN_ASSERTIONS),
"Impossible to activate assertion call");
}
if (o2->op_type == OP_CONST)
o2->op_private &= ~OPpCONST_STRICT;
else if (o2->op_type == OP_LIST) {
- OP *o = ((UNOP*)o2)->op_first->op_sibling;
+ OP * const o = ((UNOP*)o2)->op_first->op_sibling;
if (o && o->op_type == OP_CONST)
o->op_private &= ~OPpCONST_STRICT;
}
(gvop = ((UNOP*)gvop)->op_first) &&
gvop->op_type == OP_GV)
{
- GV *gv = cGVOPx_gv(gvop);
- OP *sibling = o2->op_sibling;
- SV *n = newSVpvn("",0);
+ GV * const gv = cGVOPx_gv(gvop);
+ OP * const sibling = o2->op_sibling;
+ SV * const n = newSVpvn("",0);
op_free(o2);
gv_fullname4(n, gv, "", FALSE);
o2 = newSVOP(OP_CONST, 0, n);
break;
case ']':
if (contextclass) {
+ /* XXX We shouldn't be modifying proto, so we can const proto */
char *p = proto;
const char s = *p;
contextclass = 0;
break;
wrapref:
{
- OP* kid = o2;
- OP* sib = kid->op_sibling;
+ OP* const kid = o2;
+ OP* const sib = kid->op_sibling;
kid->op_sibling = 0;
o2 = newUNOP(OP_REFGEN, 0, kid);
o2->op_sibling = sib;
mod(o2, OP_ENTERSUB);
prev = o2;
o2 = o2->op_sibling;
- }
+ } /* while */
if (proto && !optional &&
(*proto && *proto != '@' && *proto != '%' && *proto != ';'))
return too_few_arguments(o, gv_ename(namegv));
case OP_PADAV:
case OP_GV:
if (o->op_type == OP_PADAV || o->op_next->op_type == OP_RV2AV) {
- OP* pop = (o->op_type == OP_PADAV) ?
+ OP* const pop = (o->op_type == OP_PADAV) ?
o->op_next : o->op_next->op_next;
IV i;
if (pop && pop->op_type == OP_CONST &&
}
}
else if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) {
- GV *gv = cGVOPo_gv;
+ GV * const gv = cGVOPo_gv;
if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX_const(GvCV(gv))) {
/* XXX could check prototype here instead of just carping */
- SV *sv = sv_newmortal();
+ SV * const sv = sv_newmortal();
gv_efullname3(sv, gv, Nullch);
Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
"%"SVf"() called too early to check prototype",
case OP_EXEC:
o->op_opt = 1;
- if (ckWARN(WARN_SYNTAX) && o->op_next
- && o->op_next->op_type == OP_NEXTSTATE) {
+ if (o->op_next && o->op_next->op_type == OP_NEXTSTATE
+ && ckWARN(WARN_SYNTAX))
+ {
if (o->op_next->op_sibling &&
o->op_next->op_sibling->op_type != OP_EXIT &&
o->op_next->op_sibling->op_type != OP_WARN &&
case OP_SORT: {
/* will point to RV2AV or PADAV op on LHS/RHS of assign */
- OP *oleft, *oright;
+ OP *oleft;
OP *o2;
/* check that RHS of sort is a single plain array */
- oright = cUNOPo->op_first;
+ OP *oright = cUNOPo->op_first;
if (!oright || oright->op_type != OP_PUSHMARK)
break;
/* reverse sort ... can be optimised. */
if (!cUNOPo->op_sibling) {
/* Nothing follows us on the list. */
- OP *reverse = o->op_next;
+ OP * const reverse = o->op_next;
if (reverse->op_type == OP_REVERSE &&
(reverse->op_flags & OPf_WANT) == OPf_WANT_LIST) {
- OP *pushmark = cUNOPx(reverse)->op_first;
+ OP * const pushmark = cUNOPx(reverse)->op_first;
if (pushmark && (pushmark->op_type == OP_PUSHMARK)
&& (cUNOPx(pushmark)->op_sibling == o)) {
/* reverse -> pushmark -> sort */
https://perl5.git.perl.org / perl5.git / blobdiff