#define DOCATCH(o) ((CATCH_GET == TRUE) ? docatch(o) : (o))
+#ifdef PERL_OBJECT
+#define CALLOP this->*op
+#else
+#define CALLOP *op
static OP *docatch _((OP *o));
static OP *dofindlabel _((OP *o, char *label, OP **opstack, OP **oplimit));
static void doparseform _((SV *sv));
static I32 dopoptolabel _((char *label));
static I32 dopoptoloop _((I32 startingblock));
static I32 dopoptosub _((I32 startingblock));
+static I32 dopoptosub_at _((PERL_CONTEXT *cxstk, I32 startingblock));
static void save_lines _((AV *array, SV *sv));
static I32 sortcv _((SV *a, SV *b));
static void qsortsv _((SV **array, size_t num_elts, I32 (*fun)(SV *a, SV *b)));
static OP *doeval _((int gimme, OP** startop));
-
-static I32 sortcxix;
+#endif
PP(pp_wantarray)
{
return NORMAL;
}
-PP(pp_regcomp) {
+PP(pp_regcreset)
+{
+ /* XXXX Should store the old value to allow for tie/overload - and
+ restore in regcomp, where marked with XXXX. */
+ reginterp_cnt = 0;
+ return NORMAL;
+}
+
+PP(pp_regcomp)
+{
djSP;
register PMOP *pm = (PMOP*)cLOGOP->op_other;
register char *t;
MAGIC *mg = Null(MAGIC*);
tmpstr = POPs;
- if(SvROK(tmpstr)) {
+ if (SvROK(tmpstr)) {
SV *sv = SvRV(tmpstr);
if(SvMAGICAL(sv))
mg = mg_find(sv, 'r');
}
- if(mg) {
+ if (mg) {
regexp *re = (regexp *)mg->mg_obj;
ReREFCNT_dec(pm->op_pmregexp);
pm->op_pmregexp = ReREFCNT_inc(re);
ReREFCNT_dec(pm->op_pmregexp);
pm->op_pmregexp = Null(REGEXP*); /* crucial if regcomp aborts */
}
+ if (op->op_flags & OPf_SPECIAL)
+ reginterp_cnt = I32_MAX; /* Mark as safe. */
pm->op_pmflags = pm->op_pmpermflags; /* reset case sensitivity */
- pm->op_pmregexp = pregcomp(t, t + len, pm);
+ pm->op_pmregexp = CALLREGCOMP(t, t + len, pm);
+ reginterp_cnt = 0; /* XXXX Be extra paranoid - needed
+ inside tie/overload accessors. */
}
}
+#ifndef INCOMPLETE_TAINTS
+ if (tainting) {
+ if (tainted)
+ pm->op_pmdynflags |= PMdf_TAINTED;
+ else
+ pm->op_pmdynflags &= ~PMdf_TAINTED;
+ }
+#endif
+
if (!pm->op_pmregexp->prelen && curpm)
pm = curpm;
else if (strEQ("\\s+", pm->op_pmregexp->precomp))
if (cx->sb_iters > cx->sb_maxiters)
DIE("Substitution loop");
- if (!cx->sb_rxtainted)
- cx->sb_rxtainted = SvTAINTED(TOPs);
+ if (!(cx->sb_rxtainted & 2) && SvTAINTED(TOPs))
+ cx->sb_rxtainted |= 2;
sv_catsv(dstr, POPs);
/* Are we done */
- if (cx->sb_once || !regexec_flags(rx, s, cx->sb_strend, orig,
+ if (cx->sb_once || !CALLREGEXEC(rx, s, cx->sb_strend, orig,
s == m, Nullsv, NULL,
cx->sb_safebase ? 0 : REXEC_COPY_STR))
{
SV *targ = cx->sb_targ;
sv_catpvn(dstr, s, cx->sb_strend - s);
- TAINT_IF(cx->sb_rxtainted || RX_MATCH_TAINTED(rx));
+ cx->sb_rxtainted |= RX_MATCH_TAINTED(rx);
(void)SvOOK_off(targ);
Safefree(SvPVX(targ));
SvLEN_set(targ, SvLEN(dstr));
SvPVX(dstr) = 0;
sv_free(dstr);
+
+ TAINT_IF(cx->sb_rxtainted & 1);
+ PUSHs(sv_2mortal(newSViv((I32)cx->sb_iters - 1)));
+
(void)SvPOK_only(targ);
+ TAINT_IF(cx->sb_rxtainted);
SvSETMAGIC(targ);
SvTAINT(targ);
- PUSHs(sv_2mortal(newSViv((I32)cx->sb_iters - 1)));
LEAVE_SCOPE(cx->sb_oldsave);
POPSUBST(cx);
RETURNOP(pm->op_next);
PP(pp_formline)
{
djSP; dMARK; dORIGMARK;
- register SV *form = *++MARK;
+ register SV *tmpForm = *++MARK;
register U16 *fpc;
register char *t;
register char *f;
bool gotsome;
STRLEN len;
- if (!SvMAGICAL(form) || !SvCOMPILED(form)) {
- SvREADONLY_off(form);
- doparseform(form);
+ if (!SvMAGICAL(tmpForm) || !SvCOMPILED(tmpForm)) {
+ SvREADONLY_off(tmpForm);
+ doparseform(tmpForm);
}
SvPV_force(formtarget, len);
- t = SvGROW(formtarget, len + SvCUR(form) + 1); /* XXX SvCUR bad */
+ t = SvGROW(formtarget, len + SvCUR(tmpForm) + 1); /* XXX SvCUR bad */
t += len;
- f = SvPV(form, len);
+ f = SvPV(tmpForm, len);
/* need to jump to the next word */
- s = f + len + WORD_ALIGN - SvCUR(form) % WORD_ALIGN;
+ s = f + len + WORD_ALIGN - SvCUR(tmpForm) % WORD_ALIGN;
fpc = (U16*)s;
}
SvCUR_set(formtarget, t - SvPVX(formtarget));
sv_catpvn(formtarget, item, itemsize);
- SvGROW(formtarget, SvCUR(formtarget) + SvCUR(form) + 1);
+ SvGROW(formtarget, SvCUR(formtarget) + SvCUR(tmpForm) + 1);
t = SvPVX(formtarget) + SvCUR(formtarget);
}
break;
}
}
-
PP(pp_sort)
{
djSP; dMARK; dORIGMARK;
SAVEOP();
CATCH_SET(TRUE);
- PUSHSTACK(SI_SORT);
+ PUSHSTACKi(PERLSI_SORT);
if (sortstash != stash) {
firstgv = gv_fetchpv("a", TRUE, SVt_PV);
secondgv = gv_fetchpv("b", TRUE, SVt_PV);
(void)SvREFCNT_inc(cv); /* in preparation for POPSUB */
}
sortcxix = cxstack_ix;
-
- qsortsv(myorigmark+1, max, sortcv);
+ qsortsv((myorigmark+1), max, FUNC_NAME_TO_PTR(sortcv));
POPBLOCK(cx,curpm);
- POPSTACK();
+ POPSTACK;
CATCH_SET(oldcatch);
}
}
if (max > 1) {
MEXTEND(SP, 20); /* Can't afford stack realloc on signal. */
qsortsv(ORIGMARK+1, max,
- (op->op_private & OPpLOCALE) ? sv_cmp_locale : sv_cmp);
+ (op->op_private & OPpLOCALE)
+ ? FUNC_NAME_TO_PTR(sv_cmp_locale)
+ : FUNC_NAME_TO_PTR(sv_cmp));
}
}
LEAVE;
SV *targ = PAD_SV(op->op_targ);
if ((op->op_private & OPpFLIP_LINENUM)
- ? last_in_gv && SvIV(sv) == IoLINES(GvIOp(last_in_gv))
+ ? (last_in_gv && SvIV(sv) == (IV)IoLINES(GvIOp(last_in_gv)))
: SvTRUE(sv) ) {
sv_setiv(PAD_SV(cUNOP->op_first->op_targ), 1);
if (op->op_flags & OPf_SPECIAL) {
if (SvNIOKp(left) || !SvPOKp(left) ||
(looks_like_number(left) && *SvPVX(left) != '0') )
{
+ if (SvNV(left) < IV_MIN || SvNV(right) >= IV_MAX)
+ croak("Range iterator outside integer range");
i = SvIV(left);
max = SvIV(right);
if (max >= i) {
char *tmps = SvPV(final, len);
sv = sv_mortalcopy(left);
- while (!SvNIOKp(sv) && SvCUR(sv) <= len &&
- strNE(SvPVX(sv),tmps) ) {
+ while (!SvNIOKp(sv) && SvCUR(sv) <= len) {
XPUSHs(sv);
+ if (strEQ(SvPVX(sv),tmps))
+ break;
sv = sv_2mortal(newSVsv(sv));
sv_inc(sv);
}
- if (strEQ(SvPVX(sv),tmps))
- XPUSHs(sv);
}
}
else {
SV *targ = PAD_SV(cUNOP->op_first->op_targ);
sv_inc(targ);
if ((op->op_private & OPpFLIP_LINENUM)
- ? last_in_gv && SvIV(sv) == IoLINES(GvIOp(last_in_gv))
+ ? (last_in_gv && SvIV(sv) == (IV)IoLINES(GvIOp(last_in_gv)))
: SvTRUE(sv) ) {
sv_setiv(PAD_SV(((UNOP*)cUNOP->op_first)->op_first->op_targ), 0);
sv_catpv(targ, "E0");
/* Control. */
-static I32
+STATIC I32
dopoptolabel(char *label)
{
dTHR;
return G_VOID;
switch (cxstack[cxix].blk_gimme) {
+ case G_VOID:
+ return G_VOID;
case G_SCALAR:
return G_SCALAR;
case G_ARRAY:
return G_ARRAY;
default:
croak("panic: bad gimme: %d\n", cxstack[cxix].blk_gimme);
- case G_VOID:
- return G_VOID;
+ /* NOTREACHED */
+ return 0;
}
}
-static I32
+STATIC I32
dopoptosub(I32 startingblock)
{
dTHR;
+ return dopoptosub_at(cxstack, startingblock);
+}
+
+STATIC I32
+dopoptosub_at(PERL_CONTEXT *cxstk, I32 startingblock)
+{
+ dTHR;
I32 i;
register PERL_CONTEXT *cx;
for (i = startingblock; i >= 0; i--) {
- cx = &cxstack[i];
+ cx = &cxstk[i];
switch (cx->cx_type) {
default:
continue;
return i;
}
-static I32
+STATIC I32
dopoptoeval(I32 startingblock)
{
dTHR;
return i;
}
-static I32
+STATIC I32
dopoptoloop(I32 startingblock)
{
dTHR;
I32 gimme;
SV **newsp;
- if (in_eval & 4) {
- SV **svp;
- STRLEN klen = strlen(message);
-
- svp = hv_fetch(ERRHV, message, klen, TRUE);
- if (svp) {
- if (!SvIOK(*svp)) {
- static char prefix[] = "\t(in cleanup) ";
- SV *err = ERRSV;
- sv_upgrade(*svp, SVt_IV);
- (void)SvIOK_only(*svp);
- if (!SvPOK(err))
- sv_setpv(err,"");
- SvGROW(err, SvCUR(err)+sizeof(prefix)+klen);
- sv_catpvn(err, prefix, sizeof(prefix)-1);
- sv_catpvn(err, message, klen);
+ if (message) {
+ if (in_eval & 4) {
+ SV **svp;
+ STRLEN klen = strlen(message);
+
+ svp = hv_fetch(ERRHV, message, klen, TRUE);
+ if (svp) {
+ if (!SvIOK(*svp)) {
+ static char prefix[] = "\t(in cleanup) ";
+ SV *err = ERRSV;
+ sv_upgrade(*svp, SVt_IV);
+ (void)SvIOK_only(*svp);
+ if (!SvPOK(err))
+ sv_setpv(err,"");
+ SvGROW(err, SvCUR(err)+sizeof(prefix)+klen);
+ sv_catpvn(err, prefix, sizeof(prefix)-1);
+ sv_catpvn(err, message, klen);
+ }
+ sv_inc(*svp);
}
- sv_inc(*svp);
}
+ else
+ sv_setpv(ERRSV, message);
}
else
- sv_setpv(ERRSV, message);
-
+ message = SvPVx(ERRSV, na);
+
while ((cxix = dopoptoeval(cxstack_ix)) < 0 && curstackinfo->si_prev) {
dounwind(-1);
- POPSTACK();
+ POPSTACK;
}
if (cxix >= 0) {
djSP;
register I32 cxix = dopoptosub(cxstack_ix);
register PERL_CONTEXT *cx;
+ register PERL_CONTEXT *ccstack = cxstack;
+ PERL_SI *top_si = curstackinfo;
I32 dbcxix;
I32 gimme;
HV *hv;
count = POPi;
EXTEND(SP, 6);
for (;;) {
+ /* we may be in a higher stacklevel, so dig down deeper */
+ while (cxix < 0 && top_si->si_type != PERLSI_MAIN) {
+ top_si = top_si->si_prev;
+ ccstack = top_si->si_cxstack;
+ cxix = dopoptosub_at(ccstack, top_si->si_cxix);
+ }
if (cxix < 0) {
if (GIMME != G_ARRAY)
RETPUSHUNDEF;
RETURN;
}
if (DBsub && cxix >= 0 &&
- cxstack[cxix].blk_sub.cv == GvCV(DBsub))
+ ccstack[cxix].blk_sub.cv == GvCV(DBsub))
count++;
if (!count--)
break;
- cxix = dopoptosub(cxix - 1);
+ cxix = dopoptosub_at(ccstack, cxix - 1);
}
- cx = &cxstack[cxix];
- if (cxstack[cxix].cx_type == CXt_SUB) {
- dbcxix = dopoptosub(cxix - 1);
- /* We expect that cxstack[dbcxix] is CXt_SUB, anyway, the
+
+ cx = &ccstack[cxix];
+ if (ccstack[cxix].cx_type == CXt_SUB) {
+ dbcxix = dopoptosub_at(ccstack, cxix - 1);
+ /* We expect that ccstack[dbcxix] is CXt_SUB, anyway, the
field below is defined for any cx. */
- if (DBsub && dbcxix >= 0 && cxstack[dbcxix].blk_sub.cv == GvCV(DBsub))
- cx = &cxstack[dbcxix];
+ if (DBsub && dbcxix >= 0 && ccstack[dbcxix].blk_sub.cv == GvCV(DBsub))
+ cx = &ccstack[dbcxix];
}
if (GIMME != G_ARRAY) {
PUSHs(sv_2mortal(newSViv((I32)cx->blk_oldcop->cop_line)));
if (!MAXARG)
RETURN;
- if (cx->cx_type == CXt_SUB) { /* So is cxstack[dbcxix]. */
+ if (cx->cx_type == CXt_SUB) { /* So is ccstack[dbcxix]. */
sv = NEWSV(49, 0);
- gv_efullname3(sv, CvGV(cxstack[cxix].blk_sub.cv), Nullch);
+ gv_efullname3(sv, CvGV(ccstack[cxix].blk_sub.cv), Nullch);
PUSHs(sv_2mortal(sv));
PUSHs(sv_2mortal(newSViv((I32)cx->blk_sub.hasargs)));
}
RETURN;
}
-static I32
+STATIC I32
sortcv(SV *a, SV *b)
{
dTHR;
GvSV(secondgv) = b;
stack_sp = stack_base;
op = sortcop;
- runops();
+ CALLRUNOPS();
if (stack_sp != stack_base + 1)
croak("Sort subroutine didn't return single value");
if (!SvNIOKp(*stack_sp))
PUSHBLOCK(cx, CXt_LOOP, SP);
PUSHLOOP(cx, svp, MARK);
- if (op->op_flags & OPf_STACKED)
+ if (op->op_flags & OPf_STACKED) {
cx->blk_loop.iterary = (AV*)SvREFCNT_inc(POPs);
+ if (SvTYPE(cx->blk_loop.iterary) != SVt_PVAV) {
+ dPOPss;
+ if (SvNIOKp(sv) || !SvPOKp(sv) ||
+ (looks_like_number(sv) && *SvPVX(sv) != '0')) {
+ if (SvNV(sv) < IV_MIN ||
+ SvNV((SV*)cx->blk_loop.iterary) >= IV_MAX)
+ croak("Range iterator outside integer range");
+ cx->blk_loop.iterix = SvIV(sv);
+ cx->blk_loop.itermax = SvIV((SV*)cx->blk_loop.iterary);
+ }
+ else
+ cx->blk_loop.iterlval = newSVsv(sv);
+ }
+ }
else {
cx->blk_loop.iterary = curstack;
AvFILLp(curstack) = SP - stack_base;
PMOP *newpm;
I32 optype = 0;
- if (curstackinfo->si_type == SI_SORT) {
+ if (curstackinfo->si_type == PERLSI_SORT) {
if (cxstack_ix == sortcxix || dopoptosub(cxstack_ix) <= sortcxix) {
if (cxstack_ix > sortcxix)
dounwind(sortcxix);
TAINT_NOT;
if (gimme == G_SCALAR) {
- if (MARK < SP)
- *++newsp = (popsub2 && SvTEMP(*SP))
- ? *SP : sv_mortalcopy(*SP);
- else
+ if (MARK < SP) {
+ if (popsub2) {
+ if (cxsub.cv && CvDEPTH(cxsub.cv) > 1) {
+ if (SvTEMP(TOPs)) {
+ *++newsp = SvREFCNT_inc(*SP);
+ FREETMPS;
+ sv_2mortal(*newsp);
+ } else {
+ FREETMPS;
+ *++newsp = sv_mortalcopy(*SP);
+ }
+ } else
+ *++newsp = (SvTEMP(*SP)) ? *SP : sv_mortalcopy(*SP);
+ } else
+ *++newsp = sv_mortalcopy(*SP);
+ } else
*++newsp = &sv_undef;
}
else if (gimme == G_ARRAY) {
return cx->blk_loop.redo_op;
}
-static OP* lastgotoprobe;
-
-static OP *
+STATIC OP *
dofindlabel(OP *o, char *label, OP **opstack, OP **oplimit)
{
OP *kid;
}
*ops = 0;
if (o->op_flags & OPf_KIDS) {
+ dTHR;
/* First try all the kids at this level, since that's likeliest. */
for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
if ((kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) &&
AvREAL_off(av);
av_clear(av);
}
+ else if (CvXSUB(cv)) { /* put GvAV(defgv) back onto stack */
+ AV* av;
+ int i;
+#ifdef USE_THREADS
+ av = (AV*)curpad[0];
+#else
+ av = GvAV(defgv);
+#endif
+ items = AvFILLp(av) + 1;
+ stack_sp++;
+ EXTEND(stack_sp, items); /* @_ could have been extended. */
+ Copy(AvARRAY(av), stack_sp, items, SV*);
+ stack_sp += items;
+ }
if (cx->cx_type == CXt_SUB &&
!(CvDEPTH(cx->blk_sub.cv) = cx->blk_sub.olddepth))
SvREFCNT_dec(cx->blk_sub.cv);
SP = stack_base + items;
}
else {
+ SV **newsp;
+ I32 gimme;
+
stack_sp--; /* There is no cv arg. */
- (void)(*CvXSUB(cv))(cv);
+ /* Push a mark for the start of arglist */
+ PUSHMARK(mark);
+ (void)(*CvXSUB(cv))(cv _PERL_OBJECT_THIS);
+ /* Pop the current context like a decent sub should */
+ POPBLOCK(cx, curpm);
+ /* Do _not_ use PUTBACK, keep the XSUB's return stack! */
}
LEAVE;
return pop_return();
if (op->op_type == OP_ENTERITER)
DIE("Can't \"goto\" into the middle of a foreach loop",
label);
- (*op->op_ppaddr)(ARGS);
+ (CALLOP->op_ppaddr)(ARGS);
}
op = oldop;
}
/* Eval. */
-static void
+STATIC void
save_lines(AV *array, SV *sv)
{
register char *s = SvPVX(sv);
}
}
-static OP *
+STATIC OP *
docatch(OP *o)
{
dTHR;
restartop = 0;
/* FALL THROUGH */
case 0:
- runops();
+ CALLRUNOPS();
break;
}
JMPENV_POP;
introduced within evals. See force_ident(). GSAR 96-10-12 */
safestr = savepv(tmpbuf);
SAVEDELETE(defstash, safestr, strlen(safestr));
- SAVEI32(hints);
+ SAVEHINTS();
#ifdef OP_IN_REGISTER
opsave = op;
#else
}
/* With USE_THREADS, eval_owner must be held on entry to doeval */
-static OP *
+STATIC OP *
doeval(int gimme, OP** startop)
{
dSP;
SvREFCNT_dec(namesv);
if (!tryrsfp) {
if (op->op_type == OP_REQUIRE) {
- SV *msg = sv_2mortal(newSVpvf("Can't locate file '%s' in @INC", name));
+ SV *msg = sv_2mortal(newSVpvf("Can't locate %s in @INC", name));
SV *dirmsgsv = NEWSV(0, 0);
AV *ar = GvAVn(incgv);
I32 i;
rsfp = tryrsfp;
name = savepv(name);
SAVEFREEPV(name);
- SAVEI32(hints);
+ SAVEHINTS();
hints = 0;
/* switch to eval mode */
introduced within evals. See force_ident(). GSAR 96-10-12 */
safestr = savepv(tmpbuf);
SAVEDELETE(defstash, safestr, strlen(safestr));
- SAVEI32(hints);
+ SAVEHINTS();
hints = op->op_targ;
push_return(op->op_next);
RETURN;
}
-static void
+STATIC void
doparseform(SV *sv)
{
STRLEN len;
/* Return < 0 == 0 or > 0 as the value of elt1 is < elt2, == elt2, > elt2
*/
+#ifdef PERL_OBJECT
+#define qsort_cmp(elt1, elt2) \
+ ((this->*compare)(array[elt1], array[elt2]))
+#else
#define qsort_cmp(elt1, elt2) \
((*compare)(array[elt1], array[elt2]))
+#endif
#ifdef QSORT_ORDER_GUESS
#define QSORT_NOTICE_SWAP swapped++;
/* ****************************************************************** qsort */
-void
+STATIC void
+#ifdef PERL_OBJECT
+qsortsv(SV ** array, size_t num_elts, SVCOMPARE compare)
+#else
qsortsv(
SV ** array,
size_t num_elts,
I32 (*compare)(SV *a, SV *b))
+#endif
{
register SV * temp;