#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 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_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);
}
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);
}
}
+#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))
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);
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;
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 {
/* 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 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) {
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;
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;
projects / p5sagit/p5-mst-13.2.git / blobdiff