X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=op.c;h=207e762b807391bc60488f17f350067f09757701;hb=9d43a7557743d779c74d69ffc6df7fc17711f3ec;hp=4c5dd1302bcbc222764c21688b5c4a59a8be3108;hpb=8973db79328a885c91b9dfdcafdb28dbe9e65a88;p=p5sagit%2Fp5-mst-13.2.git diff --git a/op.c b/op.c index 4c5dd13..207e762 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 @@ -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: @@ -1361,7 +1358,7 @@ 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; @@ -1376,8 +1373,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; @@ -2627,15 +2624,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 +2654,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; @@ -2686,49 +2685,71 @@ 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; + 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 +2760,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 +2770,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 +2784,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 +2829,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 +2854,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); @@ -2872,7 +2894,12 @@ Perl_pmtrans(pTHX_ OP *o, OP *expr, OP *repl) } } if (!del) { - if (j >= rlen) + 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); @@ -2934,6 +2961,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; @@ -3279,6 +3307,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, ...) { @@ -3574,7 +3616,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 @@ -4157,14 +4199,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 */ 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); @@ -4278,7 +4325,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); @@ -4674,8 +4721,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 { @@ -4778,6 +4847,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); @@ -5618,6 +5694,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)) { @@ -5781,11 +5863,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 */ @@ -6733,7 +6819,7 @@ 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) { @@ -6780,6 +6866,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; @@ -6796,7 +6883,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); @@ -6975,3 +7062,4 @@ const_sv_xsub(pTHXo_ CV* cv) ST(0) = (SV*)XSANY.any_ptr; XSRETURN(1); } +