X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=pp_ctl.c;h=dd6962cd14e7d8e2bf73a37d7df75efa97b73bfc;hb=0c0f82231532c76a9c20f1dd989b3e879c19a114;hp=f0ac9fcb955eb7c8e205156e9312019028f29d02;hpb=4fe3f0fa0e8a231fc577c0b8520dc57000b1e088;p=p5sagit%2Fp5-mst-13.2.git diff --git a/pp_ctl.c b/pp_ctl.c index f0ac9fc..dd6962c 100644 --- a/pp_ctl.c +++ b/pp_ctl.c @@ -17,6 +17,17 @@ * And whither then? I cannot say. */ +/* This file contains control-oriented pp ("push/pop") functions that + * execute the opcodes that make up a perl program. A typical pp function + * expects to find its arguments on the stack, and usually pushes its + * results onto the stack, hence the 'pp' terminology. Each OP structure + * contains a pointer to the relevant pp_foo() function. + * + * Control-oriented means things like pp_enteriter() and pp_next(), which + * alter the flow of control of the program. + */ + + #include "EXTERN.h" #define PERL_IN_PP_CTL_C #include "perl.h" @@ -187,10 +198,13 @@ PP(pp_substcont) { SV *targ = cx->sb_targ; - if (DO_UTF8(dstr) && !SvUTF8(targ)) - sv_catpvn_utf8_upgrade(dstr, s, cx->sb_strend - s, nsv); - else - sv_catpvn(dstr, s, cx->sb_strend - s); + assert(cx->sb_strend >= s); + if(cx->sb_strend > s) { + if (DO_UTF8(dstr) && !SvUTF8(targ)) + sv_catpvn_utf8_upgrade(dstr, s, cx->sb_strend - s, nsv); + else + sv_catpvn(dstr, s, cx->sb_strend - s); + } cx->sb_rxtainted |= RX_MATCH_TAINTED(rx); #ifdef PERL_COPY_ON_WRITE @@ -199,7 +213,7 @@ PP(pp_substcont) } else #endif { - (void)SvOOK_off(targ); + SvOOK_off(targ); if (SvLEN(targ)) Safefree(SvPVX(targ)); } @@ -365,7 +379,8 @@ PP(pp_formline) NV value; bool gotsome = FALSE; STRLEN len; - STRLEN fudge = SvCUR(tmpForm) * (IN_BYTES ? 1 : 3) + 1; + STRLEN fudge = SvPOK(tmpForm) + ? (SvCUR(tmpForm) * (IN_BYTES ? 1 : 3) + 1) : 0; bool item_is_utf8 = FALSE; bool targ_is_utf8 = FALSE; SV * nsv = Nullsv; @@ -1058,8 +1073,9 @@ PP(pp_flip) #define RANGE_IS_NUMERIC(left,right) ( \ SvNIOKp(left) || (SvOK(left) && !SvPOKp(left)) || \ SvNIOKp(right) || (SvOK(right) && !SvPOKp(right)) || \ - (((!SvOK(left) && SvOK(right)) || (looks_like_number(left) && \ - SvPOKp(left) && *SvPVX(left) != '0')) && looks_like_number(right))) + (((!SvOK(left) && SvOK(right)) || ((!SvOK(left) || \ + looks_like_number(left)) && SvPOKp(left) && *SvPVX(left) != '0')) \ + && (!SvOK(right) || looks_like_number(right)))) PP(pp_flop) { @@ -1430,7 +1446,8 @@ Perl_die_where(pTHX_ char *message, STRLEN msglen) DIE(aTHX_ "%sCompilation failed in require", *msg ? msg : "Unknown error\n"); } - return pop_return(); + assert(CxTYPE(cx) == CXt_EVAL); + return cx->blk_eval.retop; } } if (!message) @@ -1724,9 +1741,9 @@ PP(pp_dbstate) hasargs = 0; SPAGAIN; - push_return(PL_op->op_next); PUSHBLOCK(cx, CXt_SUB, SP); PUSHSUB_DB(cx); + cx->blk_sub.retop = PL_op->op_next; CvDEPTH(cv)++; PAD_SET_CUR(CvPADLIST(cv),1); RETURNOP(CvSTART(cv)); @@ -1806,11 +1823,22 @@ PP(pp_enteriter) (void) SvPV(right,n_a); } } + else if (PL_op->op_private & OPpITER_REVERSED) { + cx->blk_loop.itermax = -1; + cx->blk_loop.iterix = AvFILL(cx->blk_loop.iterary); + + } } else { cx->blk_loop.iterary = PL_curstack; AvFILLp(PL_curstack) = SP - PL_stack_base; - cx->blk_loop.iterix = MARK - PL_stack_base; + if (PL_op->op_private & OPpITER_REVERSED) { + cx->blk_loop.itermax = MARK - PL_stack_base; + cx->blk_loop.iterix = cx->blk_oldsp; + } + else { + cx->blk_loop.iterix = MARK - PL_stack_base; + } } RETURN; @@ -1884,6 +1912,7 @@ PP(pp_return) PMOP *newpm; I32 optype = 0; SV *sv; + OP *retop; if (PL_curstackinfo->si_type == PERLSI_SORT) { if (cxstack_ix == PL_sortcxix @@ -1907,12 +1936,14 @@ PP(pp_return) switch (CxTYPE(cx)) { case CXt_SUB: popsub2 = TRUE; + retop = cx->blk_sub.retop; cxstack_ix++; /* preserve cx entry on stack for use by POPSUB */ break; case CXt_EVAL: if (!(PL_in_eval & EVAL_KEEPERR)) clear_errsv = TRUE; POPEVAL(cx); + retop = cx->blk_eval.retop; if (CxTRYBLOCK(cx)) break; lex_end(); @@ -1927,6 +1958,7 @@ PP(pp_return) break; case CXt_FORMAT: POPFORMAT(cx); + retop = cx->blk_sub.retop; break; default: DIE(aTHX_ "panic: return"); @@ -1980,7 +2012,7 @@ PP(pp_return) LEAVESUB(sv); if (clear_errsv) sv_setpv(ERRSV,""); - return pop_return(); + return retop; } PP(pp_last) @@ -2021,15 +2053,15 @@ PP(pp_last) break; case CXt_SUB: pop2 = CXt_SUB; - nextop = pop_return(); + nextop = cx->blk_sub.retop; break; case CXt_EVAL: POPEVAL(cx); - nextop = pop_return(); + nextop = cx->blk_eval.retop; break; case CXt_FORMAT: POPFORMAT(cx); - nextop = pop_return(); + nextop = cx->blk_sub.retop; break; default: DIE(aTHX_ "panic: last"); @@ -2236,16 +2268,13 @@ PP(pp_goto) TOPBLOCK(cx); if (CxREALEVAL(cx)) DIE(aTHX_ "Can't goto subroutine from an eval-string"); - mark = PL_stack_sp; if (CxTYPE(cx) == CXt_SUB && cx->blk_sub.hasargs) { /* put @_ back onto stack */ AV* av = cx->blk_sub.argarray; items = AvFILLp(av) + 1; - PL_stack_sp++; - EXTEND(PL_stack_sp, items); /* @_ could have been extended. */ - Copy(AvARRAY(av), PL_stack_sp, items, SV*); - PL_stack_sp += items; + EXTEND(SP, items+1); /* @_ could have been extended. */ + Copy(AvARRAY(av), SP + 1, items, SV*); SvREFCNT_dec(GvAV(PL_defgv)); GvAV(PL_defgv) = cx->blk_sub.savearray; /* abandon @_ if it got reified */ @@ -2263,11 +2292,11 @@ PP(pp_goto) AV* av; av = GvAV(PL_defgv); items = AvFILLp(av) + 1; - PL_stack_sp++; - EXTEND(PL_stack_sp, items); /* @_ could have been extended. */ - Copy(AvARRAY(av), PL_stack_sp, items, SV*); - PL_stack_sp += items; + EXTEND(SP, items+1); /* @_ could have been extended. */ + Copy(AvARRAY(av), SP + 1, items, SV*); } + mark = SP; + SP += items; if (CxTYPE(cx) == CXt_SUB && !(CvDEPTH(cx->blk_sub.cv) = cx->blk_sub.olddepth)) SvREFCNT_dec(cx->blk_sub.cv); @@ -2300,16 +2329,17 @@ PP(pp_goto) SV **newsp; I32 gimme; - PL_stack_sp--; /* There is no cv arg. */ /* Push a mark for the start of arglist */ PUSHMARK(mark); + PUTBACK; (void)(*CvXSUB(cv))(aTHX_ cv); /* Pop the current context like a decent sub should */ POPBLOCK(cx, PL_curpm); /* Do _not_ use PUTBACK, keep the XSUB's return stack! */ } LEAVE; - return pop_return(); + assert(CxTYPE(cx) == CXt_SUB); + return cx->blk_sub.retop; } else { AV* padlist = CvPADLIST(cv); @@ -2328,7 +2358,7 @@ PP(pp_goto) else { if (CvDEPTH(cv) == 100 && ckWARN(WARN_RECURSION)) sub_crush_depth(cv); - pad_push(padlist, CvDEPTH(cv), cx->blk_sub.hasargs); + pad_push(padlist, CvDEPTH(cv), 1); } PAD_SET_CUR(padlist, CvDEPTH(cv)); if (cx->blk_sub.hasargs) @@ -2340,7 +2370,6 @@ PP(pp_goto) GvAV(PL_defgv) = (AV*)SvREFCNT_inc(av); CX_CURPAD_SAVE(cx->blk_sub); cx->blk_sub.argarray = av; - ++mark; if (items >= AvMAX(av) + 1) { ary = AvALLOC(av); @@ -2355,6 +2384,7 @@ PP(pp_goto) SvPVX(av) = (char*)ary; } } + ++mark; Copy(mark,AvARRAY(av),items,SV*); AvFILLp(av) = items - 1; assert(!AvREAL(av)); @@ -2644,8 +2674,10 @@ S_docatch(pTHX_ OP *o) * the op to Nullop, we force an exit from the inner runops() * loop. DAPM. */ - retop = pop_return(); - push_return(Nullop); + assert(cxstack_ix >= 0); + assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL); + retop = cxstack[cxstack_ix].blk_eval.retop; + cxstack[cxstack_ix].blk_eval.retop = Nullop; #ifdef PERL_FLEXIBLE_EXCEPTIONS redo_body: @@ -2777,7 +2809,7 @@ Locate the CV corresponding to the currently executing sub or eval. If db_seqp is non_null, skip CVs that are in the DB package and populate *db_seqp with the cop sequence number at the point that the DB:: code was entered. (allows debuggers to eval in the scope of the breakpoint rather -than in in the scope of the debuger itself). +than in in the scope of the debugger itself). =cut */ @@ -2883,7 +2915,6 @@ S_doeval(pTHX_ int gimme, OP** startop, CV* outside, U32 seq) if (!startop) { POPBLOCK(cx,PL_curpm); POPEVAL(cx); - pop_return(); } lex_end(); LEAVE; @@ -3014,66 +3045,19 @@ PP(pp_require) OP *op; sv = POPs; - if (SvNIOKp(sv) && PL_op->op_type != OP_DOFILE) { - if (SvPOK(sv) && SvNOK(sv) && SvNV(sv)) { /* require v5.6.1 */ - UV rev = 0, ver = 0, sver = 0; - STRLEN len; - U8 *s = (U8*)SvPVX(sv); - U8 *end = (U8*)SvPVX(sv) + SvCUR(sv); - if (s < end) { - rev = utf8n_to_uvchr(s, end - s, &len, 0); - s += len; - if (s < end) { - ver = utf8n_to_uvchr(s, end - s, &len, 0); - s += len; - if (s < end) - sver = utf8n_to_uvchr(s, end - s, &len, 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 " - "v%d.%d.%d, stopped", rev, ver, sver, PERL_REVISION, - PERL_VERSION, PERL_SUBVERSION); - } - if (ckWARN(WARN_PORTABLE)) + if ( (SvNIOKp(sv) || SvVOK(sv)) && PL_op->op_type != OP_DOFILE) { + if ( SvVOK(sv) && ckWARN(WARN_PORTABLE) ) /* require v5.6.1 */ Perl_warner(aTHX_ packWARN(WARN_PORTABLE), "v-string in use/require non-portable"); + + sv = new_version(sv); + if (!sv_derived_from(PL_patchlevel, "version")) + (void *)upg_version(PL_patchlevel); + if ( vcmp(sv,PL_patchlevel) > 0 ) + DIE(aTHX_ "Perl v%_ required--this is only v%_, stopped", + vstringify(sv), vstringify(PL_patchlevel)); + RETPUSHYES; - } - else if (!SvPOKp(sv)) { /* require 5.005_03 */ - 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); - - /* 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" - " (did you mean v%"UVuf".%03"UVuf"?)--" - "this is only v%d.%d.%d, stopped", - rev, ver, sver, rev, ver/100, - PERL_REVISION, PERL_VERSION, PERL_SUBVERSION); - } - 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; - } } name = SvPV(sv, len); if (!(name && len > 0 && *name)) @@ -3341,9 +3325,9 @@ PP(pp_require) } /* switch to eval mode */ - push_return(PL_op->op_next); PUSHBLOCK(cx, CXt_EVAL, SP); PUSHEVAL(cx, name, Nullgv); + cx->blk_eval.retop = PL_op->op_next; SAVECOPLINE(&PL_compiling); CopLINE_set(&PL_compiling, 0); @@ -3434,9 +3418,9 @@ PP(pp_entereval) * to do the dirty work for us */ runcv = find_runcv(&seq); - push_return(PL_op->op_next); PUSHBLOCK(cx, (CXt_EVAL|CXp_REAL), SP); PUSHEVAL(cx, 0, Nullgv); + cx->blk_eval.retop = PL_op->op_next; /* prepare to compile string */ @@ -3465,7 +3449,7 @@ PP(pp_leaveeval) POPBLOCK(cx,newpm); POPEVAL(cx); - retop = pop_return(); + retop = cx->blk_eval.retop; TAINT_NOT; if (gimme == G_VOID) @@ -3528,9 +3512,9 @@ PP(pp_entertry) ENTER; SAVETMPS; - push_return(cLOGOP->op_other->op_next); PUSHBLOCK(cx, (CXt_EVAL|CXp_TRYBLOCK), SP); PUSHEVAL(cx, 0, 0); + cx->blk_eval.retop = cLOGOP->op_other->op_next; PL_in_eval = EVAL_INEVAL; sv_setpv(ERRSV,""); @@ -3551,7 +3535,7 @@ PP(pp_leavetry) POPBLOCK(cx,newpm); POPEVAL(cx); - retop = pop_return(); + retop = cx->blk_eval.retop; TAINT_NOT; if (gimme == G_VOID)