X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=pp_ctl.c;h=cee753a125da9fedc18da5f37c193c2089818336;hb=7f2c89897f1cc260c9f4949731056784f989703f;hp=972c21d30c5862c7d50b048d288fcc88b68a2062;hpb=1761cee512762c09b2a848d3c6cbd5a3b4232ffa;p=p5sagit%2Fp5-mst-13.2.git diff --git a/pp_ctl.c b/pp_ctl.c index 972c21d..cee753a 100644 --- a/pp_ctl.c +++ b/pp_ctl.c @@ -302,8 +302,13 @@ PP(pp_formline) bool item_is_utf = FALSE; if (!SvMAGICAL(tmpForm) || !SvCOMPILED(tmpForm)) { - SvREADONLY_off(tmpForm); - doparseform(tmpForm); + if (SvREADONLY(tmpForm)) { + SvREADONLY_off(tmpForm); + doparseform(tmpForm); + SvREADONLY_on(tmpForm); + } + else + doparseform(tmpForm); } SvPV_force(PL_formtarget, len); @@ -854,7 +859,7 @@ PP(pp_sort) up = myorigmark + 1; while (MARK < SP) { /* This may or may not shift down one here. */ /*SUPPRESS 560*/ - if (*up = *++MARK) { /* Weed out nulls. */ + if ((*up = *++MARK)) { /* Weed out nulls. */ SvTEMP_off(*up); if (!PL_sortcop && !SvPOK(*up)) { STRLEN n_a; @@ -1070,28 +1075,28 @@ S_dopoptolabel(pTHX_ char *label) cx = &cxstack[i]; switch (CxTYPE(cx)) { case CXt_SUBST: - if (ckWARN(WARN_UNSAFE)) - Perl_warner(aTHX_ WARN_UNSAFE, "Exiting substitution via %s", + if (ckWARN(WARN_EXITING)) + Perl_warner(aTHX_ WARN_EXITING, "Exiting substitution via %s", PL_op_name[PL_op->op_type]); break; case CXt_SUB: - if (ckWARN(WARN_UNSAFE)) - Perl_warner(aTHX_ WARN_UNSAFE, "Exiting subroutine via %s", + if (ckWARN(WARN_EXITING)) + Perl_warner(aTHX_ WARN_EXITING, "Exiting subroutine via %s", PL_op_name[PL_op->op_type]); break; case CXt_FORMAT: - if (ckWARN(WARN_UNSAFE)) - Perl_warner(aTHX_ WARN_UNSAFE, "Exiting format via %s", + if (ckWARN(WARN_EXITING)) + Perl_warner(aTHX_ WARN_EXITING, "Exiting format via %s", PL_op_name[PL_op->op_type]); break; case CXt_EVAL: - if (ckWARN(WARN_UNSAFE)) - Perl_warner(aTHX_ WARN_UNSAFE, "Exiting eval via %s", + if (ckWARN(WARN_EXITING)) + Perl_warner(aTHX_ WARN_EXITING, "Exiting eval via %s", PL_op_name[PL_op->op_type]); break; case CXt_NULL: - if (ckWARN(WARN_UNSAFE)) - Perl_warner(aTHX_ WARN_UNSAFE, "Exiting pseudo-block via %s", + if (ckWARN(WARN_EXITING)) + Perl_warner(aTHX_ WARN_EXITING, "Exiting pseudo-block via %s", PL_op_name[PL_op->op_type]); return -1; case CXt_LOOP: @@ -1196,28 +1201,28 @@ S_dopoptoloop(pTHX_ I32 startingblock) cx = &cxstack[i]; switch (CxTYPE(cx)) { case CXt_SUBST: - if (ckWARN(WARN_UNSAFE)) - Perl_warner(aTHX_ WARN_UNSAFE, "Exiting substitution via %s", + if (ckWARN(WARN_EXITING)) + Perl_warner(aTHX_ WARN_EXITING, "Exiting substitution via %s", PL_op_name[PL_op->op_type]); break; case CXt_SUB: - if (ckWARN(WARN_UNSAFE)) - Perl_warner(aTHX_ WARN_UNSAFE, "Exiting subroutine via %s", + if (ckWARN(WARN_EXITING)) + Perl_warner(aTHX_ WARN_EXITING, "Exiting subroutine via %s", PL_op_name[PL_op->op_type]); break; case CXt_FORMAT: - if (ckWARN(WARN_UNSAFE)) - Perl_warner(aTHX_ WARN_UNSAFE, "Exiting format via %s", + if (ckWARN(WARN_EXITING)) + Perl_warner(aTHX_ WARN_EXITING, "Exiting format via %s", PL_op_name[PL_op->op_type]); break; case CXt_EVAL: - if (ckWARN(WARN_UNSAFE)) - Perl_warner(aTHX_ WARN_UNSAFE, "Exiting eval via %s", + if (ckWARN(WARN_EXITING)) + Perl_warner(aTHX_ WARN_EXITING, "Exiting eval via %s", PL_op_name[PL_op->op_type]); break; case CXt_NULL: - if (ckWARN(WARN_UNSAFE)) - Perl_warner(aTHX_ WARN_UNSAFE, "Exiting pseudo-block via %s", + if (ckWARN(WARN_EXITING)) + Perl_warner(aTHX_ WARN_EXITING, "Exiting pseudo-block via %s", PL_op_name[PL_op->op_type]); return -1; case CXt_LOOP: @@ -1233,7 +1238,6 @@ Perl_dounwind(pTHX_ I32 cxix) { dTHR; register PERL_CONTEXT *cx; - SV **newsp; I32 optype; while (cxstack_ix > cxix) { @@ -1317,7 +1321,6 @@ Perl_qerror(pTHX_ SV *err) OP * Perl_die_where(pTHX_ char *message, STRLEN msglen) { - dSP; STRLEN n_a; if (PL_in_eval) { I32 cxix; @@ -1342,9 +1345,9 @@ Perl_die_where(pTHX_ char *message, STRLEN msglen) SvGROW(err, SvCUR(err)+sizeof(prefix)+msglen); sv_catpvn(err, prefix, sizeof(prefix)-1); sv_catpvn(err, message, msglen); - if (ckWARN(WARN_UNSAFE)) { + if (ckWARN(WARN_MISC)) { STRLEN start = SvCUR(err)-msglen-sizeof(prefix)+1; - Perl_warner(aTHX_ WARN_UNSAFE, SvPVX(err)+start); + Perl_warner(aTHX_ WARN_MISC, SvPVX(err)+start); } } } @@ -1451,7 +1454,7 @@ PP(pp_caller) if (MAXARG) count = POPi; - EXTEND(SP, 7); + EXTEND(SP, 10); for (;;) { /* we may be in a higher stacklevel, so dig down deeper */ while (cxix < 0 && top_si->si_type != PERLSI_MAIN) { @@ -1521,10 +1524,10 @@ PP(pp_caller) if (cx->blk_eval.old_op_type == OP_ENTEREVAL) { PUSHs(cx->blk_eval.cur_text); PUSHs(&PL_sv_no); - } - else if (cx->blk_eval.old_name) { /* Try blocks have old_name == 0. */ - /* Require, put the name. */ - PUSHs(sv_2mortal(newSVpv(cx->blk_eval.old_name, 0))); + } + /* try blocks have old_namesv == 0 */ + else if (cx->blk_eval.old_namesv) { + PUSHs(sv_2mortal(newSVsv(cx->blk_eval.old_namesv))); PUSHs(&PL_sv_yes); } } @@ -1556,6 +1559,17 @@ PP(pp_caller) * use the global PL_hints) */ PUSHs(sv_2mortal(newSViv((I32)cx->blk_oldcop->op_private & HINT_PRIVATE_MASK))); + { + SV * mask ; + SV * old_warnings = cx->blk_oldcop->cop_warnings ; + if (old_warnings == pWARN_NONE || old_warnings == pWARN_STD) + mask = newSVpvn(WARN_NONEstring, WARNsize) ; + else if (old_warnings == pWARN_ALL) + mask = newSVpvn(WARN_ALLstring, WARNsize) ; + else + mask = newSVsv(old_warnings); + PUSHs(sv_2mortal(mask)); + } RETURN; } @@ -1770,6 +1784,7 @@ PP(pp_return) I32 cxix; register PERL_CONTEXT *cx; bool popsub2 = FALSE; + bool clear_errsv = FALSE; I32 gimme; SV **newsp; PMOP *newpm; @@ -1800,7 +1815,11 @@ PP(pp_return) popsub2 = TRUE; break; case CXt_EVAL: + if (!(PL_in_eval & EVAL_KEEPERR)) + clear_errsv = TRUE; POPEVAL(cx); + if (CxTRYBLOCK(cx)) + break; if (AvFILLp(PL_comppad_name) >= 0) free_closures(); lex_end(); @@ -1808,9 +1827,9 @@ PP(pp_return) (MARK == SP || (gimme == G_SCALAR && !SvTRUE(*SP))) ) { /* Unassume the success we assumed earlier. */ - char *name = cx->blk_eval.old_name; - (void)hv_delete(GvHVn(PL_incgv), name, strlen(name), G_DISCARD); - DIE(aTHX_ "%s did not return a true value", name); + SV *nsv = cx->blk_eval.old_namesv; + (void)hv_delete(GvHVn(PL_incgv), SvPVX(nsv), SvCUR(nsv), G_DISCARD); + DIE(aTHX_ "%s did not return a true value", SvPVX(nsv)); } break; case CXt_FORMAT: @@ -1829,15 +1848,21 @@ PP(pp_return) *++newsp = SvREFCNT_inc(*SP); FREETMPS; sv_2mortal(*newsp); - } else { + } + else { + sv = SvREFCNT_inc(*SP); /* FREETMPS could clobber it */ FREETMPS; - *++newsp = sv_mortalcopy(*SP); + *++newsp = sv_mortalcopy(sv); + SvREFCNT_dec(sv); } - } else + } + else *++newsp = (SvTEMP(*SP)) ? *SP : sv_mortalcopy(*SP); - } else + } + else *++newsp = sv_mortalcopy(*SP); - } else + } + else *++newsp = &PL_sv_undef; } else if (gimme == G_ARRAY) { @@ -1859,6 +1884,8 @@ PP(pp_return) LEAVE; LEAVESUB(sv); + if (clear_errsv) + sv_setpv(ERRSV,""); return pop_return(); } @@ -1967,17 +1994,14 @@ PP(pp_next) if (cxix < cxstack_ix) dounwind(cxix); - cx = &cxstack[cxstack_ix]; - { - OP *nextop = cx->blk_loop.next_op; - /* clean scope, but only if there's no continue block */ - if (nextop == cUNOPx(cx->blk_loop.last_op)->op_first->op_next) { - TOPBLOCK(cx); - oldsave = PL_scopestack[PL_scopestack_ix - 1]; - LEAVE_SCOPE(oldsave); - } - return nextop; + TOPBLOCK(cx); + + /* clean scope, but only if there's no continue block */ + if (!(cx->blk_loop.last_op->op_private & OPpLOOP_CONTINUE)) { + oldsave = PL_scopestack[PL_scopestack_ix - 1]; + LEAVE_SCOPE(oldsave); } + return cx->blk_loop.next_op; } PP(pp_redo) @@ -2040,7 +2064,7 @@ S_dofindlabel(pTHX_ OP *o, char *label, OP **opstack, OP **oplimit) (ops[-1]->op_type != OP_NEXTSTATE && ops[-1]->op_type != OP_DBSTATE))) *ops++ = kid; - if (o = dofindlabel(kid, label, ops, oplimit)) + if ((o = dofindlabel(kid, label, ops, oplimit))) return o; } } @@ -2134,7 +2158,6 @@ PP(pp_goto) } else if (CvXSUB(cv)) { /* put GvAV(defgv) back onto stack */ AV* av; - int i; #ifdef USE_THREADS av = (AV*)PL_curpad[0]; #else @@ -2375,10 +2398,12 @@ PP(pp_goto) gotoprobe = PL_main_root; break; } - retop = dofindlabel(gotoprobe, label, - enterops, enterops + GOTO_DEPTH); - if (retop) - break; + if (gotoprobe) { + retop = dofindlabel(gotoprobe, label, + enterops, enterops + GOTO_DEPTH); + if (retop) + break; + } PL_lastgotoprobe = gotoprobe; } if (!retop) @@ -2516,9 +2541,17 @@ S_save_lines(pTHX_ AV *array, SV *sv) } } +#ifdef PERL_FLEXIBLE_EXCEPTIONS STATIC void * S_docatch_body(pTHX_ va_list args) { + return docatch_body(); +} +#endif + +STATIC void * +S_docatch_body(pTHX) +{ CALLRUNOPS(aTHX); return NULL; } @@ -2536,10 +2569,18 @@ S_docatch(pTHX_ OP *o) assert(CATCH_GET == TRUE); #endif PL_op = o; +#ifdef PERL_FLEXIBLE_EXCEPTIONS redo_body: CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_docatch_body)); +#else + JMPENV_PUSH(ret); +#endif switch (ret) { case 0: +#ifndef PERL_FLEXIBLE_EXCEPTIONS + redo_body: + docatch_body(); +#endif break; case 3: if (PL_restartop && cursi == PL_curstackinfo) { @@ -2549,10 +2590,12 @@ S_docatch(pTHX_ OP *o) } /* FALL THROUGH */ default: + JMPENV_POP; PL_op = oldop; JMPENV_JUMP(ret); /* NOTREACHED */ } + JMPENV_POP; PL_op = oldop; return Nullop; } @@ -2569,7 +2612,7 @@ Perl_sv_compile_2op(pTHX_ SV *sv, OP** startop, char *code, AV** avp) I32 gimme = 0; /* SUSPECT - INITIALZE TO WHAT? NI-S */ I32 optype; OP dummy; - OP *oop = PL_op, *rop; + OP *rop; char tbuf[TYPE_DIGITS(long) + 12 + 10]; char *tmpbuf = tbuf; char *safestr; @@ -2697,8 +2740,11 @@ S_doeval(pTHX_ int gimme, OP** startop) av_store(comppadlist, 1, (SV*)PL_comppad); CvPADLIST(PL_compcv) = comppadlist; - if (!saveop || saveop->op_type != OP_REQUIRE) + if (!saveop || + (saveop->op_type != OP_REQUIRE && saveop->op_type != OP_DOFILE)) + { CvOUTSIDE(PL_compcv) = (CV*)SvREFCNT_inc(caller); + } SAVEFREESV(PL_compcv); @@ -2897,15 +2943,17 @@ PP(pp_require) } } else if (!SvPOKp(sv)) { /* require 5.005_03 */ - NV n = SvNV(sv); - rev = (UV)n; - ver = (UV)((n-rev)*1000); - sver = (UV)((((n-rev)*1000 - ver) + 0.0009) * 1000); - if ((NV)PERL_REVISION + ((NV)PERL_VERSION/(NV)1000) + ((NV)PERL_SUBVERSION/(NV)1000000) + 0.00000099 < SvNV(sv)) { + NV nrev = SvNV(sv); + UV rev = (UV)nrev; + NV nver = (nrev - rev) * 1000; + UV ver = (UV)(nver + 0.0009); + NV nsver = (nver - ver) * 1000; + UV sver = (UV)(nsver + 0.0009); + DIE(aTHX_ "Perl v%"UVuf".%"UVuf".%"UVuf" required--this is only version " "v%d.%d.%d, stopped", rev, ver, sver, PERL_REVISION, PERL_VERSION, PERL_SUBVERSION); @@ -3119,11 +3167,11 @@ PP(pp_require) PL_hints = 0; SAVESPTR(PL_compiling.cop_warnings); if (PL_dowarn & G_WARN_ALL_ON) - PL_compiling.cop_warnings = WARN_ALL ; + PL_compiling.cop_warnings = pWARN_ALL ; else if (PL_dowarn & G_WARN_ALL_OFF) - PL_compiling.cop_warnings = WARN_NONE ; + PL_compiling.cop_warnings = pWARN_NONE ; else - PL_compiling.cop_warnings = WARN_STD ; + PL_compiling.cop_warnings = pWARN_STD ; if (filter_sub || filter_child_proc) { SV *datasv = filter_add(run_user_filter, Nullsv); @@ -3289,9 +3337,9 @@ PP(pp_leaveeval) !(gimme == G_SCALAR ? SvTRUE(*SP) : SP > newsp)) { /* Unassume the success we assumed earlier. */ - char *name = cx->blk_eval.old_name; - (void)hv_delete(GvHVn(PL_incgv), name, strlen(name), G_DISCARD); - retop = Perl_die(aTHX_ "%s did not return a true value", name); + SV *nsv = cx->blk_eval.old_namesv; + (void)hv_delete(GvHVn(PL_incgv), SvPVX(nsv), SvCUR(nsv), G_DISCARD); + retop = Perl_die(aTHX_ "%s did not return a true value", SvPVX(nsv)); /* die_where() did LEAVE, or we won't be here */ } else { @@ -3313,7 +3361,7 @@ PP(pp_entertry) SAVETMPS; push_return(cLOGOP->op_other->op_next); - PUSHBLOCK(cx, CXt_EVAL, SP); + PUSHBLOCK(cx, (CXt_EVAL|CXp_TRYBLOCK), SP); PUSHEVAL(cx, 0, 0); PL_eval_root = PL_op; /* Only needed so that goto works right. */ @@ -3964,7 +4012,7 @@ S_qsortsv(pTHX_ SV ** array, size_t num_elts, SVCOMPARE_t compare) on the correct side of the partition. If I find a greater value, then stop the scan. */ - while (still_work_on_left = (u_right >= part_left)) { + while ((still_work_on_left = (u_right >= part_left))) { s = qsort_cmp(u_right, pc_left); if (s < 0) { --u_right; @@ -3985,7 +4033,7 @@ S_qsortsv(pTHX_ SV ** array, size_t num_elts, SVCOMPARE_t compare) /* Do a mirror image scan of uncompared values on the right */ - while (still_work_on_right = (u_left <= part_right)) { + while ((still_work_on_right = (u_left <= part_right))) { s = qsort_cmp(pc_right, u_left); if (s < 0) { ++u_left;