X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/de39bd3b991df13674c4416d3edd61ba5ee124ba..a0cb39004565ec2396fbdb3f1949b8f13304208e:/op.c diff --git a/op.c b/op.c index 0ba050d..6e42527 100644 --- a/op.c +++ b/op.c @@ -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 @@ -207,10 +183,9 @@ Perl_pad_allocmy(pTHX_ char *name) if (*name != '$') yyerror(Perl_form(aTHX_ "Can't declare class for non-scalar %s in \"%s\"", name, PL_in_my == KEY_our ? "our" : "my")); - SvOBJECT_on(sv); + SvFLAGS(sv) |= SVpad_TYPED; (void)SvUPGRADE(sv, SVt_PVMG); SvSTASH(sv) = (HV*)SvREFCNT_inc(PL_in_my_stash); - PL_sv_objcount++; } if (PL_in_my == KEY_our) { (void)SvUPGRADE(sv, SVt_PVGV); @@ -247,11 +222,10 @@ S_pad_addlex(pTHX_ SV *proto_namesv) (void)SvUPGRADE(namesv, SVt_PVGV); GvSTASH(namesv) = (HV*)SvREFCNT_inc((SV*)GvSTASH(proto_namesv)); } - if (SvOBJECT(proto_namesv)) { /* A typed var */ - SvOBJECT_on(namesv); + if (SvFLAGS(proto_namesv) & SVpad_TYPED) { /* A typed lexical */ + SvFLAGS(namesv) |= SVpad_TYPED; (void)SvUPGRADE(namesv, SVt_PVMG); SvSTASH(namesv) = (HV*)SvREFCNT_inc((SV*)SvSTASH(proto_namesv)); - PL_sv_objcount++; } return newoff; } @@ -372,15 +346,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: @@ -397,7 +380,6 @@ S_pad_findlex(pTHX_ char *name, PADOFFSET newoff, U32 seq, CV* startcv, saweval = i; /* so we know where we were called from */ continue; } - seq = cxstack[saweval].blk_oldcop->cop_seq; return pad_findlex(name, newoff, seq, cv, i-1, saweval,FINDLEX_NOSEARCH); } } @@ -667,7 +649,7 @@ Perl_find_threadsv(pTHX_ const char *name) break; case ';': sv_setpv(sv, "\034"); - sv_magic(sv, 0, 0, name, 1); + sv_magic(sv, 0, PERL_MAGIC_sv, name, 1); break; case '&': case '`': @@ -691,7 +673,7 @@ Perl_find_threadsv(pTHX_ const char *name) /* case '!': */ default: - sv_magic(sv, 0, 0, name, 1); + sv_magic(sv, 0, PERL_MAGIC_sv, name, 1); } DEBUG_S(PerlIO_printf(Perl_error_log, "find_threadsv: new SV %p for $%s%c\n", @@ -759,8 +741,8 @@ Perl_op_free(pTHX_ OP *o) #endif } -STATIC void -S_op_clear(pTHX_ OP *o) +void +Perl_op_clear(pTHX_ OP *o) { switch (o->op_type) { case OP_NULL: /* Was holding old type, if any. */ @@ -843,6 +825,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; @@ -872,8 +877,8 @@ S_cop_free(pTHX_ COP* cop) SvREFCNT_dec(cop->cop_io); } -STATIC void -S_null(pTHX_ OP *o) +void +Perl_op_null(pTHX_ OP *o) { if (o->op_type == OP_NULL) return; @@ -954,8 +959,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 +1143,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)) { @@ -1156,7 +1162,7 @@ Perl_scalarvoid(pTHX_ OP *o) } } } - null(o); /* don't execute or even remember it */ + op_null(o); /* don't execute or even remember it */ break; case OP_POSTINC: @@ -1361,31 +1367,6 @@ 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) { @@ -1411,7 +1392,7 @@ Perl_mod(pTHX_ OP *o, I32 type) o->op_type = OP_RV2CV; /* entersub => rv2cv */ o->op_ppaddr = PL_ppaddr[OP_RV2CV]; assert(cUNOPo->op_first->op_type == OP_NULL); - null(((LISTOP*)cUNOPo->op_first)->op_first);/* disable pushmark */ + op_null(((LISTOP*)cUNOPo->op_first)->op_first);/* disable pushmark */ break; } else { /* lvalue subroutine call */ @@ -1783,7 +1764,7 @@ Perl_ref(pTHX_ OP *o, I32 type) o->op_type = OP_RV2CV; /* entersub => rv2cv */ o->op_ppaddr = PL_ppaddr[OP_RV2CV]; assert(cUNOPo->op_first->op_type == OP_NULL); - null(((LISTOP*)cUNOPo->op_first)->op_first); /* disable pushmark */ + op_null(((LISTOP*)cUNOPo->op_first)->op_first); /* disable pushmark */ o->op_flags |= OPf_SPECIAL; } break; @@ -1988,7 +1969,8 @@ S_my_kid(pTHX_ OP *o, OP *attrs) /* check for C when deciding package */ namesvp = av_fetch(PL_comppad_name, o->op_targ, FALSE); - if (namesvp && *namesvp && SvOBJECT(*namesvp) && HvNAME(SvSTASH(*namesvp))) + if (namesvp && *namesvp && (SvFLAGS(*namesvp) & SVpad_TYPED) + && HvNAME(SvSTASH(*namesvp))) stash = SvSTASH(*namesvp); else stash = PL_curstash; @@ -2095,7 +2077,7 @@ Perl_scope(pTHX_ OP *o) o->op_ppaddr = PL_ppaddr[OP_SCOPE]; kid = ((LISTOP*)o)->op_first; if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) - null(kid); + op_null(kid); } else o = newLISTOP(OP_SCOPE, 0, o, Nullop); @@ -2293,8 +2275,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; } @@ -2406,7 +2388,7 @@ Perl_convert(pTHX_ I32 type, I32 flags, OP *o) o->op_flags &= ~OPf_WANT; if (!(PL_opargs[type] & OA_MARK)) - null(cLISTOPo->op_first); + op_null(cLISTOPo->op_first); o->op_type = type; o->op_ppaddr = PL_ppaddr[type]; @@ -2516,7 +2498,7 @@ Perl_force_list(pTHX_ OP *o) { if (!o || o->op_type != OP_LIST) o = newLISTOP(OP_LIST, 0, o, Nullop); - null(o); + op_null(o); return o; } @@ -2627,15 +2609,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; } @@ -2656,6 +2639,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; @@ -2683,52 +2667,74 @@ Perl_pmtrans(pTHX_ OP *o, OP *expr, OP *repl) U32 max = 0; I32 bits; I32 havefinal = 0; - U32 final; + U32 final = 0; 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; + 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 < tend && *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 - 1 ? 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 < tend && *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); @@ -2739,7 +2745,7 @@ Perl_pmtrans(pTHX_ OP *o, OP *expr, OP *repl) 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; @@ -2749,11 +2755,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 @@ -2763,11 +2769,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 @@ -2808,9 +2814,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; } @@ -2832,7 +2839,7 @@ Perl_pmtrans(pTHX_ OP *o, OP *expr, OP *repl) 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); @@ -2871,6 +2878,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) { @@ -2925,6 +2946,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; @@ -3177,10 +3199,8 @@ void Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *id, OP *arg) { OP *pack; - OP *rqop; OP *imop; OP *veop; - GV *gv; if (id->op_type != OP_CONST) Perl_croak(aTHX_ "Module name must be constant"); @@ -3238,22 +3258,6 @@ Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *id, OP *arg) newSVOP(OP_METHOD_NAMED, 0, meth))); } - /* Fake up a require, handle override, if any */ - gv = gv_fetchpv("require", FALSE, SVt_PVCV); - if (!(gv && GvIMPORTED_CV(gv))) - gv = gv_fetchpv("CORE::GLOBAL::require", FALSE, SVt_PVCV); - - if (gv && GvIMPORTED_CV(gv)) { - rqop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED, - append_elem(OP_LIST, id, - scalar(newUNOP(OP_RV2CV, 0, - newGVOP(OP_GV, 0, - gv)))))); - } - else { - rqop = newUNOP(OP_REQUIRE, 0, id); - } - /* Fake up the BEGIN {}, which does its thing immediately. */ newATTRSUB(floor, newSVOP(OP_CONST, 0, newSVpvn("BEGIN", 5)), @@ -3261,7 +3265,7 @@ Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *id, OP *arg) Nullop, append_elem(OP_LINESEQ, append_elem(OP_LINESEQ, - newSTATEOP(0, Nullch, rqop), + newSTATEOP(0, Nullch, newUNOP(OP_REQUIRE, 0, id)), newSTATEOP(0, Nullch, veop)), newSTATEOP(0, Nullch, imop) )); @@ -3270,6 +3274,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, ...) { @@ -3565,7 +3583,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 @@ -4071,7 +4089,7 @@ Perl_newFOROP(pTHX_ I32 flags,char *label,line_t forline,OP *sv,OP *expr,OP *blo op_free(expr); expr = (OP*)(listop); - null(expr); + op_null(expr); iterflags |= OPf_STACKED; } else { @@ -4148,14 +4166,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 */ 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 (CvCONST(cv)) { SvREFCNT_dec((SV*)CvXSUBANY(cv).any_ptr); @@ -4182,6 +4211,9 @@ Perl_cv_undef(pTHX_ CV *cv) } CvPADLIST(cv) = Nullav; } + if (CvXSUB(cv)) { + CvXSUB(cv) = 0; + } CvFLAGS(cv) = 0; } @@ -4269,7 +4301,7 @@ S_cv_clone2(pTHX_ CV *proto, CV *outside) CvFILE(cv) = CvFILE(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); @@ -4665,8 +4697,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 { @@ -4769,6 +4823,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); @@ -5147,6 +5213,11 @@ Perl_newAVREF(pTHX_ OP *o) o->op_ppaddr = PL_ppaddr[OP_PADAV]; return o; } + else if ((o->op_type == OP_RV2AV || o->op_type == OP_PADAV) + && ckWARN(WARN_DEPRECATED)) { + Perl_warner(aTHX_ WARN_DEPRECATED, + "Using an array as a reference is deprecated"); + } return newUNOP(OP_RV2AV, 0, scalar(o)); } @@ -5166,6 +5237,11 @@ Perl_newHVREF(pTHX_ OP *o) o->op_ppaddr = PL_ppaddr[OP_PADHV]; return o; } + else if ((o->op_type == OP_RV2HV || o->op_type == OP_PADHV) + && ckWARN(WARN_DEPRECATED)) { + Perl_warner(aTHX_ WARN_DEPRECATED, + "Using a hash as a reference is deprecated"); + } return newUNOP(OP_RV2HV, 0, scalar(o)); } @@ -5283,7 +5359,7 @@ Perl_ck_delete(pTHX_ OP *o) Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element or slice", PL_op_desc[o->op_type]); } - null(kid); + op_null(kid); } return o; } @@ -5313,7 +5389,7 @@ Perl_ck_eval(pTHX_ OP *o) if (!kid) { o->op_flags &= ~OPf_KIDS; - null(o); + op_null(o); } else if (kid->op_type == OP_LINESEQ) { LOGOP *enter; @@ -5369,7 +5445,7 @@ Perl_ck_exec(pTHX_ OP *o) o = ck_fun(o); kid = cUNOPo->op_first->op_sibling; if (kid->op_type == OP_RV2GV) - null(kid); + op_null(kid); } else o = listkids(o); @@ -5394,7 +5470,7 @@ Perl_ck_exists(pTHX_ OP *o) else if (kid->op_type != OP_HELEM) Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element", PL_op_desc[o->op_type]); - null(kid); + op_null(kid); } return o; } @@ -5547,13 +5623,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; } @@ -5609,6 +5678,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)) { @@ -5772,11 +5847,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 */ @@ -5799,7 +5878,6 @@ 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; } @@ -5954,29 +6032,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 * @@ -6010,18 +6066,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; @@ -6101,6 +6145,8 @@ Perl_ck_repeat(pTHX_ OP *o) OP * Perl_ck_require(pTHX_ OP *o) { + GV* gv; + if (o->op_flags & OPf_KIDS) { /* Shall we supply missing .pm? */ SVOP *kid = (SVOP*)cUNOPo->op_first; @@ -6122,6 +6168,23 @@ Perl_ck_require(pTHX_ OP *o) sv_catpvn(kid->op_sv, ".pm", 3); } } + + /* handle override, if any */ + gv = gv_fetchpv("require", FALSE, SVt_PVCV); + if (!(gv && GvIMPORTED_CV(gv))) + gv = gv_fetchpv("CORE::GLOBAL::require", FALSE, SVt_PVCV); + + if (gv && GvIMPORTED_CV(gv)) { + OP *kid = cUNOPo->op_first; + cUNOPo->op_first = 0; + op_free(o); + return ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED, + append_elem(OP_LIST, kid, + scalar(newUNOP(OP_RV2CV, 0, + newGVOP(OP_GV, 0, + gv)))))); + } + return ck_fun(o); } @@ -6199,17 +6262,12 @@ 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); firstkid = cLISTOPo->op_first->op_sibling; /* get past pushmark */ if (o->op_flags & OPf_STACKED) { /* may have been cleared */ - OP *k; + OP *k = NULL; OP *kid = cUNOPx(firstkid)->op_first; /* get past null */ if (kid->op_type == OP_SCOPE || kid->op_type == OP_LEAVE) { @@ -6220,7 +6278,7 @@ Perl_ck_sort(pTHX_ OP *o) } else if (kid->op_type == OP_LEAVE) { if (o->op_type == OP_SORT) { - null(kid); /* wipe out leave */ + op_null(kid); /* wipe out leave */ kid->op_next = kid; for (k = kLISTOP->op_first->op_next; k; k = k->op_next) { @@ -6251,7 +6309,7 @@ Perl_ck_sort(pTHX_ OP *o) o->op_flags |= OPf_SPECIAL; } else if (kid->op_type == OP_RV2SV || kid->op_type == OP_PADSV) - null(firstkid); + op_null(firstkid); firstkid = firstkid->op_sibling; } @@ -6414,7 +6472,7 @@ Perl_ck_subr(pTHX_ OP *o) if (cvop->op_type == OP_RV2CV) { SVOP* tmpop; o->op_private |= (cvop->op_private & OPpENTERSUB_AMPER); - null(cvop); /* disable rv2cv */ + op_null(cvop); /* disable rv2cv */ tmpop = (SVOP*)((UNOP*)cvop)->op_first; if (tmpop->op_type == OP_GV && !(o->op_private & OPpENTERSUB_AMPER)) { GV *gv = cGVOPx_gv(tmpop); @@ -6676,7 +6734,7 @@ Perl_peep(pTHX_ register OP *o) o->op_private |= OPpTARGET_MY; } } - null(o->op_next); + op_null(o->op_next); } ignore_optimization: o->op_seq = PL_op_seqmax++; @@ -6709,7 +6767,7 @@ Perl_peep(pTHX_ register OP *o) case OP_GV: if (o->op_next->op_type == OP_RV2SV) { if (!(o->op_next->op_private & OPpDEREF)) { - null(o->op_next); + op_null(o->op_next); o->op_private |= o->op_next->op_private & (OPpLVAL_INTRO | OPpOUR_INTRO); o->op_next = o->op_next->op_next; @@ -6725,14 +6783,14 @@ Perl_peep(pTHX_ register OP *o) pop->op_next->op_type == OP_AELEM && !(pop->op_next->op_private & (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB)) && - (i = SvIV(((SVOP*)pop)->op_sv) - PL_compiling.cop_arybase) + (i = SvIV(((SVOP*)pop)->op_sv) - PL_curcop->cop_arybase) <= 255 && i >= 0) { GV *gv; - null(o->op_next); - null(pop->op_next); - null(pop); + op_null(o->op_next); + op_null(pop->op_next); + op_null(pop); o->op_flags |= pop->op_next->op_flags & OPf_MOD; o->op_next = pop->op_next->op_next; o->op_type = OP_AELEMFAST; @@ -6772,6 +6830,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; @@ -6788,7 +6847,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); @@ -6846,7 +6905,7 @@ Perl_peep(pTHX_ register OP *o) if (rop->op_type != OP_RV2HV || rop->op_first->op_type != OP_PADSV) break; lexname = *av_fetch(PL_comppad_name, rop->op_first->op_targ, TRUE); - if (!SvOBJECT(lexname)) + if (!(SvFLAGS(lexname) & SVpad_TYPED)) break; fields = (GV**)hv_fetch(SvSTASH(lexname), "FIELDS", 6, FALSE); if (!fields || !GvHV(*fields)) @@ -6896,7 +6955,7 @@ Perl_peep(pTHX_ register OP *o) if (rop->op_type != OP_RV2HV || rop->op_first->op_type != OP_PADSV) break; lexname = *av_fetch(PL_comppad_name, rop->op_first->op_targ, TRUE); - if (!SvOBJECT(lexname)) + if (!(SvFLAGS(lexname) & SVpad_TYPED)) break; fields = (GV**)hv_fetch(SvSTASH(lexname), "FIELDS", 6, FALSE); if (!fields || !GvHV(*fields)) @@ -6967,3 +7026,4 @@ const_sv_xsub(pTHXo_ CV* cv) ST(0) = (SV*)XSANY.any_ptr; XSRETURN(1); } +