/* pp_ctl.c
*
* Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
- * 2000, 2001, 2002, 2003, by Larry Wall and others
+ * 2000, 2001, 2002, 2003, 2004, by Larry Wall and others
*
* You may distribute under the terms of either the GNU General Public
* License or the Artistic License, as specified in the README file.
* 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"
{
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
#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)
{
if (GIMME == G_ARRAY) {
dPOPPOPssrl;
- register I32 i, j;
+ register IV i, j;
register SV *sv;
- I32 max;
+ IV max;
if (SvGMAGICAL(left))
mg_get(left);
mg_get(right);
if (RANGE_IS_NUMERIC(left,right)) {
- if (SvNV(left) < IV_MIN || SvNV(right) > IV_MAX)
+ if ((SvOK(left) && SvNV(left) < IV_MIN) ||
+ (SvOK(right) && SvNV(right) > IV_MAX))
DIE(aTHX_ "Range iterator outside integer range");
i = SvIV(left);
max = SvIV(right);
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));
cx->blk_loop.iterary = (AV*)SvREFCNT_inc(POPs);
if (SvTYPE(cx->blk_loop.iterary) != SVt_PVAV) {
dPOPss;
- if (RANGE_IS_NUMERIC(sv,(SV*)cx->blk_loop.iterary)) {
- if (SvNV(sv) < IV_MIN ||
- SvNV((SV*)cx->blk_loop.iterary) >= IV_MAX)
+ SV *right = (SV*)cx->blk_loop.iterary;
+ if (RANGE_IS_NUMERIC(sv,right)) {
+ if ((SvOK(sv) && SvNV(sv) < IV_MIN) ||
+ (SvOK(right) && SvNV(right) >= IV_MAX))
DIE(aTHX_ "Range iterator outside integer range");
cx->blk_loop.iterix = SvIV(sv);
- cx->blk_loop.itermax = SvIV((SV*)cx->blk_loop.iterary);
+ cx->blk_loop.itermax = SvIV(right);
}
else {
STRLEN n_a;
cx->blk_loop.iterlval = newSVsv(sv);
- SvPV_force(cx->blk_loop.iterlval,n_a);
+ (void) SvPV_force(cx->blk_loop.iterlval,n_a);
+ (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;
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");
/* 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);
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)
* 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 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
*/
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