* 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"
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;
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)
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));
PMOP *newpm;
I32 optype = 0;
SV *sv;
+ OP *retop;
if (PL_curstackinfo->si_type == PERLSI_SORT) {
if (cxstack_ix == PL_sortcxix
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();
break;
case CXt_FORMAT:
POPFORMAT(cx);
+ retop = cx->blk_sub.retop;
break;
default:
DIE(aTHX_ "panic: return");
LEAVESUB(sv);
if (clear_errsv)
sv_setpv(ERRSV,"");
- return pop_return();
+ return retop;
}
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");
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 */
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);
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);
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);
SvPVX(av) = (char*)ary;
}
}
+ ++mark;
Copy(mark,AvARRAY(av),items,SV*);
AvFILLp(av) = items - 1;
assert(!AvREAL(av));
* 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:
if (!startop) {
POPBLOCK(cx,PL_curpm);
POPEVAL(cx);
- pop_return();
}
lex_end();
LEAVE;
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))
}
/* 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);
* 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 */
POPBLOCK(cx,newpm);
POPEVAL(cx);
- retop = pop_return();
+ retop = cx->blk_eval.retop;
TAINT_NOT;
if (gimme == G_VOID)
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,"");
POPBLOCK(cx,newpm);
POPEVAL(cx);
- retop = pop_return();
+ retop = cx->blk_eval.retop;
TAINT_NOT;
if (gimme == G_VOID)
projects / p5sagit/p5-mst-13.2.git / blobdiff