X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=op.c;h=677fe7a231b945db0ef51950fe4329d06dc3b1c1;hb=f86a8bc58a487e28b31c5d91c65920f4859f3f74;hp=92d15da3a1aeb49604f585b4c0e7114c67611218;hpb=a27978d3b51a1694fbb3bf9d13a41f0518386f5c;p=p5sagit%2Fp5-mst-13.2.git diff --git a/op.c b/op.c index 92d15da..677fe7a 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 @@ -113,7 +115,7 @@ Perl_pad_allocmy(pTHX_ char *name) if (!(PL_in_my == KEY_our || isALPHA(name[1]) || - (PL_hints & HINT_UTF8 && UTF8_IS_START(name[1])) || + (USE_UTF8_IN_NAMES && UTF8_IS_START(name[1])) || (name[1] == '_' && (int)strlen(name) > 2))) { if (!isPRINT(name[1]) || strchr("\t\n\r\f", name[1])) { @@ -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; } @@ -2174,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) @@ -2185,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 */ @@ -2208,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", @@ -2369,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; @@ -2948,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; @@ -2980,16 +3002,12 @@ Perl_pmruntime(pTHX_ OP *o, OP *expr, OP *repl) p = SvPV(pat, plen); pm->op_pmflags |= PMf_SKIPWHITE; } - if ((PL_hints & HINT_UTF8) || DO_UTF8(pat)) - pm->op_pmdynflags |= PMdf_UTF8; PM_SETRE(pm, CALLREGCOMP(aTHX_ p, p + plen, pm)); if (strEQ("\\s+", PM_GETRE(pm)->precomp)) pm->op_pmflags |= PMf_WHITE; op_free(expr); } else { - if (PL_hints & HINT_UTF8) - pm->op_pmdynflags |= PMdf_UTF8; if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL)) expr = newUNOP((!(PL_hints & HINT_RE_EVAL) ? OP_REGCRESET @@ -3193,6 +3211,7 @@ Perl_package(pTHX_ OP *o) op_free(o); } else { + deprecate("\"package\" with no arguments"); sv_setpv(PL_curstname,""); PL_curstash = Nullhv; } @@ -3207,6 +3226,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"); @@ -3264,6 +3286,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)), @@ -3275,6 +3306,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; @@ -4160,9 +4200,10 @@ Perl_cv_undef(pTHX_ CV *cv) #ifdef USE_ITHREADS if (CvFILE(cv) && !CvXSUB(cv)) { + /* for XSUBs CvFILE point directly to static memory; __FILE__ */ Safefree(CvFILE(cv)); - CvFILE(cv) = 0; } + CvFILE(cv) = 0; #endif if (!CvXSUB(cv) && CvROOT(cv)) { @@ -4739,6 +4780,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; @@ -4798,7 +4841,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)) { @@ -5139,7 +5182,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); @@ -6117,39 +6160,6 @@ Perl_ck_null(pTHX_ OP *o) } OP * -Perl_ck_octmode(pTHX_ OP *o) -{ - OP *p; - - if ((ckWARN(WARN_OCTMODE) - /* Add WARN_MKDIR instead of getting rid of WARN_{CHMOD,UMASK}. - Backwards compatibility and consistency are terrible things. - AMS 20010705 */ - || (o->op_type == OP_CHMOD && ckWARN(WARN_CHMOD)) - || (o->op_type == OP_UMASK && ckWARN(WARN_UMASK)) - || (o->op_type == OP_MKDIR && ckWARN(WARN_MKDIR))) - && o->op_flags & OPf_KIDS) - { - if (o->op_type == OP_MKDIR) - p = cLISTOPo->op_last; /* mkdir $foo, 0777 */ - else if (o->op_type == OP_CHMOD) - p = cLISTOPo->op_first->op_sibling; /* chmod 0777, $foo */ - else - p = cUNOPo->op_first; /* umask 0222 */ - - if (p->op_type == OP_CONST && !(p->op_private & OPpCONST_OCTAL)) { - int mode = SvIV(cSVOPx_sv(p)); - - Perl_warner(aTHX_ WARN_OCTMODE, - "Non-octal literal mode (%d) specified", mode); - Perl_warner(aTHX_ WARN_OCTMODE, - "\t(Did you mean 0%d instead?)\n", mode); - } - } - return ck_fun(o); -} - -OP * Perl_ck_open(pTHX_ OP *o) { HV *table = GvHV(PL_hintgv); @@ -6345,7 +6355,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) { @@ -6801,7 +6811,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: @@ -6860,6 +6878,15 @@ Perl_peep(pTHX_ register OP *o) SvPV_nolen(sv)); } } + else if (o->op_next->op_type == OP_READLINE + && o->op_next->op_next->op_type == OP_CONCAT + && (o->op_next->op_next->op_flags & OPf_STACKED)) + { + /* Turn "$a .= " into an OP_RCATLINE. AMS 20010811 */ + o->op_next->op_type = OP_RCATLINE; + o->op_next->op_flags |= OPf_STACKED; + op_null(o->op_next->op_next); + } o->op_seq = PL_op_seqmax++; break; @@ -6875,7 +6902,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: