X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/e5e32358e826544b3081ef44129256ad3c11a406..4e267243e0f1e4a79c99c8aa048aeec9c0d5cd6f:/op.c diff --git a/op.c b/op.c index 3d2404c..304150c 100644 --- a/op.c +++ b/op.c @@ -1,6 +1,6 @@ /* op.c * - * Copyright (c) 1991-2000, Larry Wall + * Copyright (c) 1991-2001, Larry Wall * * You may distribute under the terms of either the GNU General Public * License or the Artistic License, as specified in the README file. @@ -55,6 +55,7 @@ S_Slab_Alloc(pTHX_ int m, size_t sz) : CALL_FPTR(PL_check[type])(aTHX_ (OP*)o)) #define PAD_MAX 999999999 +#define RETURN_UNLIMITED_NUMBER (PERL_INT_MAX / 2) STATIC char* S_gv_ename(pTHX_ GV *gv) @@ -164,7 +165,7 @@ Perl_pad_allocmy(pTHX_ char *name) SV **svp = AvARRAY(PL_comppad_name); HV *ourstash = (PL_curstash ? PL_curstash : PL_defstash); PADOFFSET top = AvFILLp(PL_comppad_name); - for (off = top; off > PL_comppad_name_floor; off--) { + for (off = top; (I32)off > PL_comppad_name_floor; off--) { if ((sv = svp[off]) && sv != &PL_sv_undef && (SvIVX(sv) == PAD_MAX || SvIVX(sv) == 0) @@ -279,8 +280,8 @@ S_pad_findlex(pTHX_ char *name, PADOFFSET newoff, U32 seq, CV* startcv, for (off = AvFILLp(curname); off > 0; off--) { if ((sv = svp[off]) && sv != &PL_sv_undef && - seq <= SvIVX(sv) && - seq > I_32(SvNVX(sv)) && + seq <= (U32)SvIVX(sv) && + seq > (U32)I_32(SvNVX(sv)) && strEQ(SvPVX(sv), name)) { I32 depth; @@ -371,15 +372,24 @@ S_pad_findlex(pTHX_ char *name, PADOFFSET newoff, U32 seq, CV* startcv, switch (CxTYPE(cx)) { default: if (i == 0 && saweval) { - seq = cxstack[saweval].blk_oldcop->cop_seq; return pad_findlex(name, newoff, seq, PL_main_cv, -1, saweval, 0); } break; case CXt_EVAL: switch (cx->blk_eval.old_op_type) { case OP_ENTEREVAL: - if (CxREALEVAL(cx)) + if (CxREALEVAL(cx)) { + PADOFFSET off; saweval = i; + seq = cxstack[i].blk_oldcop->cop_seq; + startcv = cxstack[i].blk_eval.cv; + if (startcv && CvOUTSIDE(startcv)) { + off = pad_findlex(name, newoff, seq, CvOUTSIDE(startcv), + i-1, saweval, 0); + if (off) /* continue looking if not found here */ + return off; + } + } break; case OP_DOFILE: case OP_REQUIRE: @@ -394,9 +404,9 @@ S_pad_findlex(pTHX_ char *name, PADOFFSET newoff, U32 seq, CV* startcv, cv = cx->blk_sub.cv; if (PL_debstash && CvSTASH(cv) == PL_debstash) { /* ignore DB'* scope */ saweval = i; /* so we know where we were called from */ + seq = cxstack[i].blk_oldcop->cop_seq; continue; } - seq = cxstack[saweval].blk_oldcop->cop_seq; return pad_findlex(name, newoff, seq, cv, i-1, saweval,FINDLEX_NOSEARCH); } } @@ -433,8 +443,8 @@ Perl_pad_findmy(pTHX_ char *name) if ((sv = svp[off]) && sv != &PL_sv_undef && (!SvIVX(sv) || - (seq <= SvIVX(sv) && - seq > I_32(SvNVX(sv)))) && + (seq <= (U32)SvIVX(sv) && + seq > (U32)I_32(SvNVX(sv)))) && strEQ(SvPVX(sv), name)) { if (SvIVX(sv) || SvFLAGS(sv) & SVpad_OUR) @@ -739,7 +749,7 @@ Perl_op_free(pTHX_ OP *o) } type = o->op_type; if (type == OP_NULL) - type = o->op_targ; + type = (OPCODE)o->op_targ; /* COP* is not cleared by op_clear() so that we may track line * numbers etc even after null() */ @@ -798,6 +808,7 @@ S_op_clear(pTHX_ OP *o) cSVOPo->op_sv = Nullsv; #endif break; + case OP_METHOD_NAMED: case OP_CONST: SvREFCNT_dec(cSVOPo->op_sv); cSVOPo->op_sv = Nullsv; @@ -1380,6 +1391,7 @@ Perl_mod(pTHX_ OP *o, I32 type) } else { /* lvalue subroutine call */ o->op_private |= OPpLVAL_INTRO; + PL_modcount = RETURN_UNLIMITED_NUMBER; if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN) { /* Backward compatibility mode: */ o->op_private |= OPpENTERSUB_INARGS; @@ -1514,7 +1526,7 @@ Perl_mod(pTHX_ OP *o, I32 type) if (!type && cUNOPo->op_first->op_type != OP_GV) Perl_croak(aTHX_ "Can't localize through a reference"); if (type == OP_REFGEN && o->op_flags & OPf_PARENS) { - PL_modcount = 10000; + PL_modcount = RETURN_UNLIMITED_NUMBER; return o; /* Treat \(@foo) like ordinary list. */ } /* FALL THROUGH */ @@ -1523,14 +1535,16 @@ Perl_mod(pTHX_ OP *o, I32 type) goto nomod; ref(cUNOPo->op_first, o->op_type); /* FALL THROUGH */ - case OP_AASSIGN: case OP_ASLICE: case OP_HSLICE: + if (type == OP_LEAVESUBLV) + o->op_private |= OPpMAYBE_LVSUB; + /* FALL THROUGH */ + case OP_AASSIGN: case OP_NEXTSTATE: case OP_DBSTATE: - case OP_REFGEN: case OP_CHOMP: - PL_modcount = 10000; + PL_modcount = RETURN_UNLIMITED_NUMBER; break; case OP_RV2SV: if (!type && cUNOPo->op_first->op_type != OP_GV) @@ -1549,11 +1563,13 @@ Perl_mod(pTHX_ OP *o, I32 type) case OP_PADAV: case OP_PADHV: - PL_modcount = 10000; + PL_modcount = RETURN_UNLIMITED_NUMBER; if (type == OP_REFGEN && o->op_flags & OPf_PARENS) return o; /* Treat \(@foo) like ordinary list. */ if (scalar_mod_type(o, type)) goto nomod; + if (type == OP_LEAVESUBLV) + o->op_private |= OPpMAYBE_LVSUB; /* FALL THROUGH */ case OP_PADSV: PL_modcount++; @@ -1581,6 +1597,8 @@ Perl_mod(pTHX_ OP *o, I32 type) /* FALL THROUGH */ case OP_POS: case OP_VEC: + if (type == OP_LEAVESUBLV) + o->op_private |= OPpMAYBE_LVSUB; lvalue_func: pad_free(o->op_targ); o->op_targ = pad_alloc(o->op_type, SVs_PADMY); @@ -1595,12 +1613,15 @@ Perl_mod(pTHX_ OP *o, I32 type) if (type == OP_ENTERSUB && !(o->op_private & (OPpLVAL_INTRO | OPpDEREF))) o->op_private |= OPpLVAL_DEFER; + if (type == OP_LEAVESUBLV) + o->op_private |= OPpMAYBE_LVSUB; PL_modcount++; break; case OP_SCOPE: case OP_LEAVE: case OP_ENTER: + case OP_LINESEQ: if (o->op_flags & OPf_KIDS) mod(cLISTOPo->op_last, type); break; @@ -1619,8 +1640,14 @@ Perl_mod(pTHX_ OP *o, I32 type) for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) mod(kid, type); break; + + case OP_RETURN: + if (type != OP_LEAVESUBLV) + goto nomod; + break; /* mod()ing was handled by ck_return() */ } - o->op_flags |= OPf_MOD; + if (type != OP_LEAVESUBLV) + o->op_flags |= OPf_MOD; if (type == OP_AASSIGN || type == OP_SASSIGN) o->op_flags |= OPf_SPECIAL|OPf_REF; @@ -1629,7 +1656,8 @@ Perl_mod(pTHX_ OP *o, I32 type) o->op_flags &= ~OPf_SPECIAL; PL_hints |= HINT_BLOCK_SCOPE; } - else if (type != OP_GREPSTART && type != OP_ENTERSUB) + else if (type != OP_GREPSTART && type != OP_ENTERSUB + && type != OP_LEAVESUBLV) o->op_flags |= OPf_REF; return o; } @@ -2085,7 +2113,7 @@ Perl_block_end(pTHX_ I32 floor, OP *seq) OP* retval = scalarseq(seq); LEAVE_SCOPE(floor); PL_pad_reset_pending = FALSE; - PL_compiling.op_private = PL_hints; + PL_compiling.op_private = (U8)(PL_hints & HINT_PRIVATE_MASK); if (needblockscope) PL_hints |= HINT_BLOCK_SCOPE; /* propagate out */ pad_leavemy(PL_comppad_name_fill); @@ -2225,8 +2253,8 @@ Perl_fold_constants(pTHX_ register OP *o) case OP_SLE: case OP_SGE: case OP_SCMP: - - if (o->op_private & OPpLOCALE) + /* XXX what about the numeric ops? */ + if (PL_hints & HINT_LOCALE) goto nope; } @@ -2334,7 +2362,6 @@ Perl_gen_constant_list(pTHX_ register OP *o) OP * Perl_convert(pTHX_ I32 type, I32 flags, OP *o) { - OP *kid; OP *last = 0; if (!o || o->op_type != OP_LIST) @@ -2345,7 +2372,7 @@ Perl_convert(pTHX_ I32 type, I32 flags, OP *o) if (!(PL_opargs[type] & OA_MARK)) null(cLISTOPo->op_first); - o->op_type = type; + o->op_type = (OPCODE)type; o->op_ppaddr = PL_ppaddr[type]; o->op_flags |= flags; @@ -2353,13 +2380,6 @@ Perl_convert(pTHX_ I32 type, I32 flags, OP *o) if (o->op_type != type) return o; - if (cLISTOPo->op_children < 7) { - /* XXX do we really need to do this if we're done appending?? */ - for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) - last = kid; - cLISTOPo->op_last = last; /* in case check substituted last arg */ - } - return fold_constants(o); } @@ -2387,7 +2407,6 @@ Perl_append_elem(pTHX_ I32 type, OP *first, OP *last) ((LISTOP*)first)->op_first = last; } ((LISTOP*)first)->op_last = last; - ((LISTOP*)first)->op_children++; return first; } @@ -2408,10 +2427,8 @@ Perl_append_list(pTHX_ I32 type, LISTOP *first, LISTOP *last) first->op_last->op_sibling = last->op_first; first->op_last = last->op_last; - first->op_children += last->op_children; - if (first->op_children) - first->op_flags |= OPf_KIDS; - + first->op_flags |= (last->op_flags & OPf_KIDS); + #ifdef PL_OP_SLAB_ALLOC #else Safefree(last); @@ -2441,7 +2458,7 @@ Perl_prepend_elem(pTHX_ I32 type, OP *first, OP *last) first->op_sibling = ((LISTOP*)last)->op_first; ((LISTOP*)last)->op_first = first; } - ((LISTOP*)last)->op_children++; + last->op_flags |= OPf_KIDS; return last; } @@ -2472,10 +2489,11 @@ Perl_newLISTOP(pTHX_ I32 type, I32 flags, OP *first, OP *last) NewOp(1101, listop, 1, LISTOP); - listop->op_type = type; + listop->op_type = (OPCODE)type; listop->op_ppaddr = PL_ppaddr[type]; - listop->op_children = (first != 0) + (last != 0); - listop->op_flags = flags; + if (first || last) + flags |= OPf_KIDS; + listop->op_flags = (U8)flags; if (!last && first) last = first; @@ -2494,8 +2512,6 @@ Perl_newLISTOP(pTHX_ I32 type, I32 flags, OP *first, OP *last) if (!last) listop->op_last = pushop; } - else if (listop->op_children) - listop->op_flags |= OPf_KIDS; return (OP*)listop; } @@ -2505,12 +2521,12 @@ Perl_newOP(pTHX_ I32 type, I32 flags) { OP *o; NewOp(1101, o, 1, OP); - o->op_type = type; + o->op_type = (OPCODE)type; o->op_ppaddr = PL_ppaddr[type]; - o->op_flags = flags; + o->op_flags = (U8)flags; o->op_next = o; - o->op_private = 0 + (flags >> 8); + o->op_private = (U8)(0 | (flags >> 8)); if (PL_opargs[type] & OA_RETSCALAR) scalar(o); if (PL_opargs[type] & OA_TARGET) @@ -2529,11 +2545,11 @@ Perl_newUNOP(pTHX_ I32 type, I32 flags, OP *first) first = force_list(first); NewOp(1101, unop, 1, UNOP); - unop->op_type = type; + unop->op_type = (OPCODE)type; unop->op_ppaddr = PL_ppaddr[type]; unop->op_first = first; unop->op_flags = flags | OPf_KIDS; - unop->op_private = 1 | (flags >> 8); + unop->op_private = (U8)(1 | (flags >> 8)); unop = (UNOP*) CHECKOP(type, unop); if (unop->op_next) return (OP*)unop; @@ -2550,21 +2566,21 @@ Perl_newBINOP(pTHX_ I32 type, I32 flags, OP *first, OP *last) if (!first) first = newOP(OP_NULL, 0); - binop->op_type = type; + binop->op_type = (OPCODE)type; binop->op_ppaddr = PL_ppaddr[type]; binop->op_first = first; binop->op_flags = flags | OPf_KIDS; if (!last) { last = first; - binop->op_private = 1 | (flags >> 8); + binop->op_private = (U8)(1 | (flags >> 8)); } else { - binop->op_private = 2 | (flags >> 8); + binop->op_private = (U8)(2 | (flags >> 8)); first->op_sibling = last; } binop = (BINOP*)CHECKOP(type, binop); - if (binop->op_next || binop->op_type != type) + if (binop->op_next || binop->op_type != (OPCODE)type) return (OP*)binop; binop->op_last = binop->op_first->op_sibling; @@ -2602,6 +2618,7 @@ Perl_pmtrans(pTHX_ OP *o, OP *expr, OP *repl) I32 grows = 0; register short *tbl; + PL_hints |= HINT_BLOCK_SCOPE; complement = o->op_private & OPpTRANS_COMPLEMENT; del = o->op_private & OPpTRANS_DELETE; squash = o->op_private & OPpTRANS_SQUASH; @@ -2638,7 +2655,6 @@ Perl_pmtrans(pTHX_ OP *o, OP *expr, OP *repl) if (complement) { U8 tmpbuf[UTF8_MAXLEN+1]; U8** cp; - I32* cl; UV nextmin = 0; New(1109, cp, tlen, U8*); i = 0; @@ -2646,7 +2662,7 @@ Perl_pmtrans(pTHX_ OP *o, OP *expr, OP *repl) while (t < tend) { cp[i++] = t; t += UTF8SKIP(t); - if (*t == 0xff) { + if (t < tend && *t == 0xff) { t++; t += UTF8SKIP(t); } @@ -2654,7 +2670,7 @@ Perl_pmtrans(pTHX_ OP *o, OP *expr, OP *repl) qsort(cp, i, sizeof(U8*), utf8compare); for (j = 0; j < i; j++) { U8 *s = cp[j]; - I32 cur = j < i ? cp[j+1] - s : tend - s; + I32 cur = j < i - 1 ? cp[j+1] - s : tend - s; UV val = utf8_to_uv(s, cur, &ulen, 0); s += ulen; diff = val - nextmin; @@ -2667,7 +2683,7 @@ Perl_pmtrans(pTHX_ OP *o, OP *expr, OP *repl) sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf); } } - if (*s == 0xff) + if (s < tend && *s == 0xff) val = utf8_to_uv(s+1, cur - 1, &ulen, 0); if (val >= nextmin) nextmin = val + 1; @@ -2680,6 +2696,7 @@ Perl_pmtrans(pTHX_ OP *o, OP *expr, OP *repl) t = (U8*)SvPVX(transv); tlen = SvCUR(transv); tend = t + tlen; + Safefree(cp); } else if (!rlen && !del) { r = t; rlen = tlen; rend = tend; @@ -2772,6 +2789,7 @@ Perl_pmtrans(pTHX_ OP *o, OP *expr, OP *repl) else bits = 8; + Safefree(cPVOPo->op_pv); cSVOPo->op_sv = (SV*)swash_init("utf8", "", listsv, bits, none); SvREFCNT_dec(listsv); if (transv) @@ -2797,17 +2815,17 @@ Perl_pmtrans(pTHX_ OP *o, OP *expr, OP *repl) tbl = (short*)cPVOPo->op_pv; if (complement) { Zero(tbl, 256, short); - for (i = 0; i < tlen; i++) + for (i = 0; i < (I32)tlen; i++) tbl[t[i]] = -1; for (i = 0, j = 0; i < 256; i++) { if (!tbl[i]) { - if (j >= rlen) { + if (j >= (I32)rlen) { if (del) tbl[i] = -2; else if (rlen) tbl[i] = r[j-1]; else - tbl[i] = i; + tbl[i] = (short)i; } else { if (i < 128 && r[j] >= 128) @@ -2825,8 +2843,8 @@ Perl_pmtrans(pTHX_ OP *o, OP *expr, OP *repl) } for (i = 0; i < 256; i++) tbl[i] = -1; - for (i = 0, j = 0; i < tlen; i++,j++) { - if (j >= rlen) { + for (i = 0, j = 0; i < (I32)tlen; i++,j++) { + if (j >= (I32)rlen) { if (del) { if (tbl[t[i]] == -1) tbl[t[i]] = -2; @@ -2855,10 +2873,10 @@ Perl_newPMOP(pTHX_ I32 type, I32 flags) PMOP *pmop; NewOp(1101, pmop, 1, PMOP); - pmop->op_type = type; + pmop->op_type = (OPCODE)type; pmop->op_ppaddr = PL_ppaddr[type]; - pmop->op_flags = flags; - pmop->op_private = 0 | (flags >> 8); + pmop->op_flags = (U8)flags; + pmop->op_private = (U8)(0 | (flags >> 8)); if (PL_hints & HINT_RE_TAINT) pmop->op_pmpermflags |= PMf_RETAINT; @@ -2941,7 +2959,7 @@ Perl_pmruntime(pTHX_ OP *o, OP *expr, OP *repl) if (pm->op_pmflags & PMf_EVAL) { curop = 0; if (CopLINE(PL_curcop) < PL_multi_end) - CopLINE_set(PL_curcop, PL_multi_end); + CopLINE_set(PL_curcop, (line_t)PL_multi_end); } #ifdef USE_THREADS else if (repl->op_type == OP_THREADSV @@ -3033,11 +3051,11 @@ Perl_newSVOP(pTHX_ I32 type, I32 flags, SV *sv) { SVOP *svop; NewOp(1101, svop, 1, SVOP); - svop->op_type = type; + svop->op_type = (OPCODE)type; svop->op_ppaddr = PL_ppaddr[type]; svop->op_sv = sv; svop->op_next = (OP*)svop; - svop->op_flags = flags; + svop->op_flags = (U8)flags; if (PL_opargs[type] & OA_RETSCALAR) scalar((OP*)svop); if (PL_opargs[type] & OA_TARGET) @@ -3050,14 +3068,14 @@ Perl_newPADOP(pTHX_ I32 type, I32 flags, SV *sv) { PADOP *padop; NewOp(1101, padop, 1, PADOP); - padop->op_type = type; + padop->op_type = (OPCODE)type; padop->op_ppaddr = PL_ppaddr[type]; padop->op_padix = pad_alloc(type, SVs_PADTMP); SvREFCNT_dec(PL_curpad[padop->op_padix]); PL_curpad[padop->op_padix] = sv; SvPADTMP_on(sv); padop->op_next = (OP*)padop; - padop->op_flags = flags; + padop->op_flags = (U8)flags; if (PL_opargs[type] & OA_RETSCALAR) scalar((OP*)padop); if (PL_opargs[type] & OA_TARGET) @@ -3081,11 +3099,11 @@ Perl_newPVOP(pTHX_ I32 type, I32 flags, char *pv) { PVOP *pvop; NewOp(1101, pvop, 1, PVOP); - pvop->op_type = type; + pvop->op_type = (OPCODE)type; pvop->op_ppaddr = PL_ppaddr[type]; pvop->op_pv = pv; pvop->op_next = (OP*)pvop; - pvop->op_flags = flags; + pvop->op_flags = (U8)flags; if (PL_opargs[type] & OA_RETSCALAR) scalar((OP*)pvop); if (PL_opargs[type] & OA_TARGET) @@ -3371,7 +3389,7 @@ Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right) } curop = list(force_list(left)); o = newBINOP(OP_AASSIGN, flags, list(force_list(right)), curop); - o->op_private = 0 | (flags >> 8); + o->op_private = (U8)(0 | (flags >> 8)); for (curop = ((LISTOP*)curop)->op_first; curop; curop = curop->op_sibling) { @@ -3388,7 +3406,7 @@ Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right) if (PL_opargs[curop->op_type] & OA_DANGEROUS) { if (curop->op_type == OP_GV) { GV *gv = cGVOPx_gv(curop); - if (gv == PL_defgv || SvCUR(gv) == PL_generation) + if (gv == PL_defgv || (int)SvCUR(gv) == PL_generation) break; SvCUR(gv) = PL_generation; } @@ -3398,7 +3416,7 @@ Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right) curop->op_type == OP_PADANY) { SV **svp = AvARRAY(PL_comppad_name); SV *sv = svp[curop->op_targ]; - if (SvCUR(sv) == PL_generation) + if ((int)SvCUR(sv) == PL_generation) break; SvCUR(sv) = PL_generation; /* (SvCUR not used any more) */ } @@ -3418,7 +3436,7 @@ Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right) #else GV *gv = (GV*)((PMOP*)curop)->op_pmreplroot; #endif - if (gv == PL_defgv || SvCUR(gv) == PL_generation) + if (gv == PL_defgv || (int)SvCUR(gv) == PL_generation) break; SvCUR(gv) = PL_generation; } @@ -3462,7 +3480,7 @@ Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right) } } else { - if (PL_modcount < 10000 && + if (PL_modcount < RETURN_UNLIMITED_NUMBER && ((LISTOP*)right)->op_last->op_type == OP_CONST) { SV *sv = ((SVOP*)((LISTOP*)right)->op_last)->op_sv; @@ -3509,8 +3527,8 @@ Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o) cop->op_type = OP_NEXTSTATE; cop->op_ppaddr = PL_ppaddr[ OP_NEXTSTATE ]; } - cop->op_flags = flags; - cop->op_private = (PL_hints & HINT_BYTE); + cop->op_flags = (U8)flags; + cop->op_private = (U8)(PL_hints & (HINT_BYTE|HINT_LOCALE)); #ifdef NATIVE_HINTS cop->op_private |= NATIVE_HINTS; #endif @@ -3651,7 +3669,7 @@ S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp) || k1->op_type == OP_EACH) { warnop = ((k1->op_type == OP_NULL) - ? k1->op_targ : k1->op_type); + ? (OPCODE)k1->op_targ : k1->op_type); } break; } @@ -3675,12 +3693,12 @@ S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp) NewOp(1101, logop, 1, LOGOP); - logop->op_type = type; + logop->op_type = (OPCODE)type; logop->op_ppaddr = PL_ppaddr[type]; logop->op_first = first; logop->op_flags = flags | OPf_KIDS; logop->op_other = LINKLIST(other); - logop->op_private = 1 | (flags >> 8); + logop->op_private = (U8)(1 | (flags >> 8)); /* establish postfix order */ logop->op_next = LINKLIST(first); @@ -3727,7 +3745,7 @@ Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop) logop->op_ppaddr = PL_ppaddr[OP_COND_EXPR]; logop->op_first = first; logop->op_flags = flags | OPf_KIDS; - logop->op_private = 1 | (flags >> 8); + logop->op_private = (U8)(1 | (flags >> 8)); logop->op_other = LINKLIST(trueop); logop->op_next = LINKLIST(falseop); @@ -3763,7 +3781,7 @@ Perl_newRANGE(pTHX_ I32 flags, OP *left, OP *right) range->op_flags = OPf_KIDS; leftstart = LINKLIST(left); range->op_other = LINKLIST(right); - range->op_private = 1 | (flags >> 8); + range->op_private = (U8)(1 | (flags >> 8)); left->op_sibling = right; @@ -3890,7 +3908,6 @@ Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop, I32 whileline, OP * if (cont) { next = LINKLIST(cont); - loopflags |= OPpLOOP_CONTINUE; } if (expr) { OP *unstack = newOP(OP_UNSTACK, 0); @@ -3898,7 +3915,7 @@ Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop, I32 whileline, OP * next = unstack; cont = append_elem(OP_LINESEQ, cont, unstack); if ((line_t)whileline != NOLINE) { - PL_copline = whileline; + PL_copline = (line_t)whileline; cont = append_elem(OP_LINESEQ, cont, newSTATEOP(0, Nullch, Nullop)); } @@ -3908,7 +3925,7 @@ Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop, I32 whileline, OP * redo = LINKLIST(listop); if (expr) { - PL_copline = whileline; + PL_copline = (line_t)whileline; scalar(listop); o = new_logop(OP_AND, 0, &expr, &listop); if (o == expr && o->op_type == OP_CONST && !SvTRUE(cSVOPo->op_sv)) { @@ -4090,16 +4107,25 @@ Perl_cv_undef(pTHX_ CV *cv) SAVEVPTR(PL_curpad); PL_curpad = 0; - if (!CvCLONED(cv)) - op_free(CvROOT(cv)); + op_free(CvROOT(cv)); CvROOT(cv) = Nullop; LEAVE; } SvPOK_off((SV*)cv); /* forget prototype */ - CvFLAGS(cv) = 0; - SvREFCNT_dec(CvGV(cv)); CvGV(cv) = Nullgv; - SvREFCNT_dec(CvOUTSIDE(cv)); + /* Since closure prototypes have the same lifetime as the containing + * CV, they don't hold a refcount on the outside CV. This avoids + * the refcount loop between the outer CV (which keeps a refcount to + * the closure prototype in the pad entry for pp_anoncode()) and the + * closure prototype, and the ensuing memory leak. This does not + * apply to closures generated within eval"", since eval"" CVs are + * ephemeral. --GSAR */ + if (!CvANON(cv) || CvCLONED(cv) + || (CvOUTSIDE(cv) && SvTYPE(CvOUTSIDE(cv)) == SVt_PVCV + && CvEVAL(CvOUTSIDE(cv)) && !CvGV(CvOUTSIDE(cv)))) + { + SvREFCNT_dec(CvOUTSIDE(cv)); + } CvOUTSIDE(cv) = Nullcv; if (CvPADLIST(cv)) { /* may be during global destruction */ @@ -4122,6 +4148,7 @@ Perl_cv_undef(pTHX_ CV *cv) } CvPADLIST(cv) = Nullav; } + CvFLAGS(cv) = 0; } STATIC void @@ -4204,9 +4231,9 @@ S_cv_clone2(pTHX_ CV *proto, CV *outside) CvOWNER(cv) = 0; #endif /* USE_THREADS */ CvFILE(cv) = CvFILE(proto); - CvGV(cv) = (GV*)SvREFCNT_inc(CvGV(proto)); + CvGV(cv) = CvGV(proto); CvSTASH(cv) = CvSTASH(proto); - CvROOT(cv) = CvROOT(proto); + CvROOT(cv) = OpREFCNT_inc(CvROOT(proto)); CvSTART(cv) = CvSTART(proto); if (outside) CvOUTSIDE(cv) = (CV*)SvREFCNT_inc(outside); @@ -4467,12 +4494,15 @@ Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block) goto done; } /* ahem, death to those who redefine active sort subs */ - if (PL_curstackinfo->si_type == PERLSI_SORT && PL_sortcop == CvSTART(cv)) + if (PL_curstackinfo->si_type == PERLSI_SORT && + PL_sortcop == CvSTART(cv)) { + op_free(block); Perl_croak(aTHX_ "Can't redefine active sort subroutine %s", name); + } if (!block) goto withattrs; if ((const_sv = cv_const_sv(cv))) - const_changed = sv_cmp(const_sv, op_const_sv(block, Nullcv)); + const_changed = (bool)sv_cmp(const_sv, op_const_sv(block, Nullcv)); if ((const_sv || const_changed) && ckWARN(WARN_REDEFINE)) { line_t oldline = CopLINE(PL_curcop); @@ -4525,8 +4555,30 @@ Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block) CvOUTSIDE(PL_compcv) = 0; CvPADLIST(cv) = CvPADLIST(PL_compcv); CvPADLIST(PL_compcv) = 0; - if (SvREFCNT(PL_compcv) > 1) /* XXX Make closures transit through stub. */ - CvOUTSIDE(PL_compcv) = (CV*)SvREFCNT_inc((SV*)cv); + /* inner references to PL_compcv must be fixed up ... */ + { + AV *padlist = CvPADLIST(cv); + AV *comppad_name = (AV*)AvARRAY(padlist)[0]; + AV *comppad = (AV*)AvARRAY(padlist)[1]; + SV **namepad = AvARRAY(comppad_name); + SV **curpad = AvARRAY(comppad); + for (ix = AvFILLp(comppad_name); ix > 0; ix--) { + SV *namesv = namepad[ix]; + if (namesv && namesv != &PL_sv_undef + && *SvPVX(namesv) == '&') + { + CV *innercv = (CV*)curpad[ix]; + if (CvOUTSIDE(innercv) == PL_compcv) { + CvOUTSIDE(innercv) = cv; + if (!CvANON(innercv) || CvCLONED(innercv)) { + (void)SvREFCNT_inc(cv); + SvREFCNT_dec(PL_compcv); + } + } + } + } + } + /* ... before we throw it away */ SvREFCNT_dec(PL_compcv); } else { @@ -4537,7 +4589,7 @@ Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block) PL_sub_generation++; } } - CvGV(cv) = (GV*)SvREFCNT_inc(gv); + CvGV(cv) = gv; CvFILE(cv) = CopFILE(PL_curcop); CvSTASH(cv) = PL_curstash; #ifdef USE_THREADS @@ -4581,7 +4633,8 @@ Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block) av_store(PL_comppad_name, AvFILLp(PL_comppad), Nullsv); if (CvLVALUE(cv)) { - CvROOT(cv) = newUNOP(OP_LEAVESUBLV, 0, scalarseq(block)); + CvROOT(cv) = newUNOP(OP_LEAVESUBLV, 0, + mod(scalarseq(block), OP_LEAVESUBLV)); } else { CvROOT(cv) = newUNOP(OP_LEAVESUB, 0, scalarseq(block)); @@ -4629,6 +4682,18 @@ Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block) } } + /* If a potential closure prototype, don't keep a refcount on + * outer CV, unless the latter happens to be a passing eval"". + * This is okay as the lifetime of the prototype is tied to the + * lifetime of the outer CV. Avoids memory leak due to reference + * loop. --GSAR */ + if (!name && CvOUTSIDE(cv) + && !(SvTYPE(CvOUTSIDE(cv)) == SVt_PVCV + && CvEVAL(CvOUTSIDE(cv)) && !CvGV(CvOUTSIDE(cv)))) + { + SvREFCNT_dec(CvOUTSIDE(cv)); + } + if (name || aname) { char *s; char *tname = (name ? name : aname); @@ -4676,12 +4741,12 @@ Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block) if (!PL_beginav) PL_beginav = newAV(); DEBUG_x( dump_sub(gv) ); - av_push(PL_beginav, SvREFCNT_inc(cv)); - GvCV(gv) = 0; + av_push(PL_beginav, (SV*)cv); + GvCV(gv) = 0; /* cv has been hijacked */ call_list(oldscope, PL_beginav); PL_curcop = &PL_compiling; - PL_compiling.op_private = PL_hints; + PL_compiling.op_private = (U8)(PL_hints & HINT_PRIVATE_MASK); LEAVE; } else if (strEQ(s, "END") && !PL_error_count) { @@ -4689,8 +4754,8 @@ Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block) PL_endav = newAV(); DEBUG_x( dump_sub(gv) ); av_unshift(PL_endav, 1); - av_store(PL_endav, 0, SvREFCNT_inc(cv)); - GvCV(gv) = 0; + av_store(PL_endav, 0, (SV*)cv); + GvCV(gv) = 0; /* cv has been hijacked */ } else if (strEQ(s, "CHECK") && !PL_error_count) { if (!PL_checkav) @@ -4699,8 +4764,8 @@ Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block) if (PL_main_start && ckWARN(WARN_VOID)) Perl_warner(aTHX_ WARN_VOID, "Too late to run CHECK block"); av_unshift(PL_checkav, 1); - av_store(PL_checkav, 0, SvREFCNT_inc(cv)); - GvCV(gv) = 0; + av_store(PL_checkav, 0, (SV*)cv); + GvCV(gv) = 0; /* cv has been hijacked */ } else if (strEQ(s, "INIT") && !PL_error_count) { if (!PL_initav) @@ -4708,8 +4773,8 @@ Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block) DEBUG_x( dump_sub(gv) ); if (PL_main_start && ckWARN(WARN_VOID)) Perl_warner(aTHX_ WARN_VOID, "Too late to run INIT block"); - av_push(PL_initav, SvREFCNT_inc(cv)); - GvCV(gv) = 0; + av_push(PL_initav, (SV*)cv); + GvCV(gv) = 0; /* cv has been hijacked */ } } @@ -4810,7 +4875,7 @@ Perl_newXS(pTHX_ char *name, XSUBADDR_t subaddr, char *filename) PL_sub_generation++; } } - CvGV(cv) = (GV*)SvREFCNT_inc(gv); + CvGV(cv) = gv; #ifdef USE_THREADS New(666, CvMUTEXP(cv), 1, perl_mutex); MUTEX_INIT(CvMUTEXP(cv)); @@ -4834,15 +4899,15 @@ Perl_newXS(pTHX_ char *name, XSUBADDR_t subaddr, char *filename) if (strEQ(s, "BEGIN")) { if (!PL_beginav) PL_beginav = newAV(); - av_push(PL_beginav, SvREFCNT_inc(cv)); - GvCV(gv) = 0; + av_push(PL_beginav, (SV*)cv); + GvCV(gv) = 0; /* cv has been hijacked */ } else if (strEQ(s, "END")) { if (!PL_endav) PL_endav = newAV(); av_unshift(PL_endav, 1); - av_store(PL_endav, 0, SvREFCNT_inc(cv)); - GvCV(gv) = 0; + av_store(PL_endav, 0, (SV*)cv); + GvCV(gv) = 0; /* cv has been hijacked */ } else if (strEQ(s, "CHECK")) { if (!PL_checkav) @@ -4850,16 +4915,16 @@ Perl_newXS(pTHX_ char *name, XSUBADDR_t subaddr, char *filename) if (PL_main_start && ckWARN(WARN_VOID)) Perl_warner(aTHX_ WARN_VOID, "Too late to run CHECK block"); av_unshift(PL_checkav, 1); - av_store(PL_checkav, 0, SvREFCNT_inc(cv)); - GvCV(gv) = 0; + av_store(PL_checkav, 0, (SV*)cv); + GvCV(gv) = 0; /* cv has been hijacked */ } else if (strEQ(s, "INIT")) { if (!PL_initav) PL_initav = newAV(); if (PL_main_start && ckWARN(WARN_VOID)) Perl_warner(aTHX_ WARN_VOID, "Too late to run INIT block"); - av_push(PL_initav, SvREFCNT_inc(cv)); - GvCV(gv) = 0; + av_push(PL_initav, (SV*)cv); + GvCV(gv) = 0; /* cv has been hijacked */ } } else @@ -4896,7 +4961,7 @@ Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block) } cv = PL_compcv; GvFORM(gv) = cv; - CvGV(cv) = (GV*)SvREFCNT_inc(gv); + CvGV(cv) = gv; CvFILE(cv) = CopFILE(PL_curcop); for (ix = AvFILLp(PL_comppad); ix > 0; ix--) { @@ -5075,7 +5140,7 @@ Perl_ck_anoncode(pTHX_ OP *o) OP * Perl_ck_bitop(pTHX_ OP *o) { - o->op_private = PL_hints; + o->op_private = (U8)(PL_hints & HINT_PRIVATE_MASK); return o; } @@ -5365,6 +5430,7 @@ Perl_ck_rvconst(pTHX_ register OP *o) #else kid->op_sv = SvREFCNT_inc(gv); #endif + kid->op_private = 0; kid->op_ppaddr = PL_ppaddr[OP_GV]; } } @@ -5398,13 +5464,6 @@ Perl_ck_ftst(pTHX_ OP *o) else o = newUNOP(type, 0, newDEFSVOP()); } -#ifdef USE_LOCALE - if (type == OP_FTTEXT || type == OP_FTBINARY) { - o->op_private = 0; - if (PL_hints & HINT_LOCALE) - o->op_private |= OPpLOCALE; - } -#endif return o; } @@ -5650,6 +5709,7 @@ Perl_ck_glob(pTHX_ OP *o) gv = newGVgen("main"); gv_IOadd(gv); append_elem(OP_GLOB, o, newGVOP(OP_GV, 0, gv)); + SvREFCNT_dec((SV*)gv); /* had excess refcnt */ scalarkids(o); return o; } @@ -5804,29 +5864,7 @@ Perl_ck_listiob(pTHX_ OP *o) if (!kid) append_elem(o->op_type, o, newDEFSVOP()); - o = listkids(o); - - o->op_private = 0; -#ifdef USE_LOCALE - if (PL_hints & HINT_LOCALE) - o->op_private |= OPpLOCALE; -#endif - - return o; -} - -OP * -Perl_ck_fun_locale(pTHX_ OP *o) -{ - o = ck_fun(o); - - o->op_private = 0; -#ifdef USE_LOCALE - if (PL_hints & HINT_LOCALE) - o->op_private |= OPpLOCALE; -#endif - - return o; + return listkids(o); } OP * @@ -5860,18 +5898,6 @@ Perl_ck_sassign(pTHX_ OP *o) } OP * -Perl_ck_scmp(pTHX_ OP *o) -{ - o->op_private = 0; -#ifdef USE_LOCALE - if (PL_hints & HINT_LOCALE) - o->op_private |= OPpLOCALE; -#endif - - return o; -} - -OP * Perl_ck_match(pTHX_ OP *o) { o->op_private |= OPpRUNTIME; @@ -5973,6 +5999,17 @@ Perl_ck_require(pTHX_ OP *o) return ck_fun(o); } +OP * +Perl_ck_return(pTHX_ OP *o) +{ + OP *kid; + if (CvLVALUE(PL_compcv)) { + for (kid = cLISTOPo->op_first->op_sibling; kid; kid = kid->op_sibling) + mod(kid, OP_LEAVESUBLV); + } + return o; +} + #if 0 OP * Perl_ck_retarget(pTHX_ OP *o) @@ -6036,11 +6073,6 @@ OP * Perl_ck_sort(pTHX_ OP *o) { OP *firstkid; - o->op_private = 0; -#ifdef USE_LOCALE - if (PL_hints & HINT_LOCALE) - o->op_private |= OPpLOCALE; -#endif if (o->op_type == OP_SORT && o->op_flags & OPf_STACKED) simplify_sort(o); @@ -6162,7 +6194,6 @@ S_simplify_sort(pTHX_ OP *o) kid = cLISTOPo->op_first->op_sibling; cLISTOPo->op_first->op_sibling = kid->op_sibling; /* bypass old block */ op_free(kid); /* then delete it */ - cLISTOPo->op_children--; } OP * @@ -6452,7 +6483,6 @@ Perl_peep(pTHX_ register OP *o) { register OP* oldop = 0; STRLEN n_a; - OP *last_composite = Nullop; if (!o || o->op_seq) return; @@ -6471,7 +6501,6 @@ Perl_peep(pTHX_ register OP *o) case OP_DBSTATE: PL_curcop = ((COP*)o); /* for warnings */ o->op_seq = PL_op_seqmax++; - last_composite = Nullop; break; case OP_CONST: @@ -6562,7 +6591,7 @@ Perl_peep(pTHX_ register OP *o) (PL_op = pop->op_next) && pop->op_next->op_type == OP_AELEM && !(pop->op_next->op_private & - (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF)) && + (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB)) && (i = SvIV(((SVOP*)pop)->op_sv) - PL_compiling.cop_arybase) <= 255 && i >= 0) @@ -6610,9 +6639,16 @@ Perl_peep(pTHX_ register OP *o) break; case OP_ENTERLOOP: + case OP_ENTERITER: o->op_seq = PL_op_seqmax++; + while (cLOOP->op_redoop->op_type == OP_NULL) + cLOOP->op_redoop = cLOOP->op_redoop->op_next; peep(cLOOP->op_redoop); + while (cLOOP->op_nextop->op_type == OP_NULL) + cLOOP->op_nextop = cLOOP->op_nextop->op_next; peep(cLOOP->op_nextop); + while (cLOOP->op_lastop->op_type == OP_NULL) + cLOOP->op_lastop = cLOOP->op_lastop->op_next; peep(cLOOP->op_lastop); break; @@ -6620,6 +6656,9 @@ Perl_peep(pTHX_ register OP *o) case OP_MATCH: case OP_SUBST: o->op_seq = PL_op_seqmax++; + while (cPMOP->op_pmreplstart && + cPMOP->op_pmreplstart->op_type == OP_NULL) + cPMOP->op_pmreplstart = cPMOP->op_pmreplstart->op_next; peep(cPMOP->op_pmreplstart); break; @@ -6752,42 +6791,6 @@ Perl_peep(pTHX_ register OP *o) break; } - case OP_RV2AV: - case OP_RV2HV: - if (!(o->op_flags & OPf_WANT) - || (o->op_flags & OPf_WANT) == OPf_WANT_LIST) - { - last_composite = o; - } - o->op_seq = PL_op_seqmax++; - break; - - case OP_RETURN: - if (o->op_next && o->op_next->op_type != OP_LEAVESUBLV) { - o->op_seq = PL_op_seqmax++; - break; - } - /* FALL THROUGH */ - - case OP_LEAVESUBLV: - if (last_composite) { - OP *r = last_composite; - - while (r->op_sibling) - r = r->op_sibling; - if (r->op_next == o - || (r->op_next->op_type == OP_LIST - && r->op_next->op_next == o)) - { - if (last_composite->op_type == OP_RV2AV) - yyerror("Lvalue subs returning arrays not implemented yet"); - else - yyerror("Lvalue subs returning hashes not implemented yet"); - ; - } - } - /* FALL THROUGH */ - default: o->op_seq = PL_op_seqmax++; break;