X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=pp_ctl.c;h=96e852e50ab59b89f2086b5407449eb95a1bb78b;hb=dcb4812c733545a68ef39b77c2dc4f7d440de203;hp=61e940fcacfac24e5e5353a901b9d33ca87406a7;hpb=d2719217c9b7910115cef7ea0c16d68e6b286cf7;p=p5sagit%2Fp5-mst-13.2.git diff --git a/pp_ctl.c b/pp_ctl.c index 61e940f..96e852e 100644 --- a/pp_ctl.c +++ b/pp_ctl.c @@ -25,6 +25,10 @@ #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)); @@ -36,8 +40,7 @@ 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) { @@ -64,7 +67,8 @@ PP(pp_regcmaybe) return NORMAL; } -PP(pp_regcomp) { +PP(pp_regcomp) +{ djSP; register PMOP *pm = (PMOP*)cLOGOP->op_other; register char *t; @@ -73,12 +77,12 @@ PP(pp_regcomp) { 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); @@ -101,6 +105,15 @@ PP(pp_regcomp) { } } +#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)) @@ -142,7 +155,6 @@ PP(pp_substcont) 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); @@ -244,7 +256,7 @@ rxres_free(void **rsp) PP(pp_formline) { djSP; dMARK; dORIGMARK; - register SV *form = *++MARK; + register SV *tmpForm = *++MARK; register U16 *fpc; register char *t; register char *f; @@ -263,17 +275,17 @@ PP(pp_formline) 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; @@ -448,7 +460,7 @@ PP(pp_formline) } 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; @@ -638,7 +650,6 @@ PP(pp_mapwhile) } } - PP(pp_sort) { djSP; dMARK; dORIGMARK; @@ -718,7 +729,7 @@ PP(pp_sort) SAVEOP(); CATCH_SET(TRUE); - PUSHSTACK(SI_SORT); + PUSHSTACKi(SI_SORT); if (sortstash != stash) { firstgv = gv_fetchpv("a", TRUE, SVt_PV); secondgv = gv_fetchpv("b", TRUE, SVt_PV); @@ -738,11 +749,10 @@ PP(pp_sort) (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); } } @@ -750,7 +760,9 @@ PP(pp_sort) 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; @@ -812,6 +824,8 @@ PP(pp_flop) 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) { @@ -829,14 +843,13 @@ PP(pp_flop) 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 { @@ -857,7 +870,7 @@ PP(pp_flop) /* Control. */ -static I32 +STATIC I32 dopoptolabel(char *label) { dTHR; @@ -928,7 +941,7 @@ block_gimme(void) } } -static I32 +STATIC I32 dopoptosub(I32 startingblock) { dTHR; @@ -948,7 +961,7 @@ dopoptosub(I32 startingblock) return i; } -static I32 +STATIC I32 dopoptoeval(I32 startingblock) { dTHR; @@ -967,7 +980,7 @@ dopoptoeval(I32 startingblock) return i; } -static I32 +STATIC I32 dopoptoloop(I32 startingblock) { dTHR; @@ -1072,7 +1085,7 @@ die_where(char *message) while ((cxix = dopoptoeval(cxstack_ix)) < 0 && curstackinfo->si_prev) { dounwind(-1); - POPSTACK(); + POPSTACK; } if (cxix >= 0) { @@ -1241,7 +1254,7 @@ PP(pp_caller) RETURN; } -static I32 +STATIC I32 sortcv(SV *a, SV *b) { dTHR; @@ -1252,7 +1265,7 @@ sortcv(SV *a, SV *b) 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)) @@ -1364,8 +1377,22 @@ PP(pp_enteriter) 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; @@ -1483,10 +1510,22 @@ PP(pp_return) 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) { @@ -1640,9 +1679,7 @@ PP(pp_redo) return cx->blk_loop.redo_op; } -static OP* lastgotoprobe; - -static OP * +STATIC OP * dofindlabel(OP *o, char *label, OP **opstack, OP **oplimit) { OP *kid; @@ -1749,6 +1786,20 @@ PP(pp_goto) 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); @@ -1771,8 +1822,16 @@ PP(pp_goto) 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(); @@ -1992,7 +2051,7 @@ PP(pp_goto) 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; } @@ -2080,7 +2139,7 @@ PP(pp_cswitch) /* Eval. */ -static void +STATIC void save_lines(AV *array, SV *sv) { register char *s = SvPVX(sv); @@ -2104,7 +2163,7 @@ save_lines(AV *array, SV *sv) } } -static OP * +STATIC OP * docatch(OP *o) { dTHR; @@ -2133,7 +2192,7 @@ docatch(OP *o) restartop = 0; /* FALL THROUGH */ case 0: - runops(); + CALLRUNOPS(); break; } JMPENV_POP; @@ -2174,7 +2233,7 @@ sv_compile_2op(SV *sv, OP** startop, char *code, AV** avp) 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 @@ -2203,7 +2262,7 @@ sv_compile_2op(SV *sv, OP** startop, char *code, AV** avp) } /* With USE_THREADS, eval_owner must be held on entry to doeval */ -static OP * +STATIC OP * doeval(int gimme, OP** startop) { dSP; @@ -2465,7 +2524,7 @@ PP(pp_require) SvREFCNT_dec(namesv); if (!tryrsfp) { if (op->op_type == OP_REQUIRE) { - SV *msg = sv_2mortal(newSVpvf("Can't locate '%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; @@ -2502,7 +2561,7 @@ PP(pp_require) rsfp = tryrsfp; name = savepv(name); SAVEFREEPV(name); - SAVEI32(hints); + SAVEHINTS(); hints = 0; /* switch to eval mode */ @@ -2562,7 +2621,7 @@ PP(pp_entereval) 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); @@ -2754,7 +2813,7 @@ PP(pp_leavetry) RETURN; } -static void +STATIC void doparseform(SV *sv) { STRLEN len; @@ -3038,8 +3097,13 @@ struct partition_stack_entry { /* 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++; @@ -3120,10 +3184,14 @@ doqsort_all_asserts( /* ****************************************************************** qsort */ 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;