X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=pp_ctl.c;h=a924d2ebe318a986f5bf21320c4abb94ea7decf2;hb=e3acbfda4f677df31695d7b2b63b7e9e854a3514;hp=972c21d30c5862c7d50b048d288fcc88b68a2062;hpb=3818b22bb9ef820a2553aa5e3504220f3b156f21;p=p5sagit%2Fp5-mst-13.2.git diff --git a/pp_ctl.c b/pp_ctl.c index 972c21d..a924d2e 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; @@ -878,15 +883,22 @@ PP(pp_sort) CATCH_SET(TRUE); PUSHSTACKi(PERLSI_SORT); - if (PL_sortstash != stash) { - PL_firstgv = gv_fetchpv("a", TRUE, SVt_PV); - PL_secondgv = gv_fetchpv("b", TRUE, SVt_PV); - PL_sortstash = stash; + if (!hasargs && !is_xsub) { + if (PL_sortstash != stash || !PL_firstgv || !PL_secondgv) { + SAVESPTR(PL_firstgv); + SAVESPTR(PL_secondgv); + PL_firstgv = gv_fetchpv("a", TRUE, SVt_PV); + PL_secondgv = gv_fetchpv("b", TRUE, SVt_PV); + PL_sortstash = stash; + } +#ifdef USE_THREADS + sv_lock((SV *)PL_firstgv); + sv_lock((SV *)PL_secondgv); +#endif + SAVESPTR(GvSV(PL_firstgv)); + SAVESPTR(GvSV(PL_secondgv)); } - SAVESPTR(GvSV(PL_firstgv)); - SAVESPTR(GvSV(PL_secondgv)); - PUSHBLOCK(cx, CXt_NULL, PL_stack_base); if (!(PL_op->op_flags & OPf_SPECIAL)) { cx->cx_type = CXt_SUB; @@ -905,6 +917,7 @@ PP(pp_sort) cx->blk_sub.savearray = GvAV(PL_defgv); GvAV(PL_defgv) = (AV*)SvREFCNT_inc(av); #endif /* USE_THREADS */ + cx->blk_sub.oldcurpad = PL_curpad; cx->blk_sub.argarray = av; } qsortsv((myorigmark+1), max, @@ -1070,28 +1083,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 +1209,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 +1246,6 @@ Perl_dounwind(pTHX_ I32 cxix) { dTHR; register PERL_CONTEXT *cx; - SV **newsp; I32 optype; while (cxstack_ix > cxix) { @@ -1317,7 +1329,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 +1353,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 +1462,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) { @@ -1518,15 +1529,21 @@ PP(pp_caller) else PUSHs(sv_2mortal(newSViv(gimme & G_ARRAY))); if (CxTYPE(cx) == CXt_EVAL) { + /* eval STRING */ 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))); + } + /* require */ + else if (cx->blk_eval.old_namesv) { + PUSHs(sv_2mortal(newSVsv(cx->blk_eval.old_namesv))); PUSHs(&PL_sv_yes); } + /* eval BLOCK (try blocks have old_namesv == 0) */ + else { + PUSHs(&PL_sv_undef); + PUSHs(&PL_sv_undef); + } } else { PUSHs(&PL_sv_undef); @@ -1543,7 +1560,7 @@ PP(pp_caller) PL_dbargs = GvAV(gv_AVadd(tmpgv = gv_fetchpv("DB::args", TRUE, SVt_PVAV))); GvMULTI_on(tmpgv); - AvREAL_off(PL_dbargs); /* XXX Should be REIFY */ + AvREAL_off(PL_dbargs); /* XXX should be REIFY (see av.h) */ } if (AvMAX(PL_dbargs) < AvFILLp(ary) + off) @@ -1556,6 +1573,20 @@ 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 && (PL_dowarn & G_WARN_ON) == 0)) + mask = newSVpvn(WARN_NONEstring, WARNsize) ; + else if (old_warnings == pWARN_ALL || + (old_warnings == pWARN_STD && PL_dowarn & G_WARN_ON)) + mask = newSVpvn(WARN_ALLstring, WARNsize) ; + else + mask = newSVsv(old_warnings); + PUSHs(sv_2mortal(mask)); + } RETURN; } @@ -1770,6 +1801,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 +1832,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 +1844,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 +1865,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 +1901,8 @@ PP(pp_return) LEAVE; LEAVESUB(sv); + if (clear_errsv) + sv_setpv(ERRSV,""); return pop_return(); } @@ -1952,7 +1996,7 @@ PP(pp_next) { I32 cxix; register PERL_CONTEXT *cx; - I32 oldsave; + I32 inner; if (PL_op->op_flags & OPf_SPECIAL) { cxix = dopoptoloop(cxstack_ix); @@ -1967,17 +2011,13 @@ 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; - } + /* clear off anything above the scope we're re-entering, but + * save the rest until after a possible continue block */ + inner = PL_scopestack_ix; + TOPBLOCK(cx); + if (PL_scopestack_ix < inner) + leave_scope(PL_scopestack[PL_scopestack_ix]); + return cx->blk_loop.next_op; } PP(pp_redo) @@ -2040,7 +2080,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 +2174,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 @@ -2274,6 +2313,7 @@ PP(pp_goto) cx->blk_sub.savearray = GvAV(PL_defgv); GvAV(PL_defgv) = (AV*)SvREFCNT_inc(av); #endif /* USE_THREADS */ + cx->blk_sub.oldcurpad = PL_curpad; cx->blk_sub.argarray = av; ++mark; @@ -2375,10 +2415,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) @@ -2438,8 +2480,8 @@ PP(pp_exit) anum = 0; else { anum = SvIVx(POPs); -#ifdef VMSISH_EXIT - if (anum == 1 && VMSISH_EXIT) +#ifdef VMS + if (anum == 1 && (PL_op->op_private & OPpEXIT_VMSISH)) anum = 0; #endif } @@ -2516,9 +2558,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 +2586,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 +2607,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 +2629,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; @@ -2580,11 +2640,9 @@ Perl_sv_compile_2op(pTHX_ SV *sv, OP** startop, char *code, AV** avp) /* switch to eval mode */ if (PL_curcop == &PL_compiling) { - SAVECOPSTASH(&PL_compiling); + SAVECOPSTASH_FREE(&PL_compiling); CopSTASH_set(&PL_compiling, PL_curstash); } - SAVECOPFILE(&PL_compiling); - SAVECOPLINE(&PL_compiling); if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) { SV *sv = sv_newmortal(); Perl_sv_setpvf(aTHX_ sv, "_<(%.10seval %lu)[%s:%"IVdf"]", @@ -2594,7 +2652,9 @@ Perl_sv_compile_2op(pTHX_ SV *sv, OP** startop, char *code, AV** avp) } else sprintf(tmpbuf, "_<(%.10s_eval %lu)", code, (unsigned long)++PL_evalseq); + SAVECOPFILE_FREE(&PL_compiling); CopFILE_set(&PL_compiling, tmpbuf+2); + SAVECOPLINE(&PL_compiling); CopLINE_set(&PL_compiling, 1); /* XXX For Cs within BEGIN {} blocks, this ends up deleting the eval's FILEGV from the stash before gv_check() runs @@ -2697,8 +2757,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); @@ -2711,6 +2774,7 @@ S_doeval(pTHX_ int gimme, OP** startop) SAVESPTR(PL_beginav); PL_beginav = newAV(); SAVEFREESV(PL_beginav); + SAVEI32(PL_error_count); /* try to compile it */ @@ -2864,8 +2928,8 @@ PP(pp_require) sv = POPs; if (SvNIOKp(sv)) { - UV rev, ver, sver; - if (SvPOKp(sv)) { /* require v5.6.1 */ + if (SvPOK(sv) && SvNOK(sv)) { /* require v5.6.1 */ + UV rev = 0, ver = 0, sver = 0; I32 len; U8 *s = (U8*)SvPVX(sv); U8 *end = (U8*)SvPVX(sv) + SvCUR(sv); @@ -2877,41 +2941,49 @@ PP(pp_require) s += len; if (s < end) sver = utf8_to_uv(s, &len); - else - sver = 0; } - else - ver = 0; } - else - rev = 0; if (PERL_REVISION < rev || (PERL_REVISION == rev && (PERL_VERSION < ver || (PERL_VERSION == ver && PERL_SUBVERSION < sver)))) { - DIE(aTHX_ "Perl v%"UVuf".%"UVuf".%"UVuf" required--this is only version " + DIE(aTHX_ "Perl v%"UVuf".%"UVuf".%"UVuf" required--this is only " "v%d.%d.%d, stopped", rev, ver, sver, PERL_REVISION, PERL_VERSION, PERL_SUBVERSION); } + RETPUSHYES; } 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)) { - 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); + 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); + + /* help out with the "use 5.6" confusion */ + if (sver == 0 && (rev > 5 || (rev == 5 && ver >= 100))) { + DIE(aTHX_ "Perl v%"UVuf".%"UVuf".%"UVuf" required--" + "this is only v%d.%d.%d, stopped" + " (did you mean v%"UVuf".%"UVuf".0?)", + rev, ver, sver, PERL_REVISION, PERL_VERSION, + PERL_SUBVERSION, rev, ver/100); + } + else { + DIE(aTHX_ "Perl v%"UVuf".%"UVuf".%"UVuf" required--" + "this is only v%d.%d.%d, stopped", + rev, ver, sver, PERL_REVISION, PERL_VERSION, + PERL_SUBVERSION); + } } + RETPUSHYES; } - RETPUSHYES; } name = SvPV(sv, len); if (!(name && len > 0 && *name)) @@ -2930,8 +3002,19 @@ PP(pp_require) { tryname = name; tryrsfp = doopen_pmc(name,PERL_SCRIPT_MODE); +#ifdef MACOS_TRADITIONAL + /* We consider paths of the form :a:b ambiguous and interpret them first + as global then as local + */ + if (!tryrsfp && name[0] == ':' && name[1] != ':' && strchr(name+2, ':')) + goto trylocal; + } + else +trylocal: { +#else } else { +#endif AV *ar = GvAVn(PL_incgv); I32 i; #ifdef VMS @@ -3049,6 +3132,10 @@ PP(pp_require) } else { char *dir = SvPVx(dirsv, n_a); +#ifdef MACOS_TRADITIONAL + /* We have ensured in incpush that library ends with ':' */ + Perl_sv_setpvf(aTHX_ namesv, "%s%s", dir, name+(name[0] == ':')); +#else #ifdef VMS char *unixdir; if ((unixdir = tounixpath(dir, Nullch)) == Nullch) @@ -3058,8 +3145,17 @@ PP(pp_require) #else Perl_sv_setpvf(aTHX_ namesv, "%s/%s", dir, name); #endif +#endif TAINT_PROPER("require"); tryname = SvPVX(namesv); +#ifdef MACOS_TRADITIONAL + { + /* Convert slashes in the name part, but not the directory part, to colons */ + char * colon; + for (colon = tryname+strlen(dir); colon = strchr(colon, '/'); ) + *colon++ = ':'; + } +#endif tryrsfp = doopen_pmc(tryname, PERL_SCRIPT_MODE); if (tryrsfp) { if (tryname[0] == '.' && tryname[1] == '/') @@ -3070,7 +3166,7 @@ PP(pp_require) } } } - SAVECOPFILE(&PL_compiling); + SAVECOPFILE_FREE(&PL_compiling); CopFILE_set(&PL_compiling, tryrsfp ? tryname : name); SvREFCNT_dec(namesv); if (!tryrsfp) { @@ -3119,11 +3215,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); @@ -3180,7 +3276,6 @@ PP(pp_entereval) /* switch to eval mode */ - SAVECOPFILE(&PL_compiling); if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) { SV *sv = sv_newmortal(); Perl_sv_setpvf(aTHX_ sv, "_<(eval %lu)[%s:%"IVdf"]", @@ -3190,7 +3285,9 @@ PP(pp_entereval) } else sprintf(tmpbuf, "_<(eval %lu)", (unsigned long)++PL_evalseq); + SAVECOPFILE_FREE(&PL_compiling); CopFILE_set(&PL_compiling, tmpbuf+2); + SAVECOPLINE(&PL_compiling); CopLINE_set(&PL_compiling, 1); /* XXX For Cs within BEGIN {} blocks, this ends up deleting the eval's FILEGV from the stash before gv_check() runs @@ -3202,9 +3299,11 @@ PP(pp_entereval) SAVEHINTS(); PL_hints = PL_op->op_targ; SAVESPTR(PL_compiling.cop_warnings); - if (!specialWARN(PL_compiling.cop_warnings)) { - PL_compiling.cop_warnings = newSVsv(PL_compiling.cop_warnings) ; - SAVEFREESV(PL_compiling.cop_warnings) ; + if (specialWARN(PL_curcop->cop_warnings)) + PL_compiling.cop_warnings = PL_curcop->cop_warnings; + else { + PL_compiling.cop_warnings = newSVsv(PL_curcop->cop_warnings); + SAVEFREESV(PL_compiling.cop_warnings); } push_return(PL_op->op_next); @@ -3289,9 +3388,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 +3412,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 +4063,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 +4084,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;