X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=op.c;h=5325a5abac03e1976cdd7022e31868815969db1d;hb=52c93dd194e572ccf0cd84fbd063340b76d1a6ba;hp=d2c68354b75cb739fcba01f915be80714f754257;hpb=11206fddaf7ef0686e22e60221d236872f9d4063;p=p5sagit%2Fp5-mst-13.2.git diff --git a/op.c b/op.c index d2c6835..5325a5a 100644 --- a/op.c +++ b/op.c @@ -1876,7 +1876,7 @@ Perl_bind_match(pTHX_ I32 type, OP *left, OP *right) { const char * const desc = PL_op_desc[(rtype == OP_SUBST || rtype == OP_TRANS) - ? rtype : OP_MATCH]; + ? (int)rtype : OP_MATCH]; const char * const sample = ((ltype == OP_RV2AV || ltype == OP_PADAV) ? "@array" : "%hash"); Perl_warner(aTHX_ packWARN(WARN_MISC), @@ -2118,8 +2118,8 @@ Perl_fold_constants(pTHX_ register OP *o) dVAR; register OP *curop; OP *newop; - I32 type = o->op_type; - SV *sv = NULL; + VOL I32 type = o->op_type; + SV * VOL sv = NULL; int ret = 0; I32 oldscope; OP *old_next; @@ -2233,7 +2233,7 @@ Perl_fold_constants(pTHX_ register OP *o) if (type == OP_RV2GV) newop = newGVOP(OP_GV, 0, (GV*)sv); else - newop = newSVOP(OP_CONST, 0, sv); + newop = newSVOP(OP_CONST, 0, (SV*)sv); op_getmad(o,newop,'f'); return newop; @@ -2258,6 +2258,8 @@ Perl_gen_constant_list(pTHX_ register OP *o) pp_pushmark(); CALLRUNOPS(aTHX); PL_op = curop; + assert (!(curop->op_flags & OPf_SPECIAL)); + assert(curop->op_type == OP_RANGE); pp_anonlist(); PL_tmps_floor = oldtmps_floor; @@ -3223,7 +3225,7 @@ Perl_pmruntime(pTHX_ OP *o, OP *expr, bool isreg) if (DO_UTF8(pat)) pm->op_pmdynflags |= PMdf_UTF8; /* FIXME - can we make this function take const char * args? */ - PM_SETRE(pm, CALLREGCOMP(aTHX_ (char*)p, (char*)p + plen, pm)); + PM_SETRE(pm, CALLREGCOMP((char*)p, (char*)p + plen, pm)); if (strEQ("\\s+", PM_GETRE(pm)->precomp)) pm->op_pmflags |= PMf_WHITE; #ifdef PERL_MAD @@ -3783,7 +3785,7 @@ Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right) * to store these values, evil chicanery is done with SvCUR(). */ - if (!(left->op_private & OPpLVAL_INTRO)) { + { OP *lastop = o; PL_generation++; for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) { @@ -3838,6 +3840,34 @@ Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right) if (curop != o) o->op_private |= OPpASSIGN_COMMON; } + + if ( ((left->op_private & OPpLVAL_INTRO) || ckWARN(WARN_MISC)) + && (left->op_type == OP_LIST + || (left->op_type == OP_NULL && left->op_targ == OP_LIST))) + { + OP* lop = ((LISTOP*)left)->op_first; + while (lop) { + if (lop->op_type == OP_PADSV || + lop->op_type == OP_PADAV || + lop->op_type == OP_PADHV || + lop->op_type == OP_PADANY) + { + if (lop->op_private & OPpPAD_STATE) { + if (left->op_private & OPpLVAL_INTRO) { + o->op_private |= OPpASSIGN_STATE; + /* hijacking PADSTALE for uninitialized state variables */ + SvPADSTALE_on(PAD_SVl(lop->op_targ)); + } + else { /* we already checked for WARN_MISC before */ + Perl_warner(aTHX_ packWARN(WARN_MISC), "State variable %s will be reinitialized", + PAD_COMPNAME_PV(lop->op_targ)); + } + } + } + lop = lop->op_sibling; + } + } + if (right && right->op_type == OP_SPLIT) { OP* tmpop = ((LISTOP*)right)->op_first; if (tmpop && (tmpop->op_type == OP_PUSHRE)) { @@ -4525,7 +4555,7 @@ Perl_newFOROP(pTHX_ I32 flags, char *label, line_t forline, OP *sv, OP *expr, OP loop = tmp; } #else - loop = PerlMemShared_realloc(loop, sizeof(LOOP)); + loop = (LOOP*)PerlMemShared_realloc(loop, sizeof(LOOP)); #endif loop->op_targ = padoff; wop = newWHILEOP(flags, 1, loop, forline, newOP(OP_ITER, 0), block, cont, 0); @@ -5312,7 +5342,7 @@ Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block) else s = tname; - if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I') + if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I' && *s != 'U') goto done; if (strEQ(s, "BEGIN") && !PL_error_count) { @@ -5340,6 +5370,15 @@ Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block) av_store(PL_endav, 0, (SV*)cv); GvCV(gv) = 0; /* cv has been hijacked */ } + else if (strEQ(s, "UNITCHECK") && !PL_error_count) { + /* It's never too late to run a unitcheck block */ + if (!PL_unitcheckav) + PL_unitcheckav = newAV(); + DEBUG_x( dump_sub(gv) ); + av_unshift(PL_unitcheckav, 1); + av_store(PL_unitcheckav, 0, (SV*)cv); + GvCV(gv) = 0; /* cv has been hijacked */ + } else if (strEQ(s, "CHECK") && !PL_error_count) { if (!PL_checkav) PL_checkav = newAV(); @@ -5414,6 +5453,7 @@ Perl_newCONSTSUB(pTHX_ HV *stash, const char *name, SV *sv) cv = newXS_flags(name, const_sv_xsub, file, "", XS_DYNAMIC_FILENAME); CvXSUBANY(cv).any_ptr = sv; CvCONST_on(cv); + Safefree(file); #ifdef USE_ITHREADS if (stash) @@ -5653,15 +5693,13 @@ Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block) OP * Perl_newANONLIST(pTHX_ OP *o) { - return newUNOP(OP_REFGEN, 0, - mod(list(convert(OP_ANONLIST, 0, o)), OP_REFGEN)); + return convert(OP_ANONLIST, OPf_SPECIAL, o); } OP * Perl_newANONHASH(pTHX_ OP *o) { - return newUNOP(OP_REFGEN, 0, - mod(list(convert(OP_ANONHASH, 0, o)), OP_REFGEN)); + return convert(OP_ANONHASH, OPf_SPECIAL, o); } OP * @@ -6716,16 +6754,6 @@ Perl_ck_listiob(pTHX_ OP *o) } OP * -Perl_ck_say(pTHX_ OP *o) -{ - o = ck_listiob(o); - o->op_type = OP_PRINT; - cLISTOPo->op_last = cLISTOPo->op_last->op_sibling - = newSVOP(OP_CONST, 0, newSVpvs("\n")); - return o; -} - -OP * Perl_ck_smartmatch(pTHX_ OP *o) { dVAR; @@ -7275,7 +7303,7 @@ Perl_ck_subr(pTHX_ OP *o) int optional = 0; I32 arg = 0; I32 contextclass = 0; - char *e = NULL; + const char *e = NULL; bool delete_op = 0; o->op_private |= OPpENTERSUB_HASTARG; @@ -7298,13 +7326,20 @@ Perl_ck_subr(pTHX_ OP *o) proto_end = proto + len; } if (CvASSERTION(cv)) { - if (PL_hints & HINT_ASSERTING) { + U32 asserthints = 0; + HV *const hinthv = GvHV(PL_hintgv); + if (hinthv) { + SV **svp = hv_fetchs(hinthv, "assertions", FALSE); + if (svp && *svp) + asserthints = SvUV(*svp); + } + if (asserthints & HINT_ASSERTING) { if (PERLDB_ASSERTION && PL_curstash != PL_debstash) o->op_private |= OPpENTERSUB_DB; } else { delete_op = 1; - if (!(PL_hints & HINT_ASSERTIONSSEEN) && ckWARN(WARN_ASSERTIONS)) { + if (!(asserthints & HINT_ASSERTIONSSEEN) && ckWARN(WARN_ASSERTIONS)) { Perl_warner(aTHX_ packWARN(WARN_ASSERTIONS), "Impossible to activate assertion call"); } @@ -7340,6 +7375,10 @@ Perl_ck_subr(pTHX_ OP *o) optional = 1; proto++; continue; + case '_': + /* _ must be at the end */ + if (proto[1] && proto[1] != ';') + goto oops; case '$': proto++; arg++; @@ -7499,8 +7538,14 @@ Perl_ck_subr(pTHX_ OP *o) prev = o2; o2 = o2->op_sibling; } /* while */ + if (o2 == cvop && proto && *proto == '_') { + /* generate an access to $_ */ + o2 = newDEFSVOP(); + o2->op_sibling = prev->op_sibling; + prev->op_sibling = o2; /* instead of cvop */ + } if (proto && !optional && proto_end > proto && - (*proto != '@' && *proto != '%' && *proto != ';')) + (*proto != '@' && *proto != '%' && *proto != ';' && *proto != '_')) return too_few_arguments(o, gv_ename(namegv)); if(delete_op) { #ifdef PERL_MAD