X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/894356b32151f778d4d2915c6db38e5d049b115a..faa7e5bbaa1a624cf61859998ab6ab0a1323ed35:/pp_ctl.c diff --git a/pp_ctl.c b/pp_ctl.c index af8b947..42811f5 100644 --- a/pp_ctl.c +++ b/pp_ctl.c @@ -1,6 +1,6 @@ /* pp_ctl.c * - * Copyright (c) 1991-1999, Larry Wall + * Copyright (c) 1991-2000, Larry Wall * * You may distribute under the terms of either the GNU General Public * License or the Artistic License, as specified in the README file. @@ -114,6 +114,8 @@ PP(pp_regcomp) PL_reginterp_cnt = I32_MAX; /* Mark as safe. */ pm->op_pmflags = pm->op_pmpermflags; /* reset case sensitivity */ + if (DO_UTF8(tmpstr)) + pm->op_pmdynflags |= PMdf_UTF8; pm->op_pmregexp = CALLREGCOMP(aTHX_ t, t + len, pm); PL_reginterp_cnt = 0; /* XXXX Be extra paranoid - needed inside tie/overload accessors. */ @@ -296,11 +298,17 @@ PP(pp_formline) NV value; bool gotsome; STRLEN len; - STRLEN fudge = SvCUR(tmpForm) * (IN_UTF8 ? 3 : 1) + 1; + STRLEN fudge = SvCUR(tmpForm) * (IN_BYTE ? 1 : 3) + 1; + 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); @@ -374,7 +382,7 @@ PP(pp_formline) case FF_CHECKNL: item = s = SvPV(sv, len); itemsize = len; - if (IN_UTF8) { + if (DO_UTF8(sv)) { itemsize = sv_len_utf8(sv); if (itemsize != len) { I32 itembytes; @@ -393,11 +401,13 @@ PP(pp_formline) break; s++; } + item_is_utf = TRUE; itemsize = s - item; sv_pos_b2u(sv, &itemsize); break; } } + item_is_utf = FALSE; if (itemsize > fieldsize) itemsize = fieldsize; send = chophere = s + itemsize; @@ -414,7 +424,7 @@ PP(pp_formline) case FF_CHECKCHOP: item = s = SvPV(sv, len); itemsize = len; - if (IN_UTF8) { + if (DO_UTF8(sv)) { itemsize = sv_len_utf8(sv); if (itemsize != len) { I32 itembytes; @@ -452,9 +462,11 @@ PP(pp_formline) itemsize = chophere - item; sv_pos_b2u(sv, &itemsize); } + item_is_utf = TRUE; break; } } + item_is_utf = FALSE; if (itemsize <= fieldsize) { send = chophere = s + itemsize; while (s < send) { @@ -510,7 +522,7 @@ PP(pp_formline) case FF_ITEM: arg = itemsize; s = item; - if (IN_UTF8) { + if (item_is_utf) { while (arg--) { if (*s & 0x80) { switch (UTF8SKIP(s)) { @@ -553,6 +565,7 @@ PP(pp_formline) case FF_LINEGLOB: item = s = SvPV(sv, len); itemsize = len; + item_is_utf = FALSE; /* XXX is this correct? */ if (itemsize) { gotsome = TRUE; send = s + itemsize; @@ -846,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; @@ -1062,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: @@ -1188,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: @@ -1225,7 +1238,6 @@ Perl_dounwind(pTHX_ I32 cxix) { dTHR; register PERL_CONTEXT *cx; - SV **newsp; I32 optype; while (cxstack_ix > cxix) { @@ -1309,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; @@ -1334,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); } } } @@ -1443,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) { @@ -1513,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); } } @@ -1548,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 == WARN_NONE || old_warnings == WARN_STD) + mask = newSVpvn(WARN_NONEstring, WARNsize) ; + else if (old_warnings == WARN_ALL) + mask = newSVpvn(WARN_ALLstring, WARNsize) ; + else + mask = newSVsv(old_warnings); + PUSHs(sv_2mortal(mask)); + } RETURN; } @@ -1800,9 +1822,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: @@ -1960,8 +1982,12 @@ PP(pp_next) dounwind(cxix); TOPBLOCK(cx); - oldsave = PL_scopestack[PL_scopestack_ix - 1]; - LEAVE_SCOPE(oldsave); + + /* 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; } @@ -2025,7 +2051,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; } } @@ -2119,7 +2145,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 @@ -2360,10 +2385,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) @@ -2501,9 +2528,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; } @@ -2521,10 +2556,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) { @@ -2534,10 +2577,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; } @@ -2554,8 +2599,9 @@ 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; - char tmpbuf[TYPE_DIGITS(long) + 12 + 10]; + OP *rop; + char tbuf[TYPE_DIGITS(long) + 12 + 10]; + char *tmpbuf = tbuf; char *safestr; ENTER; @@ -2569,7 +2615,15 @@ Perl_sv_compile_2op(pTHX_ SV *sv, OP** startop, char *code, AV** avp) } SAVECOPFILE(&PL_compiling); SAVECOPLINE(&PL_compiling); - sprintf(tmpbuf, "_<(%.10s_eval %lu)", code, (unsigned long)++PL_evalseq); + if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) { + SV *sv = sv_newmortal(); + Perl_sv_setpvf(aTHX_ sv, "_<(%.10seval %lu)[%s:%"IVdf"]", + code, (unsigned long)++PL_evalseq, + CopFILE(PL_curcop), (IV)CopLINE(PL_curcop)); + tmpbuf = SvPVX(sv); + } + else + sprintf(tmpbuf, "_<(%.10s_eval %lu)", code, (unsigned long)++PL_evalseq); CopFILE_set(&PL_compiling, tmpbuf+2); CopLINE_set(&PL_compiling, 1); /* XXX For Cs within BEGIN {} blocks, this ends up @@ -2673,8 +2727,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); @@ -2841,7 +2898,7 @@ PP(pp_require) sv = POPs; if (SvNIOKp(sv)) { UV rev, ver, sver; - if (SvPOKp(sv) && SvUTF8(sv)) { /* require v5.6.1 */ + if (SvPOKp(sv)) { /* require v5.6.1 */ I32 len; U8 *s = (U8*)SvPVX(sv); U8 *end = (U8*)SvPVX(sv) + SvCUR(sv); @@ -2873,15 +2930,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); @@ -3140,7 +3199,8 @@ PP(pp_entereval) register PERL_CONTEXT *cx; dPOPss; I32 gimme = GIMME_V, was = PL_sub_generation; - char tmpbuf[TYPE_DIGITS(long) + 12]; + char tbuf[TYPE_DIGITS(long) + 12]; + char *tmpbuf = tbuf; char *safestr; STRLEN len; OP *ret; @@ -3156,7 +3216,15 @@ PP(pp_entereval) /* switch to eval mode */ SAVECOPFILE(&PL_compiling); - sprintf(tmpbuf, "_<(eval %lu)", (unsigned long)++PL_evalseq); + if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) { + SV *sv = sv_newmortal(); + Perl_sv_setpvf(aTHX_ sv, "_<(eval %lu)[%s:%"IVdf"]", + (unsigned long)++PL_evalseq, + CopFILE(PL_curcop), (IV)CopLINE(PL_curcop)); + tmpbuf = SvPVX(sv); + } + else + sprintf(tmpbuf, "_<(eval %lu)", (unsigned long)++PL_evalseq); CopFILE_set(&PL_compiling, tmpbuf+2); CopLINE_set(&PL_compiling, 1); /* XXX For Cs within BEGIN {} blocks, this ends up @@ -3256,9 +3324,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 { @@ -3931,7 +3999,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; @@ -3952,7 +4020,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;