diff options
Diffstat (limited to 'gnu/usr.bin/perl/op.c')
| -rw-r--r-- | gnu/usr.bin/perl/op.c | 579 |
1 files changed, 355 insertions, 224 deletions
diff --git a/gnu/usr.bin/perl/op.c b/gnu/usr.bin/perl/op.c index 1cfc6dde2a1..5fe0a039808 100644 --- a/gnu/usr.bin/perl/op.c +++ b/gnu/usr.bin/perl/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,18 +103,41 @@ 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 Perl_pad_allocmy(pTHX_ char *name) { - dTHR; PADOFFSET off; SV *sv; 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])) { @@ -162,6 +186,7 @@ Perl_pad_allocmy(pTHX_ char *name) do { if ((sv = svp[off]) && sv != &PL_sv_undef + && (SvIVX(sv) == PAD_MAX || SvIVX(sv) == 0) && ((SvFLAGS(sv) & SVpad_OUR) && GvSTASH(sv) == ourstash) && strEQ(name, SvPVX(sv))) { @@ -237,7 +262,6 @@ STATIC PADOFFSET S_pad_findlex(pTHX_ char *name, PADOFFSET newoff, U32 seq, CV* startcv, I32 cx_ix, I32 saweval, U32 flags) { - dTHR; CV *cv; I32 off; SV *sv; @@ -321,9 +345,12 @@ S_pad_findlex(pTHX_ char *name, PADOFFSET newoff, U32 seq, CV* startcv, } } else if (!CvUNIQUE(PL_compcv)) { - if (ckWARN(WARN_CLOSURE) && !SvFAKE(sv) && !CvUNIQUE(cv)) + if (ckWARN(WARN_CLOSURE) && !SvFAKE(sv) && !CvUNIQUE(cv) + && !(SvFLAGS(sv) & SVpad_OUR)) + { Perl_warner(aTHX_ WARN_CLOSURE, "Variable \"%s\" will not stay shared", name); + } } } av_store(PL_comppad, newoff, SvREFCNT_inc(oldsv)); @@ -381,7 +408,6 @@ S_pad_findlex(pTHX_ char *name, PADOFFSET newoff, U32 seq, CV* startcv, PADOFFSET Perl_pad_findmy(pTHX_ char *name) { - dTHR; I32 off; I32 pendoff = 0; SV *sv; @@ -444,7 +470,6 @@ Perl_pad_findmy(pTHX_ char *name) void Perl_pad_leavemy(pTHX_ I32 fill) { - dTHR; I32 off; SV **svp = AvARRAY(PL_comppad_name); SV *sv; @@ -464,7 +489,6 @@ Perl_pad_leavemy(pTHX_ I32 fill) PADOFFSET Perl_pad_alloc(pTHX_ I32 optype, U32 tmptype) { - dTHR; SV *sv; I32 retval; @@ -515,7 +539,6 @@ Perl_pad_alloc(pTHX_ I32 optype, U32 tmptype) SV * Perl_pad_sv(pTHX_ PADOFFSET po) { - dTHR; #ifdef USE_THREADS DEBUG_X(PerlIO_printf(Perl_debug_log, "0x%"UVxf" Pad 0x%"UVxf" sv %"IVdf"\n", @@ -532,7 +555,6 @@ Perl_pad_sv(pTHX_ PADOFFSET po) void Perl_pad_free(pTHX_ PADOFFSET po) { - dTHR; if (!PL_curpad) return; if (AvARRAY(PL_comppad) != PL_curpad) @@ -560,7 +582,6 @@ Perl_pad_free(pTHX_ PADOFFSET po) void Perl_pad_swipe(pTHX_ PADOFFSET po) { - dTHR; if (AvARRAY(PL_comppad) != PL_curpad) Perl_croak(aTHX_ "panic: pad_swipe curpad"); if (!po) @@ -590,7 +611,6 @@ void Perl_pad_reset(pTHX) { #ifdef USE_BROKEN_PAD_RESET - dTHR; register I32 po; if (AvARRAY(PL_comppad) != PL_curpad) @@ -619,7 +639,6 @@ Perl_pad_reset(pTHX) PADOFFSET Perl_find_threadsv(pTHX_ const char *name) { - dTHR; char *p; PADOFFSET key; SV **svp; @@ -780,6 +799,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; @@ -839,8 +859,8 @@ S_cop_free(pTHX_ COP* cop) { Safefree(cop->cop_label); #ifdef USE_ITHREADS - Safefree(CopFILE(cop)); /* XXXXX share in a pvtable? */ - Safefree(CopSTASHPV(cop)); /* XXXXX share in a pvtable? */ + Safefree(CopFILE(cop)); /* XXX share in a pvtable? */ + Safefree(CopSTASHPV(cop)); /* XXX share in a pvtable? */ #else /* NOTE: COP.cop_stash is not refcounted */ SvREFCNT_dec(CopFILEGV(cop)); @@ -903,7 +923,6 @@ STATIC OP * S_scalarboolean(pTHX_ OP *o) { if (o->op_type == OP_SASSIGN && cBINOPo->op_first->op_type == OP_CONST) { - dTHR; if (ckWARN(WARN_SYNTAX)) { line_t oldline = CopLINE(PL_curcop); @@ -999,10 +1018,7 @@ Perl_scalarvoid(pTHX_ OP *o) || (o->op_type == OP_NULL && (o->op_targ == OP_NEXTSTATE || o->op_targ == OP_SETSTATE || o->op_targ == OP_DBSTATE))) - { - dTHR; PL_curcop = (COP*)o; /* for warning below */ - } /* assumes no premature commitment */ want = o->op_flags & OPf_WANT; @@ -1119,7 +1135,6 @@ Perl_scalarvoid(pTHX_ OP *o) if (cSVOPo->op_private & OPpCONST_STRICT) no_bareword_allowed(o); else { - dTHR; if (ckWARN(WARN_VOID)) { useless = "a constant"; if (SvNIOK(sv) && (SvNV(sv) == 0.0 || SvNV(sv) == 1.0)) @@ -1160,7 +1175,6 @@ Perl_scalarvoid(pTHX_ OP *o) case OP_DBSTATE: case OP_ENTERTRY: case OP_ENTER: - case OP_SCALAR: if (!(o->op_flags & OPf_KIDS)) break; /* FALL THROUGH */ @@ -1179,6 +1193,8 @@ Perl_scalarvoid(pTHX_ OP *o) case OP_REQUIRE: /* all requires must return a boolean value */ o->op_flags &= ~OPf_WANT; + /* FALL THROUGH */ + case OP_SCALAR: return scalar(o); case OP_SPLIT: if ((kid = cLISTOPo->op_first) && kid->op_type == OP_PUSHRE) { @@ -1187,11 +1203,8 @@ Perl_scalarvoid(pTHX_ OP *o) } break; } - if (useless) { - dTHR; - if (ckWARN(WARN_VOID)) - Perl_warner(aTHX_ WARN_VOID, "Useless use of %s in void context", useless); - } + if (useless && ckWARN(WARN_VOID)) + Perl_warner(aTHX_ WARN_VOID, "Useless use of %s in void context", useless); return o; } @@ -1292,7 +1305,6 @@ Perl_scalarseq(pTHX_ OP *o) o->op_type == OP_LEAVE || o->op_type == OP_LEAVETRY) { - dTHR; for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) { if (kid->op_sibling) { scalarvoid(kid); @@ -1323,7 +1335,6 @@ S_modkids(pTHX_ OP *o, I32 type) OP * Perl_mod(pTHX_ OP *o, I32 type) { - dTHR; OP *kid; STRLEN n_a; @@ -1341,6 +1352,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) { @@ -1371,6 +1407,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; @@ -1505,7 +1542,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 */ @@ -1514,14 +1551,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) @@ -1540,11 +1579,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++; @@ -1572,6 +1613,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); @@ -1586,12 +1629,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; @@ -1610,8 +1656,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; @@ -1620,7 +1672,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; } @@ -1845,6 +1898,37 @@ S_apply_attrs(pTHX_ HV *stash, SV *target, OP *attrs) LEAVE; } +void +Perl_apply_attrs_string(pTHX_ char *stashpv, CV *cv, + char *attrstr, STRLEN len) +{ + OP *attrs = Nullop; + + if (!len) { + len = strlen(attrstr); + } + + while (len) { + for (; isSPACE(*attrstr) && len; --len, ++attrstr) ; + if (len) { + char *sstr = attrstr; + for (; !isSPACE(*attrstr) && len; --len, ++attrstr) ; + attrs = append_elem(OP_LIST, attrs, + newSVOP(OP_CONST, 0, + newSVpvn(sstr, attrstr-sstr))); + } + } + + Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS, + newSVpvn(ATTRSMODULE, sizeof(ATTRSMODULE)-1), + Nullsv, prepend_elem(OP_LIST, + newSVOP(OP_CONST, 0, newSVpv(stashpv,0)), + prepend_elem(OP_LIST, + newSVOP(OP_CONST, 0, + newRV((SV*)cv)), + attrs))); +} + STATIC OP * S_my_kid(pTHX_ OP *o, OP *attrs) { @@ -1927,7 +2011,6 @@ Perl_sawparens(pTHX_ OP *o) OP * Perl_bind_match(pTHX_ I32 type, OP *left, OP *right) { - dTHR; OP *o; if (ckWARN(WARN_MISC) && @@ -1946,11 +2029,14 @@ Perl_bind_match(pTHX_ I32 type, OP *left, OP *right) desc, sample, sample); } - if (right->op_type == OP_MATCH || + if (!(right->op_flags & OPf_STACKED) && + (right->op_type == OP_MATCH || right->op_type == OP_SUBST || - right->op_type == OP_TRANS) { + right->op_type == OP_TRANS)) { right->op_flags |= OPf_STACKED; - if (right->op_type != OP_MATCH) + if (right->op_type != OP_MATCH && + ! (right->op_type == OP_TRANS && + right->op_private & OPpTRANS_IDENTICAL)) left = mod(left, right->op_type); if (right->op_type == OP_TRANS) o = newBINOP(OP_NULL, OPf_STACKED, scalar(left), right); @@ -2011,7 +2097,6 @@ Perl_save_hints(pTHX) int Perl_block_start(pTHX_ int full) { - dTHR; int retval = PL_savestack_ix; SAVEI32(PL_comppad_name_floor); @@ -2040,7 +2125,6 @@ Perl_block_start(pTHX_ int full) OP* Perl_block_end(pTHX_ I32 floor, OP *seq) { - dTHR; int needblockscope = PL_hints & HINT_BLOCK_SCOPE; OP* retval = scalarseq(seq); LEAVE_SCOPE(floor); @@ -2068,7 +2152,6 @@ S_newDEFSVOP(pTHX) void Perl_newPROG(pTHX_ OP *o) { - dTHR; if (PL_in_eval) { if (PL_eval_root) return; @@ -2113,10 +2196,9 @@ Perl_localize(pTHX_ OP *o, I32 lex) if (o->op_flags & OPf_PARENS) list(o); else { - dTHR; 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", @@ -2151,7 +2233,6 @@ Perl_jmaybe(pTHX_ OP *o) OP * Perl_fold_constants(pTHX_ register OP *o) { - dTHR; register OP *curop; I32 type = o->op_type; SV *sv; @@ -2269,7 +2350,6 @@ Perl_fold_constants(pTHX_ register OP *o) OP * Perl_gen_constant_list(pTHX_ register OP *o) { - dTHR; register OP *curop; I32 oldtmps_floor = PL_tmps_floor; @@ -2317,13 +2397,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); } @@ -2351,7 +2424,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; } @@ -2372,10 +2444,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); @@ -2405,7 +2475,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; } @@ -2438,7 +2508,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) @@ -2458,8 +2529,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; } @@ -2556,25 +2625,33 @@ 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; + 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; + + if (SvUTF8(rstr)) + o->op_private |= OPpTRANS_TO_UTF; if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) { SV* listsv = newSVpvn("# comment\n",10); SV* transv = 0; U8* tend = t + tlen; U8* rend = r + rlen; - I32 ulen; + STRLEN ulen; U32 tfirst = 1; U32 tlast = 0; I32 tdiff; @@ -2585,15 +2662,17 @@ 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]; + U8 tmpbuf[UTF8_MAXLEN+1]; U8** cp; + I32* cl; UV nextmin = 0; New(1109, cp, tlen, U8*); i = 0; @@ -2601,7 +2680,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); } @@ -2609,7 +2688,8 @@ 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]; - UV val = utf8_to_uv(s, &ulen); + 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; if (diff > 0) { @@ -2621,8 +2701,8 @@ Perl_pmtrans(pTHX_ OP *o, OP *expr, OP *repl) sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf); } } - if (*s == 0xff) - val = utf8_to_uv(s+1, &ulen); + if (s < tend && *s == 0xff) + val = utf8_to_uv(s+1, cur - 1, &ulen, 0); if (val >= nextmin) nextmin = val + 1; } @@ -2634,29 +2714,27 @@ 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; } if (!squash) { - if (to_utf && from_utf) { /* only counting characters */ - if (t == r || (tlen == rlen && memEQ(t, r, tlen))) - o->op_private |= OPpTRANS_IDENTICAL; - } - else { /* straight latin-1 translation */ - if (tlen == 4 && memEQ(t, "\0\377\303\277", 4) && - rlen == 4 && memEQ(r, "\0\377\303\277", 4)) + if (t == r || + (tlen == rlen && memEQ((char *)t, (char *)r, tlen))) + { o->op_private |= OPpTRANS_IDENTICAL; - } + } } while (t < tend || tfirst <= tlast) { /* see if we need more "t" chars */ if (tfirst > tlast) { - tfirst = (I32)utf8_to_uv(t, &ulen); + tfirst = (I32)utf8_to_uv(t, tend - t, &ulen, 0); t += ulen; if (t < tend && *t == 0xff) { /* illegal utf8 val indicates range */ - tlast = (I32)utf8_to_uv(++t, &ulen); + t++; + tlast = (I32)utf8_to_uv(t, tend - t, &ulen, 0); t += ulen; } else @@ -2666,10 +2744,11 @@ Perl_pmtrans(pTHX_ OP *o, OP *expr, OP *repl) /* now see if we need more "r" chars */ if (rfirst > rlast) { if (r < rend) { - rfirst = (I32)utf8_to_uv(r, &ulen); + rfirst = (I32)utf8_to_uv(r, rend - r, &ulen, 0); r += ulen; if (r < rend && *r == 0xff) { /* illegal utf8 val indicates range */ - rlast = (I32)utf8_to_uv(++r, &ulen); + r++; + rlast = (I32)utf8_to_uv(r, rend - r, &ulen, 0); r += ulen; } else @@ -2711,20 +2790,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; } @@ -2740,6 +2807,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) @@ -2749,9 +2817,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; @@ -2772,8 +2845,11 @@ 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++]; + } } } } @@ -2794,10 +2870,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); @@ -2807,7 +2888,6 @@ Perl_pmtrans(pTHX_ OP *o, OP *expr, OP *repl) OP * Perl_newPMOP(pTHX_ I32 type, I32 flags) { - dTHR; PMOP *pmop; NewOp(1101, pmop, 1, PMOP); @@ -2834,7 +2914,6 @@ Perl_newPMOP(pTHX_ I32 type, I32 flags) OP * Perl_pmruntime(pTHX_ OP *o, OP *expr, OP *repl) { - dTHR; PMOP *pm; LOGOP *rcop; I32 repl_has_vars = 0; @@ -2854,7 +2933,7 @@ Perl_pmruntime(pTHX_ OP *o, OP *expr, OP *repl) p = SvPV(pat, plen); pm->op_pmflags |= PMf_SKIPWHITE; } - if ((PL_hints & HINT_UTF8) || (SvUTF8(pat) && !(PL_hints & HINT_BYTE))) + if ((PL_hints & HINT_UTF8) || DO_UTF8(pat)) pm->op_pmdynflags |= PMdf_UTF8; pm->op_pmregexp = CALLREGCOMP(aTHX_ p, p + plen, pm); if (strEQ("\\s+", pm->op_pmregexp->precomp)) @@ -3025,7 +3104,6 @@ Perl_newPADOP(pTHX_ I32 type, I32 flags, SV *sv) OP * Perl_newGVOP(pTHX_ I32 type, I32 flags, GV *gv) { - dTHR; #ifdef USE_ITHREADS GvIN_PAD_on(gv); return newPADOP(type, flags, SvREFCNT_inc(gv)); @@ -3054,7 +3132,6 @@ Perl_newPVOP(pTHX_ I32 type, I32 flags, char *pv) void Perl_package(pTHX_ OP *o) { - dTHR; SV *sv; save_hptr(&PL_curstash); @@ -3222,8 +3299,15 @@ Perl_vload_module(pTHX_ U32 flags, SV *name, SV *ver, va_list *args) sv = va_arg(*args, SV*); } } - utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(FALSE, 0), - veop, modname, imop); + { + line_t ocopline = PL_copline; + int oexpect = PL_expect; + + utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(FALSE, 0), + veop, modname, imop); + PL_expect = oexpect; + PL_copline = ocopline; + } } OP * @@ -3309,7 +3393,6 @@ Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right) } if (list_assignment(left)) { - dTHR; OP *curop; PL_modcount = 0; @@ -3366,7 +3449,11 @@ Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right) } else if (curop->op_type == OP_PUSHRE) { if (((PMOP*)curop)->op_pmreplroot) { +#ifdef USE_ITHREADS + GV *gv = (GV*)PL_curpad[(PADOFFSET)((PMOP*)curop)->op_pmreplroot]; +#else GV *gv = (GV*)((PMOP*)curop)->op_pmreplroot; +#endif if (gv == PL_defgv || SvCUR(gv) == PL_generation) break; SvCUR(gv) = PL_generation; @@ -3411,7 +3498,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; @@ -3446,7 +3533,6 @@ Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right) OP * Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o) { - dTHR; U32 seq = intro_my(); register COP *cop; @@ -3486,9 +3572,9 @@ Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o) PL_copline = NOLINE; } #ifdef USE_ITHREADS - CopFILE_set(cop, CopFILE(PL_curcop)); /* XXXXX share in a pvtable? */ + CopFILE_set(cop, CopFILE(PL_curcop)); /* XXX share in a pvtable? */ #else - CopFILEGV_set(cop, (GV*)SvREFCNT_inc(CopFILEGV(PL_curcop))); + CopFILEGV_set(cop, CopFILEGV(PL_curcop)); #endif CopSTASH_set(cop, PL_curstash); @@ -3535,7 +3621,6 @@ Perl_newLOGOP(pTHX_ I32 type, I32 flags, OP *first, OP *other) STATIC OP * S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp) { - dTHR; LOGOP *logop; OP *o; OP *first = *firstp; @@ -3647,7 +3732,6 @@ S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp) OP * Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop) { - dTHR; LOGOP *logop; OP *start; OP *o; @@ -3701,7 +3785,6 @@ Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop) OP * Perl_newRANGE(pTHX_ I32 flags, OP *left, OP *right) { - dTHR; LOGOP *range; OP *flip; OP *flop; @@ -3748,7 +3831,6 @@ Perl_newRANGE(pTHX_ I32 flags, OP *left, OP *right) OP * Perl_newLOOPOP(pTHX_ I32 flags, I32 debuggable, OP *expr, OP *block) { - dTHR; OP* listop; OP* o; int once = block && block->op_flags & OPf_SPECIAL && @@ -3804,7 +3886,6 @@ Perl_newLOOPOP(pTHX_ I32 flags, I32 debuggable, OP *expr, OP *block) OP * Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop, I32 whileline, OP *expr, OP *block, OP *cont) { - dTHR; OP *redo; OP *next = 0; OP *listop; @@ -3845,10 +3926,12 @@ Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop, I32 whileline, OP * if (cont) { next = LINKLIST(cont); - loopflags |= OPpLOOP_CONTINUE; } if (expr) { - cont = append_elem(OP_LINESEQ, cont, newOP(OP_UNSTACK, 0)); + OP *unstack = newOP(OP_UNSTACK, 0); + if (!next) + next = unstack; + cont = append_elem(OP_LINESEQ, cont, unstack); if ((line_t)whileline != NOLINE) { PL_copline = whileline; cont = append_elem(OP_LINESEQ, cont, @@ -3871,8 +3954,6 @@ Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop, I32 whileline, OP * if (listop) ((LISTOP*)listop)->op_last->op_next = condop = (o == listop ? redo : LINKLIST(o)); - if (!next) - next = condop; } else o = listop; @@ -3997,7 +4078,6 @@ Perl_newFOROP(pTHX_ I32 flags,char *label,line_t forline,OP *sv,OP *expr,OP *blo OP* Perl_newLOOPEX(pTHX_ I32 type, OP *label) { - dTHR; OP *o; STRLEN n_a; @@ -4024,7 +4104,6 @@ Perl_newLOOPEX(pTHX_ I32 type, OP *label) void Perl_cv_undef(pTHX_ CV *cv) { - dTHR; #ifdef USE_THREADS if (CvMUTEXP(cv)) { MUTEX_DESTROY(CvMUTEXP(cv)); @@ -4046,16 +4125,19 @@ 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. --GSAR */ + if (!CvANON(cv) || CvCLONED(cv)) + SvREFCNT_dec(CvOUTSIDE(cv)); CvOUTSIDE(cv) = Nullcv; if (CvPADLIST(cv)) { /* may be during global destruction */ @@ -4078,6 +4160,7 @@ Perl_cv_undef(pTHX_ CV *cv) } CvPADLIST(cv) = Nullav; } + CvFLAGS(cv) = 0; } STATIC void @@ -4130,7 +4213,6 @@ S_cv_dump(pTHX_ CV *cv) STATIC CV * S_cv_clone2(pTHX_ CV *proto, CV *outside) { - dTHR; AV* av; I32 ix; AV* protopadlist = CvPADLIST(proto); @@ -4161,9 +4243,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); @@ -4273,8 +4355,6 @@ Perl_cv_clone(pTHX_ CV *proto) void Perl_cv_ckproto(pTHX_ CV *cv, GV *gv, char *p) { - dTHR; - if (((!p != !SvPOK(cv)) || (p && strNE(p, SvPVX(cv)))) && ckWARN_d(WARN_PROTOTYPE)) { SV* msg = sv_newmortal(); SV* name = Nullsv; @@ -4364,7 +4444,6 @@ Perl_newSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *block) CV * Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block) { - dTHR; STRLEN n_a; char *name; char *aname; @@ -4427,8 +4506,11 @@ 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))) @@ -4485,8 +4567,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 { @@ -4497,7 +4601,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 @@ -4541,7 +4645,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)); @@ -4589,6 +4694,13 @@ 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. + * 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) + SvREFCNT_dec(CvOUTSIDE(cv)); + if (name || aname) { char *s; char *tname = (name ? name : aname); @@ -4636,8 +4748,8 @@ 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; @@ -4649,8 +4761,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) @@ -4659,8 +4771,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) @@ -4668,8 +4780,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 */ } } @@ -4692,13 +4804,13 @@ eligible for inlining at compile-time. void Perl_newCONSTSUB(pTHX_ HV *stash, char *name, SV *sv) { - dTHR; ENTER; - SAVECOPLINE(PL_curcop); - SAVEHINTS(); + SAVECOPLINE(PL_curcop); CopLINE_set(PL_curcop, PL_copline); + + SAVEHINTS(); PL_hints &= ~HINT_BLOCK_SCOPE; if (stash) { @@ -4734,7 +4846,6 @@ Used by C<xsubpp> to hook up XSUBs as Perl subs. CV * Perl_newXS(pTHX_ char *name, XSUBADDR_t subaddr, char *filename) { - dTHR; GV *gv = gv_fetchpv(name ? name : "__ANON__", GV_ADDMULTI, SVt_PVCV); register CV *cv; @@ -4771,7 +4882,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)); @@ -4795,15 +4906,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) @@ -4811,16 +4922,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 @@ -4833,7 +4944,6 @@ done: void Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block) { - dTHR; register CV *cv; char *name; GV *gv; @@ -4858,7 +4968,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--) { @@ -4931,8 +5041,6 @@ Perl_oopsAV(pTHX_ OP *o) OP * Perl_oopsHV(pTHX_ OP *o) { - dTHR; - switch (o->op_type) { case OP_PADSV: case OP_PADAV: @@ -5229,7 +5337,6 @@ Perl_ck_gvconst(pTHX_ register OP *o) OP * Perl_ck_rvconst(pTHX_ register OP *o) { - dTHR; SVOP *kid = (SVOP*)cUNOPo->op_first; o->op_private |= (PL_hints & HINT_STRICT_REFS); @@ -5324,11 +5431,13 @@ Perl_ck_rvconst(pTHX_ register OP *o) #ifdef USE_ITHREADS /* XXX hack: dependence on sizeof(PADOP) <= sizeof(SVOP) */ kPADOP->op_padix = pad_alloc(OP_GV, SVs_PADTMP); + SvREFCNT_dec(PL_curpad[kPADOP->op_padix]); GvIN_PAD_on(gv); PL_curpad[kPADOP->op_padix] = SvREFCNT_inc(gv); #else kid->op_sv = SvREFCNT_inc(gv); #endif + kid->op_private = 0; kid->op_ppaddr = PL_ppaddr[OP_GV]; } } @@ -5338,7 +5447,6 @@ Perl_ck_rvconst(pTHX_ register OP *o) OP * Perl_ck_ftst(pTHX_ OP *o) { - dTHR; I32 type = o->op_type; if (o->op_flags & OPf_REF) { @@ -5376,7 +5484,6 @@ Perl_ck_ftst(pTHX_ OP *o) OP * Perl_ck_fun(pTHX_ OP *o) { - dTHR; register OP *kid; OP **tokid; OP *sibl; @@ -5616,6 +5723,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; } @@ -5701,10 +5809,13 @@ Perl_ck_lfun(pTHX_ OP *o) OP * Perl_ck_defined(pTHX_ OP *o) /* 19990527 MJD */ { - dTHR; if ((o->op_flags & OPf_KIDS) && ckWARN(WARN_DEPRECATED)) { switch (cUNOPo->op_first->op_type) { case OP_RV2AV: + /* This is needed for + if (defined %stash::) + to work. Do not break Tk. + */ break; /* Globals via GV can be undef */ case OP_PADAV: case OP_AASSIGN: /* Is this a good idea? */ @@ -5714,6 +5825,10 @@ Perl_ck_defined(pTHX_ OP *o) /* 19990527 MJD */ "\t(Maybe you should just omit the defined()?)\n"); break; case OP_RV2HV: + /* This is needed for + if (defined %stash::) + to work. Do not break Tk. + */ break; /* Globals via GV can be undef */ case OP_PADHV: Perl_warner(aTHX_ WARN_DEPRECATED, @@ -5932,6 +6047,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) @@ -5994,6 +6120,7 @@ Perl_ck_shift(pTHX_ OP *o) OP * Perl_ck_sort(pTHX_ OP *o) { + OP *firstkid; o->op_private = 0; #ifdef USE_LOCALE if (PL_hints & HINT_LOCALE) @@ -6002,10 +6129,10 @@ Perl_ck_sort(pTHX_ OP *o) if (o->op_type == OP_SORT && o->op_flags & OPf_STACKED) simplify_sort(o); - if (o->op_flags & OPf_STACKED) { /* may have been cleared */ - OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */ + firstkid = cLISTOPo->op_first->op_sibling; /* get past pushmark */ + if (o->op_flags & OPf_STACKED) { /* may have been cleared */ OP *k; - kid = kUNOP->op_first; /* get past null */ + OP *kid = cUNOPx(firstkid)->op_first; /* get past null */ if (kid->op_type == OP_SCOPE || kid->op_type == OP_LEAVE) { linklist(kid); @@ -6035,24 +6162,32 @@ Perl_ck_sort(pTHX_ OP *o) } peep(k); - kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */ - if (o->op_type == OP_SORT) + kid = firstkid; + if (o->op_type == OP_SORT) { + /* provide scalar context for comparison function/block */ + kid = scalar(kid); kid->op_next = kid; + } else kid->op_next = k; o->op_flags |= OPf_SPECIAL; } else if (kid->op_type == OP_RV2SV || kid->op_type == OP_PADSV) - null(cLISTOPo->op_first->op_sibling); + null(firstkid); + + firstkid = firstkid->op_sibling; } + /* provide list context for arguments */ + if (o->op_type == OP_SORT) + list(firstkid); + return o; } STATIC void S_simplify_sort(pTHX_ OP *o) { - dTHR; register OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */ OP *k; int reversed; @@ -6112,7 +6247,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 * @@ -6134,7 +6268,7 @@ Perl_ck_split(pTHX_ OP *o) cLISTOPo->op_last = kid; /* There was only one element previously */ } - if (kid->op_type != OP_MATCH) { + if (kid->op_type != OP_MATCH || kid->op_flags & OPf_STACKED) { OP *sibl = kid->op_sibling; kid->op_sibling = 0; kid = pmruntime( newPMOP(OP_MATCH, OPf_SPECIAL), kid, Nullop); @@ -6186,7 +6320,6 @@ Perl_ck_join(pTHX_ OP *o) OP * Perl_ck_subr(pTHX_ OP *o) { - dTHR; OP *prev = ((cUNOPo->op_first->op_sibling) ? cUNOPo : ((UNOP*)cUNOPo->op_first))->op_first; OP *o2 = prev->op_sibling; @@ -6251,7 +6384,9 @@ Perl_ck_subr(pTHX_ OP *o) proto++; arg++; if (o2->op_type != OP_REFGEN && o2->op_type != OP_UNDEF) - bad_type(arg, "block", gv_ename(namegv), o2); + bad_type(arg, + arg == 1 ? "block or sub {}" : "sub {}", + gv_ename(namegv), o2); break; case '*': /* '*' allows any scalar type, including bareword */ @@ -6299,8 +6434,8 @@ Perl_ck_subr(pTHX_ OP *o) bad_type(arg, "symbol", gv_ename(namegv), o2); goto wrapref; case '&': - if (o2->op_type != OP_RV2CV) - bad_type(arg, "sub", gv_ename(namegv), o2); + if (o2->op_type != OP_ENTERSUB) + bad_type(arg, "subroutine entry", gv_ename(namegv), o2); goto wrapref; case '$': if (o2->op_type != OP_RV2SV @@ -6378,15 +6513,29 @@ Perl_ck_trunc(pTHX_ OP *o) return ck_fun(o); } +OP * +Perl_ck_substr(pTHX_ OP *o) +{ + o = ck_fun(o); + if ((o->op_flags & OPf_KIDS) && o->op_private == 4) { + OP *kid = cLISTOPo->op_first; + + if (kid->op_type == OP_NULL) + kid = kid->op_sibling; + if (kid) + kid->op_flags |= OPf_MOD; + + } + return o; +} + /* A peephole optimizer. We visit the ops in the order they're to execute. */ void Perl_peep(pTHX_ register OP *o) { - dTHR; register OP* oldop = 0; STRLEN n_a; - OP *last_composite = Nullop; if (!o || o->op_seq) return; @@ -6405,7 +6554,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: @@ -6417,9 +6565,18 @@ Perl_peep(pTHX_ register OP *o) * for reference counts, sv_upgrade() etc. */ if (cSVOP->op_sv) { PADOFFSET ix = pad_alloc(OP_CONST, SVs_PADTMP); - SvREFCNT_dec(PL_curpad[ix]); - SvPADTMP_on(cSVOPo->op_sv); - PL_curpad[ix] = cSVOPo->op_sv; + if (SvPADTMP(cSVOPo->op_sv)) { + /* If op_sv is already a PADTMP then it is being used by + * another pad, so make a copy. */ + sv_setsv(PL_curpad[ix],cSVOPo->op_sv); + SvREADONLY_on(PL_curpad[ix]); + SvREFCNT_dec(cSVOPo->op_sv); + } + else { + SvREFCNT_dec(PL_curpad[ix]); + SvPADTMP_on(cSVOPo->op_sv); + PL_curpad[ix] = cSVOPo->op_sv; + } cSVOPo->op_sv = Nullsv; o->op_targ = ix; } @@ -6487,7 +6644,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) @@ -6535,9 +6692,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; @@ -6545,6 +6709,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; @@ -6677,42 +6844,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; |