X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=op.c;h=4c5dd1302bcbc222764c21688b5c4a59a8be3108;hb=4194d4900628023d2d8e6a71f5036d1975be36d7;hp=c530e5f484bdcb5772fedb61124a3c152e1b7d43;hpb=411caa507cab4ba311ec4000c486ad2592d51146;p=p5sagit%2Fp5-mst-13.2.git diff --git a/op.c b/op.c index c530e5f..4c5dd13 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) @@ -102,6 +103,30 @@ S_no_bareword_allowed(pTHX_ OP *o) SvPV_nolen(cSVOPo_sv))); } +STATIC U8* +S_trlist_upgrade(pTHX_ U8** sp, U8** ep) +{ + U8 *s = *sp; + U8 *e = *ep; + U8 *d; + + Newz(801, d, (e - s) * 2, U8); + *sp = d; + + while (s < e) { + if (*s < 0x80 || *s == 0xff) + *d++ = *s++; + else { + U8 c = *s++; + *d++ = ((c >> 6) | 0xc0); + *d++ = ((c & 0x3f) | 0x80); + } + } + *ep = d; + return *sp; +} + + /* "register" allocation */ PADOFFSET @@ -112,7 +137,7 @@ Perl_pad_allocmy(pTHX_ char *name) if (!(PL_in_my == KEY_our || isALPHA(name[1]) || - (PL_hints & HINT_UTF8 && (name[1] & 0xc0) == 0xc0) || + (PL_hints & HINT_UTF8 && UTF8_IS_START(name[1])) || (name[1] == '_' && (int)strlen(name) > 2))) { if (!isPRINT(name[1]) || strchr("\t\n\r\f", name[1])) { @@ -1118,6 +1143,12 @@ Perl_scalarvoid(pTHX_ OP *o) if (SvNIOK(sv) && (SvNV(sv) == 0.0 || SvNV(sv) == 1.0)) useless = 0; else if (SvPOK(sv)) { + /* perl4's way of mixing documentation and code + (before the invention of POD) was based on a + trick to mix nroff and perl code. The trick was + built upon these three nroff macros being used in + void context. The pink camel has the details in + the script wrapman near page 319. */ if (strnEQ(SvPVX(sv), "di", 2) || strnEQ(SvPVX(sv), "ds", 2) || strnEQ(SvPVX(sv), "ig", 2)) @@ -1330,6 +1361,31 @@ Perl_mod(pTHX_ OP *o, I32 type) PL_modcount++; return o; case OP_CONST: + if (o->op_private & (OPpCONST_BARE) && + !(type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN)) { + SV *sv = ((SVOP*)o)->op_sv; + GV *gv; + + /* Could be a filehandle */ + if ((gv = gv_fetchpv(SvPV_nolen(sv), FALSE, SVt_PVIO))) { + OP* gvio = newUNOP(OP_RV2GV, 0, newGVOP(OP_GV, 0, gv)); + op_free(o); + o = gvio; + } else { + /* OK, it's a sub */ + OP* enter; + gv = gv_fetchpv(SvPV_nolen(sv), TRUE, SVt_PVCV); + + enter = newUNOP(OP_ENTERSUB,0, + newUNOP(OP_RV2CV, 0, + newGVOP(OP_GV, 0, gv) + )); + enter->op_private |= OPpLVAL_INTRO; + op_free(o); + o = enter; + } + break; + } if (!(o->op_private & (OPpCONST_ARYBASE))) goto nomod; if (PL_eval_start && PL_eval_start->op_type == OP_CONST) { @@ -1360,6 +1416,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; @@ -1494,7 +1551,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 */ @@ -1503,14 +1560,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) @@ -1529,11 +1588,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++; @@ -1561,6 +1622,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); @@ -1575,12 +1638,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; @@ -1599,8 +1665,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; @@ -1609,7 +1681,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; } @@ -1883,6 +1956,16 @@ S_my_kid(pTHX_ OP *o, OP *attrs) } else if (type == OP_RV2SV || /* "our" declaration */ type == OP_RV2AV || type == OP_RV2HV) { /* XXX does this let anything illegal in? */ + if (attrs) { + GV *gv = cGVOPx_gv(cUNOPo->op_first); + PL_in_my = FALSE; + PL_in_my_stash = Nullhv; + apply_attrs(GvSTASH(gv), + (type == OP_RV2SV ? GvSV(gv) : + type == OP_RV2AV ? (SV*)GvAV(gv) : + type == OP_RV2HV ? (SV*)GvHV(gv) : (SV*)gv), + attrs); + } o->op_private |= OPpOUR_INTRO; return o; } else if (type != OP_PADSV && @@ -2139,7 +2222,7 @@ Perl_localize(pTHX_ OP *o, I32 lex) else { if (ckWARN(WARN_PARENTHESIS) && PL_bufptr > PL_oldbufptr && PL_bufptr[-1] == ',') { char *s; - for (s = PL_bufptr; *s && (isALNUM(*s) || (*s & 0x80) || strchr("@$%, ",*s)); s++) ; + for (s = PL_bufptr; *s && (isALNUM(*s) || UTF8_IS_CONTINUED(*s) || strchr("@$%, ",*s)); s++) ; if (*s == ';' || *s == '=') Perl_warner(aTHX_ WARN_PARENTHESIS, "Parentheses missing around \"%s\" list", @@ -2249,13 +2332,11 @@ Perl_fold_constants(pTHX_ register OP *o) if ((SvFLAGS(sv) & (SVf_IOK|SVf_NOK|SVf_POK)) == SVf_NOK && type != OP_NEGATE) { - IV iv = SvIV(sv); - if ((NV)iv == SvNV(sv)) { - SvREFCNT_dec(sv); - sv = newSViv(iv); - } - else - SvIOK_off(sv); /* undo SvIV() damage */ +#ifdef PERL_PRESERVE_IVUV + /* Only bother to attempt to fold to IV if + most operators will benefit */ + SvIV_please(sv); +#endif } return newSVOP(OP_CONST, 0, sv); } @@ -2319,9 +2400,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) o = newLISTOP(OP_LIST, 0, o, Nullop); else @@ -2338,13 +2416,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); } @@ -2372,7 +2443,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; } @@ -2393,9 +2463,7 @@ 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 @@ -2417,6 +2485,8 @@ Perl_prepend_elem(pTHX_ I32 type, OP *first, OP *last) if (type == OP_LIST) { /* already a PUSHMARK there */ first->op_sibling = ((LISTOP*)last)->op_first->op_sibling; ((LISTOP*)last)->op_first->op_sibling = first; + if (!(first->op_flags & OPf_PARENS)) + last->op_flags &= ~OPf_PARENS; } else { if (!(last->op_flags & OPf_KIDS)) { @@ -2426,7 +2496,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; } @@ -2459,7 +2529,8 @@ Perl_newLISTOP(pTHX_ I32 type, I32 flags, OP *first, OP *last) listop->op_type = type; listop->op_ppaddr = PL_ppaddr[type]; - listop->op_children = (first != 0) + (last != 0); + if (first || last) + flags |= OPf_KIDS; listop->op_flags = flags; if (!last && first) @@ -2479,8 +2550,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; } @@ -2577,13 +2646,14 @@ Perl_pmtrans(pTHX_ OP *o, OP *expr, OP *repl) SV *rstr = ((SVOP*)repl)->op_sv; STRLEN tlen; STRLEN rlen; - register U8 *t = (U8*)SvPV(tstr, tlen); - register U8 *r = (U8*)SvPV(rstr, rlen); + U8 *t = (U8*)SvPV(tstr, tlen); + U8 *r = (U8*)SvPV(rstr, rlen); register I32 i; register I32 j; I32 del; I32 complement; I32 squash; + I32 grows = 0; register short *tbl; complement = o->op_private & OPpTRANS_COMPLEMENT; @@ -2612,16 +2682,16 @@ Perl_pmtrans(pTHX_ OP *o, OP *expr, OP *repl) I32 none = 0; U32 max = 0; I32 bits; - I32 grows = 0; I32 havefinal = 0; U32 final; I32 from_utf = o->op_private & OPpTRANS_FROM_UTF; I32 to_utf = o->op_private & OPpTRANS_TO_UTF; + U8* tsave = from_utf ? NULL : trlist_upgrade(&t, &tend); + U8* rsave = to_utf ? NULL : trlist_upgrade(&r, &rend); if (complement) { U8 tmpbuf[UTF8_MAXLEN+1]; U8** cp; - I32* cl; UV nextmin = 0; New(1109, cp, tlen, U8*); i = 0; @@ -2629,7 +2699,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); } @@ -2637,7 +2707,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; @@ -2650,7 +2720,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; @@ -2663,6 +2733,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; @@ -2738,20 +2809,8 @@ Perl_pmtrans(pTHX_ OP *o, OP *expr, OP *repl) if (rfirst + diff > max) max = rfirst + diff; rfirst += diff + 1; - if (!grows) { - if (rfirst <= 0x80) - ; - else if (rfirst <= 0x800) - grows |= (tfirst < 0x80); - else if (rfirst <= 0x10000) - grows |= (tfirst < 0x800); - else if (rfirst <= 0x200000) - grows |= (tfirst < 0x10000); - else if (rfirst <= 0x4000000) - grows |= (tfirst < 0x200000); - else if (rfirst <= 0x80000000) - grows |= (tfirst < 0x4000000); - } + if (!grows) + grows = (UNISKIP(tfirst) < UNISKIP(rfirst)); } tfirst += diff + 1; } @@ -2767,6 +2826,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) @@ -2776,9 +2836,14 @@ Perl_pmtrans(pTHX_ OP *o, OP *expr, OP *repl) (void)hv_store((HV*)SvRV((cSVOPo->op_sv)), "FINAL", 5, newSVuv((UV)final), 0); - if (grows && to_utf) + if (grows) o->op_private |= OPpTRANS_GROWS; + if (tsave) + Safefree(tsave); + if (rsave) + Safefree(rsave); + op_free(expr); op_free(repl); return o; @@ -2799,10 +2864,22 @@ Perl_pmtrans(pTHX_ OP *o, OP *expr, OP *repl) else tbl[i] = i; } - else + else { + if (i < 128 && r[j] >= 128) + grows = 1; tbl[i] = r[j++]; + } } } + if (!del) { + if (j >= rlen) + j = rlen - 1; + else + cPVOPo->op_pv = (char*)Renew(tbl, 0x101+rlen-j, short); + tbl[0x100] = rlen - j; + for (i=0; i < rlen - j; i++) + tbl[0x101+i] = r[j+i]; + } } else { if (!rlen && !del) { @@ -2821,10 +2898,15 @@ Perl_pmtrans(pTHX_ OP *o, OP *expr, OP *repl) } --j; } - if (tbl[t[i]] == -1) + if (tbl[t[i]] == -1) { + if (t[i] < 128 && r[j] >= 128) + grows = 1; tbl[t[i]] = r[j]; + } } } + if (grows) + o->op_private |= OPpTRANS_GROWS; op_free(expr); op_free(repl); @@ -3444,7 +3526,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; @@ -3876,7 +3958,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); @@ -4082,8 +4163,6 @@ Perl_cv_undef(pTHX_ CV *cv) LEAVE; } SvPOK_off((SV*)cv); /* forget prototype */ - CvFLAGS(cv) = 0; - SvREFCNT_dec(CvGV(cv)); CvGV(cv) = Nullgv; SvREFCNT_dec(CvOUTSIDE(cv)); CvOUTSIDE(cv) = Nullcv; @@ -4112,8 +4191,10 @@ Perl_cv_undef(pTHX_ CV *cv) } CvPADLIST(cv) = Nullav; } + CvFLAGS(cv) = 0; } +#ifdef DEBUG_CLOSURES STATIC void S_cv_dump(pTHX_ CV *cv) { @@ -4160,6 +4241,7 @@ S_cv_dump(pTHX_ CV *cv) } #endif /* DEBUGGING */ } +#endif /* DEBUG_CLOSURES */ STATIC CV * S_cv_clone2(pTHX_ CV *proto, CV *outside) @@ -4194,7 +4276,7 @@ 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); CvSTART(cv) = CvSTART(proto); @@ -4482,6 +4564,12 @@ Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block) cv = (!name || GvCVGEN(gv)) ? Nullcv : GvCV(gv); +#ifdef GV_SHARED_CHECK + if (cv && GvSHARED(gv) && SvREADONLY(cv)) { + Perl_croak(aTHX_ "Can't define subroutine %s (GV is shared)", name); + } +#endif + if (!block || !ps || *ps || attrs) const_sv = Nullsv; else @@ -4489,6 +4577,13 @@ Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block) if (cv) { bool exists = CvROOT(cv) || CvXSUB(cv); + +#ifdef GV_SHARED_CHECK + if (exists && GvSHARED(gv)) { + Perl_croak(aTHX_ "Can't redefine shared subroutine %s", name); + } +#endif + /* if the subroutine doesn't exist and wasn't pre-declared * with a prototype, assume it will be AUTOLOADed, * skipping the prototype check @@ -4591,7 +4686,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 @@ -4631,7 +4726,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)); @@ -4866,7 +4962,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)); @@ -4939,6 +5035,11 @@ Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block) else name = "STDOUT"; gv = gv_fetchpv(name,TRUE, SVt_PVFM); +#ifdef GV_SHARED_CHECK + if (GvSHARED(gv)) { + Perl_croak(aTHX_ "Bad symbol for form (GV is shared)"); + } +#endif GvMULTI_on(gv); if ((cv = GvFORM(gv))) { if (ckWARN(WARN_REDEFINE)) { @@ -4952,7 +5053,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--) { @@ -5421,6 +5522,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]; } } @@ -6031,6 +6133,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) @@ -6220,7 +6333,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 * @@ -6510,7 +6622,6 @@ Perl_peep(pTHX_ register OP *o) { register OP* oldop = 0; STRLEN n_a; - OP *last_composite = Nullop; if (!o || o->op_seq) return; @@ -6529,7 +6640,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: @@ -6622,7 +6732,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) @@ -6671,8 +6781,14 @@ Perl_peep(pTHX_ register OP *o) case OP_ENTERLOOP: 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; @@ -6680,6 +6796,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; @@ -6721,9 +6840,9 @@ Perl_peep(pTHX_ register OP *o) svp = cSVOPx_svp(((BINOP*)o)->op_last); if ((!SvFAKE(sv = *svp) || !SvREADONLY(sv)) && !IS_PADCONST(sv)) { key = SvPV(sv, keylen); - lexname = newSVpvn_share(key, keylen, 0); if (SvUTF8(sv)) - SvUTF8_on(lexname); + keylen = -keylen; + lexname = newSVpvn_share(key, keylen, 0); SvREFCNT_dec(sv); *svp = lexname; } @@ -6741,6 +6860,8 @@ Perl_peep(pTHX_ register OP *o) if (!fields || !GvHV(*fields)) break; key = SvPV(*svp, keylen); + if (SvUTF8(*svp)) + keylen = -keylen; indsvp = hv_fetch(GvHV(*fields), key, keylen, FALSE); if (!indsvp) { Perl_croak(aTHX_ "No such pseudo-hash field \"%s\" in variable %s of type %s", @@ -6806,6 +6927,8 @@ Perl_peep(pTHX_ register OP *o) key_op = (SVOP*)key_op->op_sibling) { svp = cSVOPx_svp(key_op); key = SvPV(*svp, keylen); + if (SvUTF8(*svp)) + keylen = -keylen; indsvp = hv_fetch(GvHV(*fields), key, keylen, FALSE); if (!indsvp) { Perl_croak(aTHX_ "No such pseudo-hash field \"%s\" " @@ -6826,42 +6949,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; @@ -6878,6 +6965,12 @@ static void const_sv_xsub(pTHXo_ CV* cv) { dXSARGS; + if (items != 0) { +#if 0 + Perl_croak(aTHX_ "usage: %s::%s()", + HvNAME(GvSTASH(CvGV(cv))), GvNAME(CvGV(cv))); +#endif + } EXTEND(sp, 1); ST(0) = (SV*)XSANY.any_ptr; XSRETURN(1);