X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=op.c;h=95aa4f27396cd5854385d5b72eb9218f102bb31e;hb=8e3f9bdf33f266c6e827493ca82149fc1598579a;hp=38738c7ba1cef246211f1e4ae808f3a006ec83b9;hpb=b448e4fea9d52c651a1814ffb2d1d8745f1f0de9;p=p5sagit%2Fp5-mst-13.2.git diff --git a/op.c b/op.c index 38738c7..95aa4f2 100644 --- a/op.c +++ b/op.c @@ -168,7 +168,7 @@ Perl_pad_allocmy(pTHX_ char *name) Perl_warner(aTHX_ WARN_MISC, "\"our\" variable %s redeclared", name); Perl_warner(aTHX_ WARN_MISC, - "(Did you mean \"local\" instead of \"our\"?)\n"); + "\t(Did you mean \"local\" instead of \"our\"?)\n"); break; } } while ( off-- > 0 ); @@ -3848,7 +3848,10 @@ Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop, I32 whileline, OP * loopflags |= OPpLOOP_CONTINUE; } if (expr) { - cont = append_elem(OP_LINESEQ, cont, newOP(OP_UNSTACK, 0)); + OP *unstack = newOP(OP_UNSTACK, 0); + if (!next) + next = unstack; + cont = append_elem(OP_LINESEQ, cont, unstack); if ((line_t)whileline != NOLINE) { PL_copline = whileline; cont = append_elem(OP_LINESEQ, cont, @@ -3871,8 +3874,6 @@ Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop, I32 whileline, OP * if (listop) ((LISTOP*)listop)->op_last->op_next = condop = (o == listop ? redo : LINKLIST(o)); - if (!next) - next = condop; } else o = listop; @@ -4656,6 +4657,8 @@ Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block) if (!PL_checkav) PL_checkav = newAV(); DEBUG_x( dump_sub(gv) ); + if (PL_main_start && ckWARN(WARN_VOID)) + Perl_warner(aTHX_ WARN_VOID, "Too late to run CHECK block"); av_unshift(PL_checkav, 1); av_store(PL_checkav, 0, SvREFCNT_inc(cv)); GvCV(gv) = 0; @@ -4664,6 +4667,8 @@ Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block) if (!PL_initav) PL_initav = newAV(); DEBUG_x( dump_sub(gv) ); + if (PL_main_start && ckWARN(WARN_VOID)) + Perl_warner(aTHX_ WARN_VOID, "Too late to run INIT block"); av_push(PL_initav, SvREFCNT_inc(cv)); GvCV(gv) = 0; } @@ -4804,6 +4809,8 @@ Perl_newXS(pTHX_ char *name, XSUBADDR_t subaddr, char *filename) else if (strEQ(s, "CHECK")) { if (!PL_checkav) PL_checkav = newAV(); + if (PL_main_start && ckWARN(WARN_VOID)) + Perl_warner(aTHX_ WARN_VOID, "Too late to run CHECK block"); av_unshift(PL_checkav, 1); av_store(PL_checkav, 0, SvREFCNT_inc(cv)); GvCV(gv) = 0; @@ -4811,6 +4818,8 @@ Perl_newXS(pTHX_ char *name, XSUBADDR_t subaddr, char *filename) else if (strEQ(s, "INIT")) { if (!PL_initav) PL_initav = newAV(); + if (PL_main_start && ckWARN(WARN_VOID)) + Perl_warner(aTHX_ WARN_VOID, "Too late to run INIT block"); av_push(PL_initav, SvREFCNT_inc(cv)); GvCV(gv) = 0; } @@ -5156,6 +5165,20 @@ Perl_ck_eval(pTHX_ OP *o) } OP * +Perl_ck_exit(pTHX_ OP *o) +{ +#ifdef VMS + HV *table = GvHV(PL_hintgv); + if (table) { + SV **svp = hv_fetch(table, "vmsish_exit", 11, FALSE); + if (svp && *svp && SvTRUE(*svp)) + o->op_private |= OPpEXIT_VMSISH; + } +#endif + return ck_fun(o); +} + +OP * Perl_ck_exec(pTHX_ OP *o) { OP *kid; @@ -5498,6 +5521,13 @@ Perl_ck_fun(pTHX_ OP *o) name = GvNAME(gv); len = GvNAMELEN(gv); } + else if (kid->op_type == OP_AELEM + || kid->op_type == OP_HELEM) + { + name = "__ANONIO__"; + len = 10; + mod(kid,type); + } if (name) { SV *namesv; targ = pad_alloc(OP_RV2GV, SVs_PADTMP); @@ -5682,7 +5712,7 @@ Perl_ck_defined(pTHX_ OP *o) /* 19990527 MJD */ Perl_warner(aTHX_ WARN_DEPRECATED, "defined(@array) is deprecated"); Perl_warner(aTHX_ WARN_DEPRECATED, - "(Maybe you should just omit the defined()?)\n"); + "\t(Maybe you should just omit the defined()?)\n"); break; case OP_RV2HV: break; /* Globals via GV can be undef */ @@ -5690,7 +5720,7 @@ Perl_ck_defined(pTHX_ OP *o) /* 19990527 MJD */ Perl_warner(aTHX_ WARN_DEPRECATED, "defined(%%hash) is deprecated"); Perl_warner(aTHX_ WARN_DEPRECATED, - "(Maybe you should just omit the defined()?)\n"); + "\t(Maybe you should just omit the defined()?)\n"); break; default: /* no warning */ @@ -5965,6 +5995,7 @@ Perl_ck_shift(pTHX_ OP *o) OP * Perl_ck_sort(pTHX_ OP *o) { + OP *firstkid; o->op_private = 0; #ifdef USE_LOCALE if (PL_hints & HINT_LOCALE) @@ -5973,10 +6004,10 @@ Perl_ck_sort(pTHX_ OP *o) if (o->op_type == OP_SORT && o->op_flags & OPf_STACKED) simplify_sort(o); - if (o->op_flags & OPf_STACKED) { /* may have been cleared */ - OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */ + firstkid = cLISTOPo->op_first->op_sibling; /* get past pushmark */ + if (o->op_flags & OPf_STACKED) { /* may have been cleared */ OP *k; - kid = kUNOP->op_first; /* get past null */ + OP *kid = cUNOPx(firstkid)->op_first; /* get past null */ if (kid->op_type == OP_SCOPE || kid->op_type == OP_LEAVE) { linklist(kid); @@ -5992,6 +6023,12 @@ Perl_ck_sort(pTHX_ OP *o) for (k = kLISTOP->op_first->op_next; k; k = k->op_next) { if (k->op_next == kid) k->op_next = 0; + /* don't descend into loops */ + else if (k->op_type == OP_ENTERLOOP + || k->op_type == OP_ENTERITER) + { + k = cLOOPx(k)->op_lastop; + } } } else @@ -6000,17 +6037,26 @@ Perl_ck_sort(pTHX_ OP *o) } peep(k); - kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */ - if (o->op_type == OP_SORT) + kid = firstkid; + if (o->op_type == OP_SORT) { + /* provide scalar context for comparison function/block */ + kid = scalar(kid); kid->op_next = kid; + } else kid->op_next = k; o->op_flags |= OPf_SPECIAL; } else if (kid->op_type == OP_RV2SV || kid->op_type == OP_PADSV) - null(cLISTOPo->op_first->op_sibling); + null(firstkid); + + firstkid = firstkid->op_sibling; } + /* provide list context for arguments */ + if (o->op_type == OP_SORT) + list(firstkid); + return o; } @@ -6527,7 +6573,7 @@ Perl_peep(pTHX_ register OP *o) Perl_warner(aTHX_ WARN_EXEC, "Statement unlikely to be reached"); Perl_warner(aTHX_ WARN_EXEC, - "(Maybe you meant system() when you said exec()?)\n"); + "\t(Maybe you meant system() when you said exec()?)\n"); CopLINE_set(PL_curcop, oldline); } }