X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=op.c;h=daefb1493e1473bbd97572b9a179021db54f9be6;hb=206b12d5641a74e09d210dd4ea3998febd96392f;hp=2228289832c3263d9d28cff1ebf614746cfeac96;hpb=5629c67553f30a19f4842982925a3d994d46684c;p=p5sagit%2Fp5-mst-13.2.git diff --git a/op.c b/op.c index 2228289..daefb14 100644 --- a/op.c +++ b/op.c @@ -20,6 +20,8 @@ #include "perl.h" #include "keywords.h" +#define CALL_PEEP(o) CALL_FPTR(PL_peepp)(aTHX_ o) + /* #define PL_OP_SLAB_ALLOC */ #ifdef PL_OP_SLAB_ALLOC @@ -842,16 +844,22 @@ clear_pmop: lastpmop = pmop; pmop = pmop->op_pmnext; } + } #ifdef USE_ITHREADS - Safefree(PmopSTASHPV(cPMOPo)); + Safefree(PmopSTASHPV(cPMOPo)); #else - /* NOTE: PMOP.op_pmstash is not refcounted */ + /* NOTE: PMOP.op_pmstash is not refcounted */ #endif - } } cPMOPo->op_pmreplroot = Nullop; - ReREFCNT_dec(PM_GETRE(cPMOPo)); - PM_SETRE(cPMOPo, (REGEXP*)NULL); + /* we use the "SAFE" version of the PM_ macros here + * since sv_clean_all might release some PMOPs + * after PL_regex_padav has been cleared + * and the clearing of PL_regex_padav needs to + * happen before sv_clean_all + */ + ReREFCNT_dec(PM_GETRE_SAFE(cPMOPo)); + PM_SETRE_SAFE(cPMOPo, (REGEXP*)NULL); break; } @@ -2035,9 +2043,15 @@ Perl_bind_match(pTHX_ I32 type, OP *left, OP *right) right->op_type == OP_SUBST || right->op_type == OP_TRANS)) { right->op_flags |= OPf_STACKED; - if (right->op_type != OP_MATCH && - ! (right->op_type == OP_TRANS && - right->op_private & OPpTRANS_IDENTICAL)) + if ((right->op_type != OP_MATCH && + ! (right->op_type == OP_TRANS && + right->op_private & OPpTRANS_IDENTICAL)) || + /* if SV has magic, then match on original SV, not on its copy. + see note in pp_helem() */ + (right->op_type == OP_MATCH && + (left->op_type == OP_AELEM || + left->op_type == OP_HELEM || + left->op_type == OP_AELEMFAST))) left = mod(left, right->op_type); if (right->op_type == OP_TRANS) o = newBINOP(OP_NULL, OPf_STACKED, scalar(left), right); @@ -2168,7 +2182,7 @@ Perl_newPROG(pTHX_ OP *o) PL_eval_root->op_private |= OPpREFCOUNTED; OpREFCNT_set(PL_eval_root, 1); PL_eval_root->op_next = 0; - peep(PL_eval_start); + CALL_PEEP(PL_eval_start); } else { if (!o) @@ -2179,7 +2193,7 @@ Perl_newPROG(pTHX_ OP *o) PL_main_root->op_private |= OPpREFCOUNTED; OpREFCNT_set(PL_main_root, 1); PL_main_root->op_next = 0; - peep(PL_main_start); + CALL_PEEP(PL_main_start); PL_compcv = 0; /* Register with debugger */ @@ -2202,9 +2216,14 @@ Perl_localize(pTHX_ OP *o, I32 lex) if (o->op_flags & OPf_PARENS) list(o); else { - if (ckWARN(WARN_PARENTHESIS) && PL_bufptr > PL_oldbufptr && PL_bufptr[-1] == ',') { - char *s; - for (s = PL_bufptr; *s && (isALNUM(*s) || UTF8_IS_CONTINUED(*s) || strchr("@$%, ",*s)); s++) ; + if (ckWARN(WARN_PARENTHESIS) + && PL_bufptr > PL_oldbufptr && PL_bufptr[-1] == ',') + { + char *s = PL_bufptr; + + while (*s && (isALNUM(*s) || UTF8_IS_CONTINUED(*s) || strchr("@$%, ", *s))) + s++; + if (*s == ';' || *s == '=') Perl_warner(aTHX_ WARN_PARENTHESIS, "Parentheses missing around \"%s\" list", @@ -2363,7 +2382,7 @@ Perl_gen_constant_list(pTHX_ register OP *o) PL_op = curop = LINKLIST(o); o->op_next = 0; - peep(curop); + CALL_PEEP(curop); pp_pushmark(); CALLRUNOPS(aTHX); PL_op = curop; @@ -2942,7 +2961,16 @@ Perl_newPMOP(pTHX_ I32 type, I32 flags) pmop->op_pmpermflags |= PMf_LOCALE; pmop->op_pmflags = pmop->op_pmpermflags; - /* link into pm list */ + #ifdef USE_ITHREADS + { + SV* repointer = newSViv(0); + av_push(PL_regex_padav,SvREFCNT_inc(repointer)); + pmop->op_pmoffset = av_len(PL_regex_padav); + PL_regex_pad = AvARRAY(PL_regex_padav); + } + #endif + + /* link into pm list */ if (type != OP_TRANS && PL_curstash) { pmop->op_pmnext = HvPMROOT(PL_curstash); HvPMROOT(PL_curstash) = pmop; @@ -3187,6 +3215,7 @@ Perl_package(pTHX_ OP *o) op_free(o); } else { + deprecate("\"package\" with no arguments"); sv_setpv(PL_curstname,""); PL_curstash = Nullhv; } @@ -3201,6 +3230,9 @@ Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *id, OP *arg) OP *pack; OP *imop; OP *veop; + char *packname = Nullch; + STRLEN packlen = 0; + SV *packsv; if (id->op_type != OP_CONST) Perl_croak(aTHX_ "Module name must be constant"); @@ -3258,6 +3290,15 @@ Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *id, OP *arg) newSVOP(OP_METHOD_NAMED, 0, meth))); } + if (ckWARN(WARN_MISC) && + imop && (imop != arg) && /* no warning on use 5.0; or explicit () */ + SvPOK(packsv = ((SVOP*)id)->op_sv)) + { + /* BEGIN will free the ops, so we need to make a copy */ + packlen = SvCUR(packsv); + packname = savepvn(SvPVX(packsv), packlen); + } + /* Fake up the BEGIN {}, which does its thing immediately. */ newATTRSUB(floor, newSVOP(OP_CONST, 0, newSVpvn("BEGIN", 5)), @@ -3269,6 +3310,15 @@ Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *id, OP *arg) newSTATEOP(0, Nullch, veop)), newSTATEOP(0, Nullch, imop) )); + if (packname) { + if (ckWARN(WARN_MISC) && !gv_stashpvn(packname, packlen, FALSE)) { + Perl_warner(aTHX_ WARN_MISC, + "Package `%s' not found " + "(did you use the incorrect case?)", packname); + } + safefree(packname); + } + PL_hints |= HINT_BLOCK_SCOPE; PL_copline = NOLINE; PL_expect = XSTATE; @@ -3931,7 +3981,6 @@ Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop, I32 whileline, OP * OP *next = 0; OP *listop; OP *o; - OP *condop; U8 loopflags = 0; if (expr && (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB @@ -3993,7 +4042,7 @@ Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop, I32 whileline, OP * return Nullop; /* listop already freed by new_logop */ } if (listop) - ((LISTOP*)listop)->op_last->op_next = condop = + ((LISTOP*)listop)->op_last->op_next = (o == listop ? redo : LINKLIST(o)); } else @@ -4153,6 +4202,14 @@ Perl_cv_undef(pTHX_ CV *cv) } #endif /* USE_THREADS */ +#ifdef USE_ITHREADS + if (CvFILE(cv) && !CvXSUB(cv)) { + /* for XSUBs CvFILE point directly to static memory; __FILE__ */ + Safefree(CvFILE(cv)); + } + CvFILE(cv) = 0; +#endif + if (!CvXSUB(cv) && CvROOT(cv)) { #ifdef USE_THREADS if (CvDEPTH(cv) || (CvOWNER(cv) && CvOWNER(cv) != thr)) @@ -4298,7 +4355,12 @@ S_cv_clone2(pTHX_ CV *proto, CV *outside) MUTEX_INIT(CvMUTEXP(cv)); CvOWNER(cv) = 0; #endif /* USE_THREADS */ +#ifdef USE_ITHREADS + CvFILE(cv) = CvXSUB(proto) ? CvFILE(proto) + : savepv(CvFILE(proto)); +#else CvFILE(cv) = CvFILE(proto); +#endif CvGV(cv) = CvGV(proto); CvSTASH(cv) = CvSTASH(proto); CvROOT(cv) = OpREFCNT_inc(CvROOT(proto)); @@ -4587,9 +4649,9 @@ 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); +#ifdef GV_UNIQUE_CHECK + if (cv && GvUNIQUE(gv) && SvREADONLY(cv)) { + Perl_croak(aTHX_ "Can't define subroutine %s (GV is unique)", name); } #endif @@ -4601,9 +4663,9 @@ 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); +#ifdef GV_UNIQUE_CHECK + if (exists && GvUNIQUE(gv)) { + Perl_croak(aTHX_ "Can't redefine unique subroutine %s", name); } #endif @@ -4722,6 +4784,8 @@ Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block) } /* ... before we throw it away */ SvREFCNT_dec(PL_compcv); + if (PERLDB_INTER)/* Advice debugger on the new sub. */ + ++PL_sub_generation; } else { cv = PL_compcv; @@ -4732,7 +4796,7 @@ Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block) } } CvGV(cv) = gv; - CvFILE(cv) = CopFILE(PL_curcop); + CvFILE_set_from_cop(cv, PL_curcop); CvSTASH(cv) = PL_curstash; #ifdef USE_THREADS CvOWNER(cv) = 0; @@ -4781,7 +4845,7 @@ Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block) OpREFCNT_set(CvROOT(cv), 1); CvSTART(cv) = LINKLIST(CvROOT(cv)); CvROOT(cv)->op_next = 0; - peep(CvSTART(cv)); + CALL_PEEP(CvSTART(cv)); /* now that optimizer has done its work, adjust pad values */ if (CvCLONE(cv)) { @@ -5091,9 +5155,9 @@ 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)"); +#ifdef GV_UNIQUE_CHECK + if (GvUNIQUE(gv)) { + Perl_croak(aTHX_ "Bad symbol for form (GV is unique)"); } #endif GvMULTI_on(gv); @@ -5110,7 +5174,7 @@ Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block) cv = PL_compcv; GvFORM(gv) = cv; CvGV(cv) = gv; - CvFILE(cv) = CopFILE(PL_curcop); + CvFILE_set_from_cop(cv, PL_curcop); for (ix = AvFILLp(PL_comppad); ix > 0; ix--) { if (!SvPADMY(PL_curpad[ix]) && !SvIMMORTAL(PL_curpad[ix])) @@ -5122,7 +5186,7 @@ Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block) OpREFCNT_set(CvROOT(cv), 1); CvSTART(cv) = LINKLIST(CvROOT(cv)); CvROOT(cv)->op_next = 0; - peep(CvSTART(cv)); + CALL_PEEP(CvSTART(cv)); op_free(o); PL_copline = NOLINE; LEAVE_SCOPE(floor); @@ -6295,7 +6359,7 @@ Perl_ck_sort(pTHX_ OP *o) kid->op_next = 0; /* just disconnect the leave */ k = kLISTOP->op_first; } - peep(k); + CALL_PEEP(k); kid = firstkid; if (o->op_type == OP_SORT) { @@ -6751,7 +6815,15 @@ Perl_peep(pTHX_ register OP *o) { PL_curcop = ((COP*)o); } - goto nothin; + /* XXX: We avoid setting op_seq here to prevent later calls + to peep() from mistakenly concluding that optimisation + has already occurred. This doesn't fix the real problem, + though (See 20010220.007). AMS 20010719 */ + if (oldop && o->op_next) { + oldop->op_next = o->op_next; + continue; + } + break; case OP_SCALAR: case OP_LINESEQ: case OP_SCOPE: @@ -6825,7 +6897,7 @@ Perl_peep(pTHX_ register OP *o) o->op_seq = PL_op_seqmax++; while (cLOGOP->op_other->op_type == OP_NULL) cLOGOP->op_other = cLOGOP->op_other->op_next; - peep(cLOGOP->op_other); + peep(cLOGOP->op_other); /* Recursive calls are not replaced by fptr calls */ break; case OP_ENTERLOOP: @@ -6890,9 +6962,9 @@ Perl_peep(pTHX_ register OP *o) svp = cSVOPx_svp(((BINOP*)o)->op_last); if ((!SvFAKE(sv = *svp) || !SvREADONLY(sv)) && !IS_PADCONST(sv)) { key = SvPV(sv, keylen); - if (SvUTF8(sv)) - keylen = -keylen; - lexname = newSVpvn_share(key, keylen, 0); + lexname = newSVpvn_share(key, + SvUTF8(sv) ? -(I32)keylen : keylen, + 0); SvREFCNT_dec(sv); *svp = lexname; } @@ -6910,9 +6982,8 @@ Perl_peep(pTHX_ register OP *o) if (!fields || !GvHV(*fields)) break; key = SvPV(*svp, keylen); - if (SvUTF8(*svp)) - keylen = -keylen; - indsvp = hv_fetch(GvHV(*fields), key, keylen, FALSE); + indsvp = hv_fetch(GvHV(*fields), key, + SvUTF8(*svp) ? -(I32)keylen : keylen, FALSE); if (!indsvp) { Perl_croak(aTHX_ "No such pseudo-hash field \"%s\" in variable %s of type %s", key, SvPV(lexname, n_a), HvNAME(SvSTASH(lexname))); @@ -6977,9 +7048,8 @@ Perl_peep(pTHX_ register OP *o) key_op = (SVOP*)key_op->op_sibling) { svp = cSVOPx_svp(key_op); key = SvPV(*svp, keylen); - if (SvUTF8(*svp)) - keylen = -keylen; - indsvp = hv_fetch(GvHV(*fields), key, keylen, FALSE); + indsvp = hv_fetch(GvHV(*fields), key, + SvUTF8(*svp) ? -(I32)keylen : keylen, FALSE); if (!indsvp) { Perl_croak(aTHX_ "No such pseudo-hash field \"%s\" " "in variable %s of type %s",