X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=op.c;h=7d28e36dd03ca6de76376fa71426975a1bb010fb;hb=6ec152c37130b7e4730fc56d5699a4b02f7c0f4a;hp=d12eecc471550c7081e8b8385dae41cee067a1c5;hpb=b78ba3cc234763c7deff02f1d759b76b3a9ce5d1;p=p5sagit%2Fp5-mst-13.2.git diff --git a/op.c b/op.c index d12eecc..7d28e36 100644 --- a/op.c +++ b/op.c @@ -55,7 +55,7 @@ S_Slab_Alloc(pTHX_ int m, size_t sz) : CALL_FPTR(PL_check[type])(aTHX_ (OP*)o)) #define PAD_MAX 999999999 -#define RETVAL_MAX ( PERL_INT_MAX / 2 ) +#define RETURN_UNLIMITED_NUMBER (PERL_INT_MAX / 2) STATIC char* S_gv_ename(pTHX_ GV *gv) @@ -103,30 +103,6 @@ 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 @@ -843,6 +819,29 @@ S_op_clear(pTHX_ OP *o) case OP_MATCH: case OP_QR: clear_pmop: + { + HV *pmstash = PmopSTASH(cPMOPo); + if (pmstash && SvREFCNT(pmstash)) { + PMOP *pmop = HvPMROOT(pmstash); + PMOP *lastpmop = NULL; + while (pmop) { + if (cPMOPo == pmop) { + if (lastpmop) + lastpmop->op_pmnext = pmop->op_pmnext; + else + HvPMROOT(pmstash) = pmop->op_pmnext; + break; + } + lastpmop = pmop; + pmop = pmop->op_pmnext; + } +#ifdef USE_ITHREADS + Safefree(PmopSTASHPV(cPMOPo)); +#else + /* NOTE: PMOP.op_pmstash is not refcounted */ +#endif + } + } cPMOPo->op_pmreplroot = Nullop; ReREFCNT_dec(cPMOPo->op_pmregexp); cPMOPo->op_pmregexp = (REGEXP*)NULL; @@ -954,8 +953,6 @@ Perl_scalar(pTHX_ OP *o) switch (o->op_type) { case OP_REPEAT: - if (o->op_private & OPpREPEAT_DOLIST) - null(((LISTOP*)cBINOPo->op_first)->op_first); scalar(cBINOPo->op_first); break; case OP_OR: @@ -1140,6 +1137,9 @@ Perl_scalarvoid(pTHX_ OP *o) else { if (ckWARN(WARN_VOID)) { useless = "a constant"; + /* the constants 0 and 1 are permitted as they are + conventionally used as dummies in constructs like + 1 while some_condition_with_side_effects; */ if (SvNIOK(sv) && (SvNV(sv) == 0.0 || SvNV(sv) == 1.0)) useless = 0; else if (SvPOK(sv)) { @@ -1361,13 +1361,13 @@ Perl_mod(pTHX_ OP *o, I32 type) PL_modcount++; return o; case OP_CONST: - if (o->op_private & (OPpCONST_BARE) && + 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)) { + 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; @@ -1376,8 +1376,8 @@ Perl_mod(pTHX_ OP *o, I32 type) OP* enter; gv = gv_fetchpv(SvPV_nolen(sv), TRUE, SVt_PVCV); - enter = newUNOP(OP_ENTERSUB,0, - newUNOP(OP_RV2CV, 0, + enter = newUNOP(OP_ENTERSUB,0, + newUNOP(OP_RV2CV, 0, newGVOP(OP_GV, 0, gv) )); enter->op_private |= OPpLVAL_INTRO; @@ -1416,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; @@ -1550,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 = RETVAL_MAX; + PL_modcount = RETURN_UNLIMITED_NUMBER; return o; /* Treat \(@foo) like ordinary list. */ } /* FALL THROUGH */ @@ -1559,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 = RETVAL_MAX; + PL_modcount = RETURN_UNLIMITED_NUMBER; break; case OP_RV2SV: if (!type && cUNOPo->op_first->op_type != OP_GV) @@ -1585,11 +1588,13 @@ Perl_mod(pTHX_ OP *o, I32 type) case OP_PADAV: case OP_PADHV: - PL_modcount = RETVAL_MAX; + 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++; @@ -1617,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); @@ -1631,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; @@ -1655,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; @@ -1665,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; } @@ -1939,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 && @@ -2373,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 @@ -2392,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); } @@ -2426,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; } @@ -2447,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 @@ -2482,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; } @@ -2515,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) @@ -2535,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; } @@ -2614,15 +2627,16 @@ Perl_newBINOP(pTHX_ I32 type, I32 flags, OP *first, OP *last) } static int -utf8compare(const void *a, const void *b) -{ - int i; - for (i = 0; i < 10; i++) { - if ((*(U8**)a)[i] < (*(U8**)b)[i]) - return -1; - if ((*(U8**)a)[i] > (*(U8**)b)[i]) - return 1; - } +uvcompare(const void *a, const void *b) +{ + if (*((UV *)a) < (*(UV *)b)) + return -1; + if (*((UV *)a) > (*(UV *)b)) + return 1; + if (*((UV *)a+1) < (*(UV *)b+1)) + return -1; + if (*((UV *)a+1) > (*(UV *)b+1)) + return 1; return 0; } @@ -2643,6 +2657,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; @@ -2673,60 +2688,82 @@ Perl_pmtrans(pTHX_ OP *o, OP *expr, OP *repl) 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); + U8* tsave = NULL; + U8* rsave = NULL; + + if (!from_utf) { + STRLEN len = tlen; + tsave = t = bytes_to_utf8(t, &len); + tend = t + len; + } + if (!to_utf && rlen) { + STRLEN len = rlen; + rsave = r = bytes_to_utf8(r, &len); + rend = r + len; + } + +/* There are several snags with this code on EBCDIC: + 1. 0xFF is a legal UTF-EBCDIC byte (there are no illegal bytes). + 2. scan_const() in toke.c has encoded chars in native encoding which makes + ranges at least in EBCDIC 0..255 range the bottom odd. +*/ if (complement) { U8 tmpbuf[UTF8_MAXLEN+1]; - U8** cp; - I32* cl; + UV *cp; UV nextmin = 0; - New(1109, cp, tlen, U8*); + New(1109, cp, 2*tlen, UV); i = 0; transv = newSVpvn("",0); while (t < tend) { - cp[i++] = t; - t += UTF8SKIP(t); - if (*t == 0xff) { + cp[2*i] = utf8n_to_uvuni(t, tend-t, &ulen, 0); + t += ulen; + if (t < tend && NATIVE_TO_UTF(*t) == 0xff) { t++; - t += UTF8SKIP(t); + cp[2*i+1] = utf8n_to_uvuni(t, tend-t, &ulen, 0); + t += ulen; } + else { + cp[2*i+1] = cp[2*i]; + } + i++; } - qsort(cp, i, sizeof(U8*), utf8compare); + qsort(cp, i, 2*sizeof(UV), uvcompare); for (j = 0; j < i; j++) { - U8 *s = cp[j]; - I32 cur = j < i ? cp[j+1] - s : tend - s; - UV val = utf8_to_uv(s, cur, &ulen, 0); - s += ulen; + UV val = cp[2*j]; diff = val - nextmin; if (diff > 0) { - t = uv_to_utf8(tmpbuf,nextmin); + t = uvuni_to_utf8(tmpbuf,nextmin); sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf); if (diff > 1) { - t = uv_to_utf8(tmpbuf, val - 1); - sv_catpvn(transv, "\377", 1); + U8 range_mark = UTF_TO_NATIVE(0xff); + t = uvuni_to_utf8(tmpbuf, val - 1); + sv_catpvn(transv, (char *)&range_mark, 1); sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf); } } - if (*s == 0xff) - val = utf8_to_uv(s+1, cur - 1, &ulen, 0); + val = cp[2*j+1]; if (val >= nextmin) nextmin = val + 1; } - t = uv_to_utf8(tmpbuf,nextmin); + t = uvuni_to_utf8(tmpbuf,nextmin); sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf); - t = uv_to_utf8(tmpbuf, 0x7fffffff); - sv_catpvn(transv, "\377", 1); + { + U8 range_mark = UTF_TO_NATIVE(0xff); + sv_catpvn(transv, (char *)&range_mark, 1); + } + t = uvuni_to_utf8(tmpbuf, 0x7fffffff); sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf); 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 (t == r || + if ((!rlen && !del) || t == r || (tlen == rlen && memEQ((char *)t, (char *)r, tlen))) { o->op_private |= OPpTRANS_IDENTICAL; @@ -2736,11 +2773,11 @@ Perl_pmtrans(pTHX_ OP *o, OP *expr, OP *repl) while (t < tend || tfirst <= tlast) { /* see if we need more "t" chars */ if (tfirst > tlast) { - tfirst = (I32)utf8_to_uv(t, tend - t, &ulen, 0); + tfirst = (I32)utf8n_to_uvuni(t, tend - t, &ulen, 0); t += ulen; - if (t < tend && *t == 0xff) { /* illegal utf8 val indicates range */ + if (t < tend && NATIVE_TO_UTF(*t) == 0xff) { /* illegal utf8 val indicates range */ t++; - tlast = (I32)utf8_to_uv(t, tend - t, &ulen, 0); + tlast = (I32)utf8n_to_uvuni(t, tend - t, &ulen, 0); t += ulen; } else @@ -2750,11 +2787,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, rend - r, &ulen, 0); + rfirst = (I32)utf8n_to_uvuni(r, rend - r, &ulen, 0); r += ulen; - if (r < rend && *r == 0xff) { /* illegal utf8 val indicates range */ + if (r < rend && NATIVE_TO_UTF(*r) == 0xff) { /* illegal utf8 val indicates range */ r++; - rlast = (I32)utf8_to_uv(r, rend - r, &ulen, 0); + rlast = (I32)utf8n_to_uvuni(r, rend - r, &ulen, 0); r += ulen; } else @@ -2795,9 +2832,10 @@ Perl_pmtrans(pTHX_ OP *o, OP *expr, OP *repl) if (rfirst + diff > max) max = rfirst + diff; - rfirst += diff + 1; if (!grows) - grows = (UNISKIP(tfirst) < UNISKIP(rfirst)); + grows = (tfirst < rfirst && + UNISKIP(tfirst) < UNISKIP(rfirst + diff)); + rfirst += diff + 1; } tfirst += diff + 1; } @@ -2813,12 +2851,13 @@ 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) SvREFCNT_dec(transv); - if (!del && havefinal) + if (!del && havefinal && rlen) (void)hv_store((HV*)SvRV((cSVOPo->op_sv)), "FINAL", 5, newSVuv((UV)final), 0); @@ -2857,6 +2896,20 @@ Perl_pmtrans(pTHX_ OP *o, OP *expr, OP *repl) } } } + if (!del) { + if (!rlen) { + j = rlen; + if (!squash) + o->op_private |= OPpTRANS_IDENTICAL; + } + else 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) { @@ -2911,6 +2964,7 @@ Perl_newPMOP(pTHX_ I32 type, I32 flags) if (type != OP_TRANS && PL_curstash) { pmop->op_pmnext = HvPMROOT(PL_curstash); HvPMROOT(PL_curstash) = pmop; + PmopSTASH_set(pmop,PL_curstash); } return (OP*)pmop; @@ -3256,6 +3310,20 @@ Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *id, OP *arg) PL_expect = XSTATE; } +/* +=for apidoc load_module + +Loads the module whose name is pointed to by the string part of name. +Note that the actual module name, not its filename, should be given. +Eg, "Foo::Bar" instead of "Foo/Bar.pm". flags can be any of +PERL_LOADMOD_DENY, PERL_LOADMOD_NOIMPORT, or PERL_LOADMOD_IMPORT_OPS +(or 0 for no flags). ver, if specified, provides version semantics +similar to C. The optional trailing SV* +arguments can be used to specify arguments to the module's import() +method, similar to C. + +=cut */ + void Perl_load_module(pTHX_ U32 flags, SV *name, SV *ver, ...) { @@ -3503,7 +3571,7 @@ Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right) } } else { - if (PL_modcount < RETVAL_MAX && + if (PL_modcount < RETURN_UNLIMITED_NUMBER && ((LISTOP*)right)->op_last->op_type == OP_CONST) { SV *sv = ((SVOP*)((LISTOP*)right)->op_last)->op_sv; @@ -3551,7 +3619,7 @@ Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o) cop->op_ppaddr = PL_ppaddr[ OP_NEXTSTATE ]; } cop->op_flags = flags; - cop->op_private = (PL_hints & HINT_BYTE); + cop->op_private = (PL_hints & HINT_PRIVATE_MASK); #ifdef NATIVE_HINTS cop->op_private |= NATIVE_HINTS; #endif @@ -4134,16 +4202,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 (CvCONST(cv)) { SvREFCNT_dec((SV*)CvXSUBANY(cv).any_ptr); @@ -4170,8 +4241,10 @@ Perl_cv_undef(pTHX_ CV *cv) } CvPADLIST(cv) = Nullav; } + CvFLAGS(cv) = 0; } +#ifdef DEBUG_CLOSURES STATIC void S_cv_dump(pTHX_ CV *cv) { @@ -4218,6 +4291,7 @@ S_cv_dump(pTHX_ CV *cv) } #endif /* DEBUGGING */ } +#endif /* DEBUG_CLOSURES */ STATIC CV * S_cv_clone2(pTHX_ CV *proto, CV *outside) @@ -4252,9 +4326,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); @@ -4540,6 +4614,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 @@ -4547,6 +4627,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 @@ -4637,8 +4724,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 { @@ -4649,7 +4758,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 @@ -4689,7 +4798,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)); @@ -4740,6 +4850,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); @@ -4924,7 +5041,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)); @@ -4997,6 +5114,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)) { @@ -5010,7 +5132,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--) { @@ -5575,6 +5697,12 @@ Perl_ck_fun(pTHX_ OP *o) list(kid); break; case OA_AVREF: + if ((type == OP_PUSH || type == OP_UNSHIFT) + && !kid->op_sibling && ckWARN(WARN_SYNTAX)) + Perl_warner(aTHX_ WARN_SYNTAX, + "Useless use of %s with no values", + PL_op_desc[type]); + if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) { @@ -5738,11 +5866,15 @@ Perl_ck_glob(pTHX_ OP *o) #if !defined(PERL_EXTERNAL_GLOB) /* XXX this can be tightened up and made more failsafe. */ if (!gv) { + GV *glob_gv; ENTER; - Perl_load_module(aTHX_ 0, newSVpvn("File::Glob", 10), Nullsv, - /* null-terminated import list */ - newSVpvn(":globally", 9), Nullsv); + Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT, newSVpvn("File::Glob", 10), Nullsv, + Nullsv, Nullsv); gv = gv_fetchpv("CORE::GLOBAL::glob", FALSE, SVt_PVCV); + glob_gv = gv_fetchpv("File::Glob::csh_glob", FALSE, SVt_PVCV); + GvCV(gv) = GvCV(glob_gv); + SvREFCNT_inc((SV*)GvCV(gv)); + GvIMPORTED_CV_on(gv); LEAVE; } #endif /* PERL_EXTERNAL_GLOB */ @@ -6090,6 +6222,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) @@ -6279,7 +6422,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 * @@ -6569,7 +6711,6 @@ Perl_peep(pTHX_ register OP *o) { register OP* oldop = 0; STRLEN n_a; - OP *last_composite = Nullop; if (!o || o->op_seq) return; @@ -6588,7 +6729,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: @@ -6681,8 +6821,8 @@ 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)) && - (i = SvIV(((SVOP*)pop)->op_sv) - PL_compiling.cop_arybase) + (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB)) && + (i = SvIV(((SVOP*)pop)->op_sv) - PL_curcop->cop_arybase) <= 255 && i >= 0) { @@ -6729,6 +6869,7 @@ 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; @@ -6745,7 +6886,7 @@ Perl_peep(pTHX_ register OP *o) case OP_MATCH: case OP_SUBST: o->op_seq = PL_op_seqmax++; - while (cPMOP->op_pmreplstart && + while (cPMOP->op_pmreplstart && cPMOP->op_pmreplstart->op_type == OP_NULL) cPMOP->op_pmreplstart = cPMOP->op_pmreplstart->op_next; peep(cPMOP->op_pmreplstart); @@ -6898,42 +7039,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; @@ -6950,7 +7055,14 @@ 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); } +