X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/6d4ff0d2f86d3c242b3f29bee3c2734df9ab8a3a..0b250b9ef0d5134fdb23236140643970d9a3fbf5:/pp_ctl.c diff --git a/pp_ctl.c b/pp_ctl.c index 24cb7a3..2d29448 100644 --- a/pp_ctl.c +++ b/pp_ctl.c @@ -1,6 +1,6 @@ /* pp_ctl.c * - * Copyright (c) 1991-1997, Larry Wall + * Copyright (c) 1991-1999, Larry Wall * * You may distribute under the terms of either the GNU General Public * License or the Artistic License, as specified in the README file. @@ -17,6 +17,7 @@ */ #include "EXTERN.h" +#define PERL_IN_PP_CTL_C #include "perl.h" #ifndef WORD_ALIGN @@ -25,24 +26,32 @@ #define DOCATCH(o) ((CATCH_GET == TRUE) ? docatch(o) : (o)) -static OP *docatch _((OP *o)); -static OP *doeval _((int gimme)); -static OP *dofindlabel _((OP *o, char *label, OP **opstack, OP **oplimit)); -static void doparseform _((SV *sv)); -static I32 dopoptoeval _((I32 startingblock)); -static I32 dopoptolabel _((char *label)); -static I32 dopoptoloop _((I32 startingblock)); -static I32 dopoptosub _((I32 startingblock)); -static void save_lines _((AV *array, SV *sv)); -static int sortcv _((const void *, const void *)); -static int sortcmp _((const void *, const void *)); -static int sortcmp_locale _((const void *, const void *)); - -static I32 sortcxix; +#ifdef PERL_OBJECT +#define CALLOP this->*PL_op +#else +#define CALLOP *PL_op +#endif + +static I32 sortcv(pTHXo_ SV *a, SV *b); +static I32 sv_ncmp(pTHXo_ SV *a, SV *b); +static I32 sv_i_ncmp(pTHXo_ SV *a, SV *b); +static I32 amagic_ncmp(pTHXo_ SV *a, SV *b); +static I32 amagic_i_ncmp(pTHXo_ SV *a, SV *b); +static I32 amagic_cmp(pTHXo_ SV *a, SV *b); +static I32 amagic_cmp_locale(pTHXo_ SV *a, SV *b); +static I32 run_user_filter(pTHXo_ int idx, SV *buf_sv, int maxlen); + +#ifdef PERL_OBJECT +static I32 sv_cmp_static(pTHXo_ SV *a, SV *b); +static I32 sv_cmp_locale_static(pTHXo_ SV *a, SV *b); +#else +#define sv_cmp_static Perl_sv_cmp +#define sv_cmp_locale_static Perl_sv_cmp_locale +#endif PP(pp_wantarray) { - dSP; + djSP; I32 cxix; EXTEND(SP, 1); @@ -65,47 +74,82 @@ PP(pp_regcmaybe) return NORMAL; } -PP(pp_regcomp) { - dSP; +PP(pp_regcreset) +{ + /* XXXX Should store the old value to allow for tie/overload - and + restore in regcomp, where marked with XXXX. */ + PL_reginterp_cnt = 0; + return NORMAL; +} + +PP(pp_regcomp) +{ + djSP; register PMOP *pm = (PMOP*)cLOGOP->op_other; register char *t; SV *tmpstr; STRLEN len; + MAGIC *mg = Null(MAGIC*); tmpstr = POPs; - t = SvPV(tmpstr, len); - - /* JMR: Check against the last compiled regexp */ - if ( ! pm->op_pmregexp || ! pm->op_pmregexp->precomp - || strnNE(pm->op_pmregexp->precomp, t, len) - || pm->op_pmregexp->precomp[len]) { - if (pm->op_pmregexp) { - pregfree(pm->op_pmregexp); - pm->op_pmregexp = Null(REGEXP*); /* crucial if regcomp aborts */ + if (SvROK(tmpstr)) { + SV *sv = SvRV(tmpstr); + if(SvMAGICAL(sv)) + mg = mg_find(sv, 'r'); + } + if (mg) { + regexp *re = (regexp *)mg->mg_obj; + ReREFCNT_dec(pm->op_pmregexp); + pm->op_pmregexp = ReREFCNT_inc(re); + } + else { + t = SvPV(tmpstr, len); + + /* Check against the last compiled regexp. */ + if (!pm->op_pmregexp || !pm->op_pmregexp->precomp || + pm->op_pmregexp->prelen != len || + memNE(pm->op_pmregexp->precomp, t, len)) + { + if (pm->op_pmregexp) { + ReREFCNT_dec(pm->op_pmregexp); + pm->op_pmregexp = Null(REGEXP*); /* crucial if regcomp aborts */ + } + if (PL_op->op_flags & OPf_SPECIAL) + PL_reginterp_cnt = I32_MAX; /* Mark as safe. */ + + pm->op_pmflags = pm->op_pmpermflags; /* reset case sensitivity */ + pm->op_pmregexp = CALLREGCOMP(aTHX_ t, t + len, pm); + PL_reginterp_cnt = 0; /* XXXX Be extra paranoid - needed + inside tie/overload accessors. */ } + } - pm->op_pmflags = pm->op_pmpermflags; /* reset case sensitivity */ - pm->op_pmregexp = pregcomp(t, t + len, pm); +#ifndef INCOMPLETE_TAINTS + if (PL_tainting) { + if (PL_tainted) + pm->op_pmdynflags |= PMdf_TAINTED; + else + pm->op_pmdynflags &= ~PMdf_TAINTED; } +#endif - if (!pm->op_pmregexp->prelen && curpm) - pm = curpm; + if (!pm->op_pmregexp->prelen && PL_curpm) + pm = PL_curpm; else if (strEQ("\\s+", pm->op_pmregexp->precomp)) pm->op_pmflags |= PMf_WHITE; if (pm->op_pmflags & PMf_KEEP) { pm->op_private &= ~OPpRUNTIME; /* no point compiling again */ - hoistmust(pm); - cLOGOP->op_first->op_next = op->op_next; + cLOGOP->op_first->op_next = PL_op->op_next; } RETURN; } PP(pp_substcont) { - dSP; + djSP; register PMOP *pm = (PMOP*) cLOGOP->op_other; - register CONTEXT *cx = &cxstack[cxstack_ix]; + register PERL_CONTEXT *cx = &cxstack[cxstack_ix]; register SV *dstr = cx->sb_dstr; register char *s = cx->sb_s; register char *m = cx->sb_m; @@ -116,20 +160,23 @@ PP(pp_substcont) if (cx->sb_iters++) { if (cx->sb_iters > cx->sb_maxiters) - DIE("Substitution loop"); + DIE(aTHX_ "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 || !pregexec(rx, s, cx->sb_strend, orig, - s == m, Nullsv, cx->sb_safebase)) + if (cx->sb_once || !CALLREGEXEC(aTHX_ rx, s, cx->sb_strend, orig, + s == m, cx->sb_targ, NULL, + ((cx->sb_rflags & REXEC_COPY_STR) + ? (REXEC_IGNOREPOS|REXEC_NOT_FIRST) + : (REXEC_COPY_STR|REXEC_IGNOREPOS|REXEC_NOT_FIRST)))) { SV *targ = cx->sb_targ; sv_catpvn(dstr, s, cx->sb_strend - s); - TAINT_IF(cx->sb_rxtainted || rx->exec_tainted); + cx->sb_rxtainted |= RX_MATCH_TAINTED(rx); (void)SvOOK_off(targ); Safefree(SvPVX(targ)); @@ -138,35 +185,37 @@ PP(pp_substcont) 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); } } - if (rx->subbase && rx->subbase != orig) { + if (RX_MATCH_COPIED(rx) && rx->subbeg != orig) { m = s; s = orig; - cx->sb_orig = orig = rx->subbase; + cx->sb_orig = orig = rx->subbeg; s = orig + (m - s); cx->sb_strend = s + (cx->sb_strend - m); } - cx->sb_m = m = rx->startp[0]; + cx->sb_m = m = rx->startp[0] + orig; sv_catpvn(dstr, s, m-s); - cx->sb_s = rx->endp[0]; - cx->sb_rxtainted |= rx->exec_tainted; + cx->sb_s = rx->endp[0] + orig; + cx->sb_rxtainted |= RX_MATCH_TAINTED(rx); rxres_save(&cx->sb_rxres, rx); RETURNOP(pm->op_pmreplstart); } void -rxres_save(rsp, rx) -void **rsp; -REGEXP *rx; +Perl_rxres_save(pTHX_ void **rsp, REGEXP *rx) { UV *p = (UV*)*rsp; U32 i; @@ -180,13 +229,13 @@ REGEXP *rx; *rsp = (void*)p; } - *p++ = (UV)rx->subbase; - rx->subbase = Nullch; + *p++ = (UV)(RX_MATCH_COPIED(rx) ? rx->subbeg : Nullch); + RX_MATCH_COPIED_off(rx); *p++ = rx->nparens; *p++ = (UV)rx->subbeg; - *p++ = (UV)rx->subend; + *p++ = (UV)rx->sublen; for (i = 0; i <= rx->nparens; ++i) { *p++ = (UV)rx->startp[i]; *p++ = (UV)rx->endp[i]; @@ -194,30 +243,28 @@ REGEXP *rx; } void -rxres_restore(rsp, rx) -void **rsp; -REGEXP *rx; +Perl_rxres_restore(pTHX_ void **rsp, REGEXP *rx) { UV *p = (UV*)*rsp; U32 i; - Safefree(rx->subbase); - rx->subbase = (char*)(*p); + if (RX_MATCH_COPIED(rx)) + Safefree(rx->subbeg); + RX_MATCH_COPIED_set(rx, *p); *p++ = 0; rx->nparens = *p++; rx->subbeg = (char*)(*p++); - rx->subend = (char*)(*p++); + rx->sublen = (I32)(*p++); for (i = 0; i <= rx->nparens; ++i) { - rx->startp[i] = (char*)(*p++); - rx->endp[i] = (char*)(*p++); + rx->startp[i] = (I32)(*p++); + rx->endp[i] = (I32)(*p++); } } void -rxres_free(rsp) -void **rsp; +Perl_rxres_free(pTHX_ void **rsp) { UV *p = (UV*)*rsp; @@ -230,8 +277,8 @@ void **rsp; PP(pp_formline) { - dSP; dMARK; dORIGMARK; - register SV *form = *++MARK; + djSP; dMARK; dORIGMARK; + register SV *tmpForm = *++MARK; register U16 *fpc; register char *t; register char *f; @@ -243,24 +290,25 @@ PP(pp_formline) I32 itemsize; I32 fieldsize; I32 lines = 0; - bool chopspace = (strchr(chopset, ' ') != Nullch); + bool chopspace = (strchr(PL_chopset, ' ') != Nullch); char *chophere; char *linemark; - double value; + NV value; bool gotsome; STRLEN len; + STRLEN fudge = SvCUR(tmpForm) * (IN_UTF8 ? 3 : 1) + 1; - 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 */ + SvPV_force(PL_formtarget, len); + t = SvGROW(PL_formtarget, len + fudge + 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; @@ -317,15 +365,39 @@ PP(pp_formline) if (MARK < SP) sv = *++MARK; else { - sv = &sv_no; - if (dowarn) - warn("Not enough format arguments"); + sv = &PL_sv_no; + if (ckWARN(WARN_SYNTAX)) + Perl_warner(aTHX_ WARN_SYNTAX, "Not enough format arguments"); } break; case FF_CHECKNL: item = s = SvPV(sv, len); itemsize = len; + if (IN_UTF8) { + itemsize = sv_len_utf8(sv); + if (itemsize != len) { + I32 itembytes; + if (itemsize > fieldsize) { + itemsize = fieldsize; + itembytes = itemsize; + sv_pos_u2b(sv, &itembytes, 0); + } + else + itembytes = len; + send = chophere = s + itembytes; + while (s < send) { + if (*s & ~31) + gotsome = TRUE; + else if (*s == '\n') + break; + s++; + } + itemsize = s - item; + sv_pos_b2u(sv, &itemsize); + break; + } + } if (itemsize > fieldsize) itemsize = fieldsize; send = chophere = s + itemsize; @@ -342,6 +414,47 @@ PP(pp_formline) case FF_CHECKCHOP: item = s = SvPV(sv, len); itemsize = len; + if (IN_UTF8) { + itemsize = sv_len_utf8(sv); + if (itemsize != len) { + I32 itembytes; + if (itemsize <= fieldsize) { + send = chophere = s + itemsize; + while (s < send) { + if (*s == '\r') { + itemsize = s - item; + break; + } + if (*s++ & ~31) + gotsome = TRUE; + } + } + else { + itemsize = fieldsize; + itembytes = itemsize; + sv_pos_u2b(sv, &itembytes, 0); + send = chophere = s + itembytes; + while (s < send || (s == send && isSPACE(*s))) { + if (isSPACE(*s)) { + if (chopspace) + chophere = s; + if (*s == '\r') + break; + } + else { + if (*s & ~31) + gotsome = TRUE; + if (strchr(PL_chopset, *s)) + chophere = s + 1; + } + s++; + } + itemsize = chophere - item; + sv_pos_b2u(sv, &itemsize); + } + break; + } + } if (itemsize <= fieldsize) { send = chophere = s + itemsize; while (s < send) { @@ -366,7 +479,7 @@ PP(pp_formline) else { if (*s & ~31) gotsome = TRUE; - if (strchr(chopset, *s)) + if (strchr(PL_chopset, *s)) chophere = s + 1; } s++; @@ -397,16 +510,34 @@ PP(pp_formline) case FF_ITEM: arg = itemsize; s = item; + if (IN_UTF8) { + while (arg--) { + if (*s & 0x80) { + switch (UTF8SKIP(s)) { + case 7: *t++ = *s++; + case 6: *t++ = *s++; + case 5: *t++ = *s++; + case 4: *t++ = *s++; + case 3: *t++ = *s++; + case 2: *t++ = *s++; + case 1: *t++ = *s++; + } + } + else { + if ( !((*t++ = *s++) & ~31) ) + t[-1] = ' '; + } + } + break; + } while (arg--) { -#if 'z' - 'a' != 25 +#ifdef EBCDIC int ch = *t++ = *s++; - if (!iscntrl(ch)) - t[-1] = ' '; + if (iscntrl(ch)) #else if ( !((*t++ = *s++) & ~31) ) - t[-1] = ' '; #endif - + t[-1] = ' '; } break; @@ -433,10 +564,10 @@ PP(pp_formline) lines++; } } - SvCUR_set(formtarget, t - SvPVX(formtarget)); - sv_catpvn(formtarget, item, itemsize); - SvGROW(formtarget, SvCUR(formtarget) + SvCUR(form) + 1); - t = SvPVX(formtarget) + SvCUR(formtarget); + SvCUR_set(PL_formtarget, t - SvPVX(PL_formtarget)); + sv_catpvn(PL_formtarget, item, itemsize); + SvGROW(PL_formtarget, SvCUR(PL_formtarget) + fudge + 1); + t = SvPVX(PL_formtarget) + SvCUR(PL_formtarget); } break; @@ -453,11 +584,25 @@ PP(pp_formline) gotsome = TRUE; value = SvNV(sv); /* Formats aren't yet marked for locales, so assume "yes". */ - SET_NUMERIC_LOCAL(); - if (arg & 256) { - sprintf(t, "%#*.*f", (int) fieldsize, (int) arg & 255, value); - } else { - sprintf(t, "%*.0f", (int) fieldsize, value); + { + RESTORE_NUMERIC_LOCAL(); +#if defined(USE_LONG_DOUBLE) + if (arg & 256) { + sprintf(t, "%#*.*" PERL_PRIfldbl, + (int) fieldsize, (int) arg & 255, value); + } else { + sprintf(t, "%*.0" PERL_PRIfldbl, (int) fieldsize, value); + } +#else + if (arg & 256) { + sprintf(t, "%#*.*f", + (int) fieldsize, (int) arg & 255, value); + } else { + sprintf(t, "%*.0f", + (int) fieldsize, value); + } +#endif + RESTORE_NUMERIC_STANDARD(); } t += fieldsize; break; @@ -474,14 +619,14 @@ PP(pp_formline) if (gotsome) { if (arg) { /* repeat until fields exhausted? */ *t = '\0'; - SvCUR_set(formtarget, t - SvPVX(formtarget)); - lines += FmLINES(formtarget); + SvCUR_set(PL_formtarget, t - SvPVX(PL_formtarget)); + lines += FmLINES(PL_formtarget); if (lines == 200) { arg = t - linemark; if (strnEQ(linemark, linemark - arg, arg)) - DIE("Runaway format"); + DIE(aTHX_ "Runaway format"); } - FmLINES(formtarget) = lines; + FmLINES(PL_formtarget) = lines; SP = ORIGMARK; RETURNOP(cLISTOP->op_first); } @@ -493,7 +638,13 @@ PP(pp_formline) break; case FF_MORE: - if (itemsize) { + s = chophere; + send = item + len; + if (chopspace) { + while (*s && isSPACE(*s) && s < send) + s++; + } + if (s < send) { arg = fieldsize - itemsize; if (arg) { fieldsize -= arg; @@ -502,7 +653,7 @@ PP(pp_formline) } s = t - 3; if (strnEQ(s," ",3)) { - while (s > SvPVX(formtarget) && isSPACE(s[-1])) + while (s > SvPVX(PL_formtarget) && isSPACE(s[-1])) s--; } *s++ = '.'; @@ -513,8 +664,8 @@ PP(pp_formline) case FF_END: *t = '\0'; - SvCUR_set(formtarget, t - SvPVX(formtarget)); - FmLINES(formtarget) += lines; + SvCUR_set(PL_formtarget, t - SvPVX(PL_formtarget)); + FmLINES(PL_formtarget) += lines; SP = ORIGMARK; RETPUSHYES; } @@ -523,65 +674,65 @@ PP(pp_formline) PP(pp_grepstart) { - dSP; + djSP; SV *src; - if (stack_base + *markstack_ptr == sp) { + if (PL_stack_base + *PL_markstack_ptr == SP) { (void)POPMARK; if (GIMME_V == G_SCALAR) - XPUSHs(&sv_no); - RETURNOP(op->op_next->op_next); + XPUSHs(sv_2mortal(newSViv(0))); + RETURNOP(PL_op->op_next->op_next); } - stack_sp = stack_base + *markstack_ptr + 1; - pp_pushmark(ARGS); /* push dst */ - pp_pushmark(ARGS); /* push src */ + PL_stack_sp = PL_stack_base + *PL_markstack_ptr + 1; + pp_pushmark(); /* push dst */ + pp_pushmark(); /* push src */ ENTER; /* enter outer scope */ SAVETMPS; - SAVESPTR(GvSV(defgv)); - + /* SAVE_DEFSV does *not* suffice here for USE_THREADS */ + SAVESPTR(DEFSV); ENTER; /* enter inner scope */ - SAVESPTR(curpm); + SAVESPTR(PL_curpm); - src = stack_base[*markstack_ptr]; + src = PL_stack_base[*PL_markstack_ptr]; SvTEMP_off(src); - GvSV(defgv) = src; + DEFSV = src; PUTBACK; - if (op->op_type == OP_MAPSTART) - pp_pushmark(ARGS); /* push top */ - return ((LOGOP*)op->op_next)->op_other; + if (PL_op->op_type == OP_MAPSTART) + pp_pushmark(); /* push top */ + return ((LOGOP*)PL_op->op_next)->op_other; } PP(pp_mapstart) { - DIE("panic: mapstart"); /* uses grepstart */ + DIE(aTHX_ "panic: mapstart"); /* uses grepstart */ } PP(pp_mapwhile) { - dSP; - I32 diff = (sp - stack_base) - *markstack_ptr; + djSP; + I32 diff = (SP - PL_stack_base) - *PL_markstack_ptr; I32 count; I32 shift; SV** src; SV** dst; - ++markstack_ptr[-1]; + ++PL_markstack_ptr[-1]; if (diff) { - if (diff > markstack_ptr[-1] - markstack_ptr[-2]) { - shift = diff - (markstack_ptr[-1] - markstack_ptr[-2]); - count = (sp - stack_base) - markstack_ptr[-1] + 2; + if (diff > PL_markstack_ptr[-1] - PL_markstack_ptr[-2]) { + shift = diff - (PL_markstack_ptr[-1] - PL_markstack_ptr[-2]); + count = (SP - PL_stack_base) - PL_markstack_ptr[-1] + 2; - EXTEND(sp,shift); - src = sp; - dst = (sp += shift); - markstack_ptr[-1] += shift; - *markstack_ptr += shift; + EXTEND(SP,shift); + src = SP; + dst = (SP += shift); + PL_markstack_ptr[-1] += shift; + *PL_markstack_ptr += shift; while (--count) *dst-- = *src--; } - dst = stack_base + (markstack_ptr[-2] += diff) - 1; + dst = PL_stack_base + (PL_markstack_ptr[-2] += diff) - 1; ++diff; while (--diff) *dst-- = SvTEMP(TOPs) ? POPs : sv_mortalcopy(POPs); @@ -589,16 +740,16 @@ PP(pp_mapwhile) LEAVE; /* exit inner scope */ /* All done yet? */ - if (markstack_ptr[-1] > *markstack_ptr) { + if (PL_markstack_ptr[-1] > *PL_markstack_ptr) { I32 items; I32 gimme = GIMME_V; (void)POPMARK; /* pop top */ LEAVE; /* exit outer scope */ (void)POPMARK; /* pop src */ - items = --*markstack_ptr - markstack_ptr[-1]; + items = --*PL_markstack_ptr - PL_markstack_ptr[-1]; (void)POPMARK; /* pop dst */ - SP = stack_base + POPMARK; /* pop original mark */ + SP = PL_stack_base + POPMARK; /* pop original mark */ if (gimme == G_SCALAR) { dTARGET; XPUSHi(items); @@ -611,20 +762,19 @@ PP(pp_mapwhile) SV *src; ENTER; /* enter inner scope */ - SAVESPTR(curpm); + SAVESPTR(PL_curpm); - src = stack_base[markstack_ptr[-1]]; + src = PL_stack_base[PL_markstack_ptr[-1]]; SvTEMP_off(src); - GvSV(defgv) = src; + DEFSV = src; RETURNOP(cLOGOP->op_other); } } - PP(pp_sort) { - dSP; dMARK; dORIGMARK; + djSP; dMARK; dORIGMARK; register SV **up; SV **myorigmark = ORIGMARK; register I32 max; @@ -632,21 +782,23 @@ PP(pp_sort) GV *gv; CV *cv; I32 gimme = GIMME; - OP* nextop = op->op_next; + OP* nextop = PL_op->op_next; + I32 overloading = 0; if (gimme != G_ARRAY) { SP = MARK; RETPUSHUNDEF; } - if (op->op_flags & OPf_STACKED) { - ENTER; - if (op->op_flags & OPf_SPECIAL) { + ENTER; + SAVEPPTR(PL_sortcop); + if (PL_op->op_flags & OPf_STACKED) { + if (PL_op->op_flags & OPf_SPECIAL) { OP *kid = cLISTOP->op_first->op_sibling; /* pass pushmark */ kid = kUNOP->op_first; /* pass rv2gv */ kid = kUNOP->op_first; /* pass leave */ - sortcop = kid->op_next; - stash = curcop->cop_stash; + PL_sortcop = kid->op_next; + stash = PL_curcop->cop_stash; } else { cv = sv_2cv(*++MARK, &stash, &gv, 0); @@ -655,28 +807,28 @@ PP(pp_sort) SV *tmpstr = sv_newmortal(); gv_efullname3(tmpstr, gv, Nullch); if (cv && CvXSUB(cv)) - DIE("Xsub \"%s\" called in sort", SvPVX(tmpstr)); - DIE("Undefined sort subroutine \"%s\" called", + DIE(aTHX_ "Xsub \"%s\" called in sort", SvPVX(tmpstr)); + DIE(aTHX_ "Undefined sort subroutine \"%s\" called", SvPVX(tmpstr)); } if (cv) { if (CvXSUB(cv)) - DIE("Xsub called in sort"); - DIE("Undefined subroutine in sort"); + DIE(aTHX_ "Xsub called in sort"); + DIE(aTHX_ "Undefined subroutine in sort"); } - DIE("Not a CODE reference in sort"); + DIE(aTHX_ "Not a CODE reference in sort"); } - sortcop = CvSTART(cv); + PL_sortcop = CvSTART(cv); SAVESPTR(CvROOT(cv)->op_ppaddr); - CvROOT(cv)->op_ppaddr = ppaddr[OP_NULL]; + CvROOT(cv)->op_ppaddr = PL_ppaddr[OP_NULL]; - SAVESPTR(curpad); - curpad = AvARRAY((AV*)AvARRAY(CvPADLIST(cv))[1]); + SAVESPTR(PL_curpad); + PL_curpad = AvARRAY((AV*)AvARRAY(CvPADLIST(cv))[1]); } } else { - sortcop = Nullop; - stash = curcop->cop_stash; + PL_sortcop = Nullop; + stash = PL_curcop->cop_stash; } up = myorigmark + 1; @@ -684,66 +836,81 @@ PP(pp_sort) /*SUPPRESS 560*/ if (*up = *++MARK) { /* Weed out nulls. */ SvTEMP_off(*up); - if (!sortcop && !SvPOK(*up)) - (void)sv_2pv(*up, &na); + if (!PL_sortcop && !SvPOK(*up)) { + STRLEN n_a; + if (SvAMAGIC(*up)) + overloading = 1; + else + (void)sv_2pv(*up, &n_a); + } up++; } } max = --up - myorigmark; - if (sortcop) { + if (PL_sortcop) { if (max > 1) { - AV *oldstack; - CONTEXT *cx; + PERL_CONTEXT *cx; SV** newsp; bool oldcatch = CATCH_GET; SAVETMPS; SAVEOP(); - oldstack = curstack; - if (!sortstack) { - sortstack = newAV(); - AvREAL_off(sortstack); - av_extend(sortstack, 32); - } CATCH_SET(TRUE); - SWITCHSTACK(curstack, sortstack); - if (sortstash != stash) { - firstgv = gv_fetchpv("a", TRUE, SVt_PV); - secondgv = gv_fetchpv("b", TRUE, SVt_PV); - sortstash = stash; + PUSHSTACKi(PERLSI_SORT); + if (PL_sortstash != stash) { + PL_firstgv = gv_fetchpv("a", TRUE, SVt_PV); + PL_secondgv = gv_fetchpv("b", TRUE, SVt_PV); + PL_sortstash = stash; } - SAVESPTR(GvSV(firstgv)); - SAVESPTR(GvSV(secondgv)); + SAVESPTR(GvSV(PL_firstgv)); + SAVESPTR(GvSV(PL_secondgv)); - PUSHBLOCK(cx, CXt_NULL, stack_base); - if (!(op->op_flags & OPf_SPECIAL)) { + PUSHBLOCK(cx, CXt_NULL, PL_stack_base); + if (!(PL_op->op_flags & OPf_SPECIAL)) { bool hasargs = FALSE; cx->cx_type = CXt_SUB; cx->blk_gimme = G_SCALAR; PUSHSUB(cx); if (!CvDEPTH(cv)) - SvREFCNT_inc(cv); /* in preparation for POPSUB */ + (void)SvREFCNT_inc(cv); /* in preparation for POPSUB */ } - sortcxix = cxstack_ix; - - qsort((char*)(myorigmark+1), max, sizeof(SV*), sortcv); + PL_sortcxix = cxstack_ix; + qsortsv((myorigmark+1), max, sortcv); - POPBLOCK(cx,curpm); - SWITCHSTACK(sortstack, oldstack); + POPBLOCK(cx,PL_curpm); + PL_stack_sp = newsp; + POPSTACK; CATCH_SET(oldcatch); } - LEAVE; } else { if (max > 1) { MEXTEND(SP, 20); /* Can't afford stack realloc on signal. */ - qsort((char*)(ORIGMARK+1), max, sizeof(SV*), - (op->op_private & OPpLOCALE) ? sortcmp_locale : sortcmp); + qsortsv(ORIGMARK+1, max, + (PL_op->op_private & OPpSORT_NUMERIC) + ? ( (PL_op->op_private & OPpSORT_INTEGER) + ? ( overloading ? amagic_i_ncmp : sv_i_ncmp) + : ( overloading ? amagic_ncmp : sv_ncmp)) + : ( (PL_op->op_private & OPpLOCALE) + ? ( overloading + ? amagic_cmp_locale + : sv_cmp_locale_static) + : ( overloading ? amagic_cmp : sv_cmp_static))); + if (PL_op->op_private & OPpSORT_REVERSE) { + SV **p = ORIGMARK+1; + SV **q = ORIGMARK+max; + while (p < q) { + SV *tmp = *p; + *p++ = *q; + *q-- = tmp; + } + } } } - stack_sp = ORIGMARK + max; + LEAVE; + PL_stack_sp = ORIGMARK + max; return nextop; } @@ -752,33 +919,37 @@ PP(pp_sort) PP(pp_range) { if (GIMME == G_ARRAY) - return cCONDOP->op_true; - return SvTRUEx(PAD_SV(op->op_targ)) ? cCONDOP->op_false : cCONDOP->op_true; + return NORMAL; + if (SvTRUEx(PAD_SV(PL_op->op_targ))) + return cLOGOP->op_other; + else + return NORMAL; } PP(pp_flip) { - dSP; + djSP; if (GIMME == G_ARRAY) { - RETURNOP(((CONDOP*)cUNOP->op_first)->op_false); + RETURNOP(((LOGOP*)cUNOP->op_first)->op_other); } else { dTOPss; - SV *targ = PAD_SV(op->op_targ); + SV *targ = PAD_SV(PL_op->op_targ); - if ((op->op_private & OPpFLIP_LINENUM) - ? last_in_gv && SvIV(sv) == IoLINES(GvIOp(last_in_gv)) + if ((PL_op->op_private & OPpFLIP_LINENUM) + ? (PL_last_in_gv && SvIV(sv) == (IV)IoLINES(GvIOp(PL_last_in_gv))) : SvTRUE(sv) ) { sv_setiv(PAD_SV(cUNOP->op_first->op_targ), 1); - if (op->op_flags & OPf_SPECIAL) { + if (PL_op->op_flags & OPf_SPECIAL) { sv_setiv(targ, 1); + SETs(targ); RETURN; } else { sv_setiv(targ, 0); - sp--; - RETURNOP(((CONDOP*)cUNOP->op_first)->op_false); + SP--; + RETURNOP(((LOGOP*)cUNOP->op_first)->op_other); } } sv_setpv(TARG, ""); @@ -789,50 +960,60 @@ PP(pp_flip) PP(pp_flop) { - dSP; + djSP; if (GIMME == G_ARRAY) { dPOPPOPssrl; - register I32 i; + register I32 i, j; register SV *sv; I32 max; + if (SvGMAGICAL(left)) + mg_get(left); + if (SvGMAGICAL(right)) + mg_get(right); + if (SvNIOKp(left) || !SvPOKp(left) || (looks_like_number(left) && *SvPVX(left) != '0') ) { + if (SvNV(left) < IV_MIN || SvNV(right) > IV_MAX) + Perl_croak(aTHX_ "Range iterator outside integer range"); i = SvIV(left); max = SvIV(right); if (max >= i) { - EXTEND_MORTAL(max - i + 1); - EXTEND(SP, max - i + 1); + j = max - i + 1; + EXTEND_MORTAL(j); + EXTEND(SP, j); } - while (i <= max) { + else + j = 0; + while (j--) { sv = sv_2mortal(newSViv(i++)); PUSHs(sv); } } else { SV *final = sv_mortalcopy(right); - STRLEN len; + STRLEN len, n_a; char *tmps = SvPV(final, len); sv = sv_mortalcopy(left); - while (!SvNIOKp(sv) && SvCUR(sv) <= len && - strNE(SvPVX(sv),tmps) ) { + SvPV_force(sv,n_a); + 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 { dTOPss; 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)) + if ((PL_op->op_private & OPpFLIP_LINENUM) + ? (PL_last_in_gv && SvIV(sv) == (IV)IoLINES(GvIOp(PL_last_in_gv))) : SvTRUE(sv) ) { sv_setiv(PAD_SV(((UNOP*)cUNOP->op_first)->op_first->op_targ), 0); sv_catpv(targ, "E0"); @@ -845,41 +1026,44 @@ PP(pp_flop) /* Control. */ -static I32 -dopoptolabel(label) -char *label; +STATIC I32 +S_dopoptolabel(pTHX_ char *label) { dTHR; register I32 i; - register CONTEXT *cx; + register PERL_CONTEXT *cx; for (i = cxstack_ix; i >= 0; i--) { cx = &cxstack[i]; - switch (cx->cx_type) { + switch (CxTYPE(cx)) { case CXt_SUBST: - if (dowarn) - warn("Exiting substitution via %s", op_name[op->op_type]); + if (ckWARN(WARN_UNSAFE)) + Perl_warner(aTHX_ WARN_UNSAFE, "Exiting substitution via %s", + PL_op_name[PL_op->op_type]); break; case CXt_SUB: - if (dowarn) - warn("Exiting subroutine via %s", op_name[op->op_type]); + if (ckWARN(WARN_UNSAFE)) + Perl_warner(aTHX_ WARN_UNSAFE, "Exiting subroutine via %s", + PL_op_name[PL_op->op_type]); break; case CXt_EVAL: - if (dowarn) - warn("Exiting eval via %s", op_name[op->op_type]); + if (ckWARN(WARN_UNSAFE)) + Perl_warner(aTHX_ WARN_UNSAFE, "Exiting eval via %s", + PL_op_name[PL_op->op_type]); break; case CXt_NULL: - if (dowarn) - warn("Exiting pseudo-block via %s", op_name[op->op_type]); + if (ckWARN(WARN_UNSAFE)) + Perl_warner(aTHX_ WARN_UNSAFE, "Exiting pseudo-block via %s", + PL_op_name[PL_op->op_type]); return -1; case CXt_LOOP: if (!cx->blk_loop.label || strNE(label, cx->blk_loop.label) ) { - DEBUG_l(deb("(Skipping label #%ld %s)\n", + DEBUG_l(Perl_deb(aTHX_ "(Skipping label #%ld %s)\n", (long)i, cx->blk_loop.label)); continue; } - DEBUG_l( deb("(Found label #%ld %s)\n", (long)i, label)); + DEBUG_l( Perl_deb(aTHX_ "(Found label #%ld %s)\n", (long)i, label)); return i; } } @@ -887,14 +1071,14 @@ char *label; } I32 -dowantarray() +Perl_dowantarray(pTHX) { I32 gimme = block_gimme(); return (gimme == G_VOID) ? G_SCALAR : gimme; } I32 -block_gimme() +Perl_block_gimme(pTHX) { dTHR; I32 cxix; @@ -911,79 +1095,89 @@ block_gimme() case G_ARRAY: return G_ARRAY; default: - croak("panic: bad gimme: %d\n", cxstack[cxix].blk_gimme); + Perl_croak(aTHX_ "panic: bad gimme: %d\n", cxstack[cxix].blk_gimme); + /* NOTREACHED */ + return 0; } } -static I32 -dopoptosub(startingblock) -I32 startingblock; +STATIC I32 +S_dopoptosub(pTHX_ I32 startingblock) +{ + dTHR; + return dopoptosub_at(cxstack, startingblock); +} + +STATIC I32 +S_dopoptosub_at(pTHX_ PERL_CONTEXT *cxstk, I32 startingblock) { dTHR; I32 i; - register CONTEXT *cx; + register PERL_CONTEXT *cx; for (i = startingblock; i >= 0; i--) { - cx = &cxstack[i]; - switch (cx->cx_type) { + cx = &cxstk[i]; + switch (CxTYPE(cx)) { default: continue; case CXt_EVAL: case CXt_SUB: - DEBUG_l( deb("(Found sub #%ld)\n", (long)i)); + DEBUG_l( Perl_deb(aTHX_ "(Found sub #%ld)\n", (long)i)); return i; } } return i; } -static I32 -dopoptoeval(startingblock) -I32 startingblock; +STATIC I32 +S_dopoptoeval(pTHX_ I32 startingblock) { dTHR; I32 i; - register CONTEXT *cx; + register PERL_CONTEXT *cx; for (i = startingblock; i >= 0; i--) { cx = &cxstack[i]; - switch (cx->cx_type) { + switch (CxTYPE(cx)) { default: continue; case CXt_EVAL: - DEBUG_l( deb("(Found eval #%ld)\n", (long)i)); + DEBUG_l( Perl_deb(aTHX_ "(Found eval #%ld)\n", (long)i)); return i; } } return i; } -static I32 -dopoptoloop(startingblock) -I32 startingblock; +STATIC I32 +S_dopoptoloop(pTHX_ I32 startingblock) { dTHR; I32 i; - register CONTEXT *cx; + register PERL_CONTEXT *cx; for (i = startingblock; i >= 0; i--) { cx = &cxstack[i]; - switch (cx->cx_type) { + switch (CxTYPE(cx)) { case CXt_SUBST: - if (dowarn) - warn("Exiting substitution via %s", op_name[op->op_type]); + if (ckWARN(WARN_UNSAFE)) + Perl_warner(aTHX_ WARN_UNSAFE, "Exiting substitution via %s", + PL_op_name[PL_op->op_type]); break; case CXt_SUB: - if (dowarn) - warn("Exiting subroutine via %s", op_name[op->op_type]); + if (ckWARN(WARN_UNSAFE)) + Perl_warner(aTHX_ WARN_UNSAFE, "Exiting subroutine via %s", + PL_op_name[PL_op->op_type]); break; case CXt_EVAL: - if (dowarn) - warn("Exiting eval via %s", op_name[op->op_type]); + if (ckWARN(WARN_UNSAFE)) + Perl_warner(aTHX_ WARN_UNSAFE, "Exiting eval via %s", + PL_op_name[PL_op->op_type]); break; case CXt_NULL: - if (dowarn) - warn("Exiting pseudo-block via %s", op_name[op->op_type]); + if (ckWARN(WARN_UNSAFE)) + Perl_warner(aTHX_ WARN_UNSAFE, "Exiting pseudo-block via %s", + PL_op_name[PL_op->op_type]); return -1; case CXt_LOOP: - DEBUG_l( deb("(Found loop #%ld)\n", (long)i)); + DEBUG_l( Perl_deb(aTHX_ "(Found loop #%ld)\n", (long)i)); return i; } } @@ -991,20 +1185,19 @@ I32 startingblock; } void -dounwind(cxix) -I32 cxix; +Perl_dounwind(pTHX_ I32 cxix) { dTHR; - register CONTEXT *cx; + register PERL_CONTEXT *cx; SV **newsp; I32 optype; while (cxstack_ix > cxix) { cx = &cxstack[cxstack_ix]; DEBUG_l(PerlIO_printf(Perl_debug_log, "Unwinding block %ld, type %s\n", - (long) cxstack_ix+1, block_type[cx->cx_type])); + (long) cxstack_ix, PL_block_type[CxTYPE(cx)])); /* Note: we don't need to restore the base context info till the end. */ - switch (cx->cx_type) { + switch (CxTYPE(cx)) { case CXt_SUBST: POPSUBST(cx); continue; /* not break */ @@ -1024,66 +1217,128 @@ I32 cxix; } } -OP * -die_where(message) -char *message; +/* + * Closures mentioned at top level of eval cannot be referenced + * again, and their presence indirectly causes a memory leak. + * (Note that the fact that compcv and friends are still set here + * is, AFAIK, an accident.) --Chip + * + * XXX need to get comppad et al from eval's cv rather than + * relying on the incidental global values. + */ +STATIC void +S_free_closures(pTHX) { dTHR; - if (in_eval) { + SV **svp = AvARRAY(PL_comppad_name); + I32 ix; + for (ix = AvFILLp(PL_comppad_name); ix >= 0; ix--) { + SV *sv = svp[ix]; + if (sv && sv != &PL_sv_undef && *SvPVX(sv) == '&') { + SvREFCNT_dec(sv); + svp[ix] = &PL_sv_undef; + + sv = PL_curpad[ix]; + if (CvCLONE(sv)) { + SvREFCNT_dec(CvOUTSIDE(sv)); + CvOUTSIDE(sv) = Nullcv; + } + else { + SvREFCNT_dec(sv); + sv = NEWSV(0,0); + SvPADTMP_on(sv); + PL_curpad[ix] = sv; + } + } + } +} + +OP * +Perl_die_where(pTHX_ char *message, STRLEN msglen) +{ + dSP; + STRLEN n_a; + if (PL_in_eval) { I32 cxix; - register CONTEXT *cx; + register PERL_CONTEXT *cx; I32 gimme; SV **newsp; - if (in_eval & 4) { - SV **svp; - STRLEN klen = strlen(message); - - svp = hv_fetch(GvHV(errgv), message, klen, TRUE); - if (svp) { - if (!SvIOK(*svp)) { - static char prefix[] = "\t(in cleanup) "; - sv_upgrade(*svp, SVt_IV); - (void)SvIOK_only(*svp); - SvGROW(GvSV(errgv), SvCUR(GvSV(errgv))+sizeof(prefix)+klen); - sv_catpvn(GvSV(errgv), prefix, sizeof(prefix)-1); - sv_catpvn(GvSV(errgv), message, klen); + if (message) { + if (PL_in_eval & EVAL_KEEPERR) { + SV **svp; + + svp = hv_fetch(ERRHV, message, msglen, 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)+msglen); + sv_catpvn(err, prefix, sizeof(prefix)-1); + sv_catpvn(err, message, msglen); + if (ckWARN(WARN_UNSAFE)) { + STRLEN start = SvCUR(err)-msglen-sizeof(prefix)+1; + Perl_warner(aTHX_ WARN_UNSAFE, SvPVX(err)+start); + } + } + sv_inc(*svp); } - sv_inc(*svp); } + else + sv_setpvn(ERRSV, message, msglen); } else - sv_setpv(GvSV(errgv), message); - - cxix = dopoptoeval(cxstack_ix); + message = SvPVx(ERRSV, msglen); + + while ((cxix = dopoptoeval(cxstack_ix)) < 0 && PL_curstackinfo->si_prev) { + dounwind(-1); + POPSTACK; + } + if (cxix >= 0) { I32 optype; if (cxix < cxstack_ix) dounwind(cxix); - POPBLOCK(cx,curpm); - if (cx->cx_type != CXt_EVAL) { - PerlIO_printf(PerlIO_stderr(), "panic: die %s", message); + POPBLOCK(cx,PL_curpm); + if (CxTYPE(cx) != CXt_EVAL) { + PerlIO_write(PerlIO_stderr(), "panic: die ", 11); + PerlIO_write(PerlIO_stderr(), message, msglen); my_exit(1); } POPEVAL(cx); if (gimme == G_SCALAR) - *++newsp = &sv_undef; - stack_sp = newsp; + *++newsp = &PL_sv_undef; + PL_stack_sp = newsp; LEAVE; if (optype == OP_REQUIRE) { - char* msg = SvPVx(GvSV(errgv), na); - DIE("%s", *msg ? msg : "Compilation failed in require"); + char* msg = SvPVx(ERRSV, n_a); + DIE(aTHX_ "%s", *msg ? msg : "Compilation failed in require"); } return pop_return(); } } - PerlIO_printf(PerlIO_stderr(), "%s",message); - PerlIO_flush(PerlIO_stderr()); + if (!message) + message = SvPVx(ERRSV, msglen); + { +#ifdef USE_SFIO + /* SFIO can really mess with your errno */ + int e = errno; +#endif + PerlIO_write(PerlIO_stderr(), message, msglen); + (void)PerlIO_flush(PerlIO_stderr()); +#ifdef USE_SFIO + errno = e; +#endif + } my_failure_exit(); /* NOTREACHED */ return 0; @@ -1091,7 +1346,7 @@ char *message; PP(pp_xor) { - dSP; dPOPTOPssrl; + djSP; dPOPTOPssrl; if (SvTRUE(left) != SvTRUE(right)) RETSETYES; else @@ -1100,7 +1355,7 @@ PP(pp_xor) PP(pp_andassign) { - dSP; + djSP; if (!SvTRUE(TOPs)) RETURN; else @@ -1109,180 +1364,149 @@ PP(pp_andassign) PP(pp_orassign) { - dSP; + djSP; if (SvTRUE(TOPs)) RETURN; else RETURNOP(cLOGOP->op_other); } -#ifdef DEPRECATED -PP(pp_entersubr) -{ - dSP; - SV** mark = (stack_base + *markstack_ptr + 1); - SV* cv = *mark; - while (mark < sp) { /* emulate old interface */ - *mark = mark[1]; - mark++; - } - *sp = cv; - return pp_entersub(ARGS); -} -#endif - PP(pp_caller) { - dSP; + djSP; register I32 cxix = dopoptosub(cxstack_ix); - register CONTEXT *cx; + register PERL_CONTEXT *cx; + register PERL_CONTEXT *ccstack = cxstack; + PERL_SI *top_si = PL_curstackinfo; I32 dbcxix; I32 gimme; + HV *hv; SV *sv; I32 count = 0; if (MAXARG) count = POPi; - EXTEND(SP, 6); + EXTEND(SP, 7); 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)) + if (PL_DBsub && cxix >= 0 && + ccstack[cxix].blk_sub.cv == GvCV(PL_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 (CxTYPE(cx) == 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 (PL_DBsub && dbcxix >= 0 && ccstack[dbcxix].blk_sub.cv == GvCV(PL_DBsub)) + cx = &ccstack[dbcxix]; } if (GIMME != G_ARRAY) { - dTARGET; - - sv_setpv(TARG, HvNAME(cx->blk_oldcop->cop_stash)); - PUSHs(TARG); + hv = cx->blk_oldcop->cop_stash; + if (!hv) + PUSHs(&PL_sv_undef); + else { + dTARGET; + sv_setpv(TARG, HvNAME(hv)); + PUSHs(TARG); + } RETURN; } - PUSHs(sv_2mortal(newSVpv(HvNAME(cx->blk_oldcop->cop_stash), 0))); - PUSHs(sv_2mortal(newSVpv(SvPVX(GvSV(cx->blk_oldcop->cop_filegv)), 0))); + hv = cx->blk_oldcop->cop_stash; + if (!hv) + PUSHs(&PL_sv_undef); + else + PUSHs(sv_2mortal(newSVpv(HvNAME(hv), 0))); + PUSHs(sv_2mortal(newSVpvn(SvPVX(GvSV(cx->blk_oldcop->cop_filegv)), + SvCUR(GvSV(cx->blk_oldcop->cop_filegv))))); PUSHs(sv_2mortal(newSViv((I32)cx->blk_oldcop->cop_line))); if (!MAXARG) RETURN; - if (cx->cx_type == CXt_SUB) { /* So is cxstack[dbcxix]. */ + if (CxTYPE(cx) == 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))); } else { - PUSHs(sv_2mortal(newSVpv("(eval)",0))); + PUSHs(sv_2mortal(newSVpvn("(eval)",6))); PUSHs(sv_2mortal(newSViv(0))); } gimme = (I32)cx->blk_gimme; if (gimme == G_VOID) - PUSHs(&sv_undef); + PUSHs(&PL_sv_undef); else PUSHs(sv_2mortal(newSViv(gimme & G_ARRAY))); - if (cx->cx_type == CXt_EVAL) { + if (CxTYPE(cx) == CXt_EVAL) { if (cx->blk_eval.old_op_type == OP_ENTEREVAL) { PUSHs(cx->blk_eval.cur_text); - PUSHs(&sv_no); + PUSHs(&PL_sv_no); } else if (cx->blk_eval.old_name) { /* Try blocks have old_name == 0. */ /* Require, put the name. */ PUSHs(sv_2mortal(newSVpv(cx->blk_eval.old_name, 0))); - PUSHs(&sv_yes); + PUSHs(&PL_sv_yes); } } - else if (cx->cx_type == CXt_SUB && - cx->blk_sub.hasargs && - curcop->cop_stash == debstash) + else { + PUSHs(&PL_sv_undef); + PUSHs(&PL_sv_undef); + } + if (CxTYPE(cx) == CXt_SUB && cx->blk_sub.hasargs + && PL_curcop->cop_stash == PL_debstash) { AV *ary = cx->blk_sub.argarray; int off = AvARRAY(ary) - AvALLOC(ary); - if (!dbargs) { + if (!PL_dbargs) { GV* tmpgv; - dbargs = GvAV(gv_AVadd(tmpgv = gv_fetchpv("DB::args", TRUE, + PL_dbargs = GvAV(gv_AVadd(tmpgv = gv_fetchpv("DB::args", TRUE, SVt_PVAV))); GvMULTI_on(tmpgv); - AvREAL_off(dbargs); /* XXX Should be REIFY */ + AvREAL_off(PL_dbargs); /* XXX Should be REIFY */ } - if (AvMAX(dbargs) < AvFILL(ary) + off) - av_extend(dbargs, AvFILL(ary) + off); - Copy(AvALLOC(ary), AvARRAY(dbargs), AvFILL(ary) + 1 + off, SV*); - AvFILL(dbargs) = AvFILL(ary) + off; + if (AvMAX(PL_dbargs) < AvFILLp(ary) + off) + av_extend(PL_dbargs, AvFILLp(ary) + off); + Copy(AvALLOC(ary), AvARRAY(PL_dbargs), AvFILLp(ary) + 1 + off, SV*); + AvFILLp(PL_dbargs) = AvFILLp(ary) + off; } + /* XXX only hints propagated via op_private are currently + * visible (others are not easily accessible, since they + * use the global PL_hints) */ + PUSHs(sv_2mortal(newSViv((I32)cx->blk_oldcop->op_private & + HINT_PRIVATE_MASK))); RETURN; } -static int -sortcv(a, b) -const void *a; -const void *b; -{ - dTHR; - SV * const *str1 = (SV * const *)a; - SV * const *str2 = (SV * const *)b; - I32 oldsaveix = savestack_ix; - I32 oldscopeix = scopestack_ix; - I32 result; - GvSV(firstgv) = *str1; - GvSV(secondgv) = *str2; - stack_sp = stack_base; - op = sortcop; - runops(); - if (stack_sp != stack_base + 1) - croak("Sort subroutine didn't return single value"); - if (!SvNIOKp(*stack_sp)) - croak("Sort subroutine didn't return a numeric value"); - result = SvIV(*stack_sp); - while (scopestack_ix > oldscopeix) { - LEAVE; - } - leave_scope(oldsaveix); - return result; -} - -static int -sortcmp(a, b) -const void *a; -const void *b; -{ - return sv_cmp(*(SV * const *)a, *(SV * const *)b); -} - -static int -sortcmp_locale(a, b) -const void *a; -const void *b; -{ - return sv_cmp_locale(*(SV * const *)a, *(SV * const *)b); -} - PP(pp_reset) { - dSP; + djSP; char *tmps; + STRLEN n_a; if (MAXARG < 1) tmps = ""; else - tmps = POPp; - sv_reset(tmps, curcop->cop_stash); - PUSHs(&sv_yes); + tmps = POPpx; + sv_reset(tmps, PL_curcop->cop_stash); + PUSHs(&PL_sv_yes); RETURN; } @@ -1293,44 +1517,44 @@ PP(pp_lineseq) PP(pp_dbstate) { - curcop = (COP*)op; + PL_curcop = (COP*)PL_op; TAINT_NOT; /* Each statement is presumed innocent */ - stack_sp = stack_base + cxstack[cxstack_ix].blk_oldsp; + PL_stack_sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp; FREETMPS; - if (op->op_private || SvIV(DBsingle) || SvIV(DBsignal) || SvIV(DBtrace)) + if (PL_op->op_private || SvIV(PL_DBsingle) || SvIV(PL_DBsignal) || SvIV(PL_DBtrace)) { - SV **sp; + djSP; register CV *cv; - register CONTEXT *cx; + register PERL_CONTEXT *cx; I32 gimme = G_ARRAY; I32 hasargs; GV *gv; - gv = DBgv; + gv = PL_DBgv; cv = GvCV(gv); if (!cv) - DIE("No DB::DB routine defined"); + DIE(aTHX_ "No DB::DB routine defined"); - if (CvDEPTH(cv) >= 1 && !(debug & (1<<30))) /* don't do recursive DB::DB call */ + if (CvDEPTH(cv) >= 1 && !(PL_debug & (1<<30))) /* don't do recursive DB::DB call */ return NORMAL; ENTER; SAVETMPS; - SAVEI32(debug); + SAVEI32(PL_debug); SAVESTACK_POS(); - debug = 0; + PL_debug = 0; hasargs = 0; - sp = stack_sp; + SPAGAIN; - push_return(op->op_next); - PUSHBLOCK(cx, CXt_SUB, sp); + push_return(PL_op->op_next); + PUSHBLOCK(cx, CXt_SUB, SP); PUSHSUB(cx); CvDEPTH(cv)++; (void)SvREFCNT_inc(cv); - SAVESPTR(curpad); - curpad = AvARRAY((AV*)*av_fetch(CvPADLIST(cv),1,FALSE)); + SAVESPTR(PL_curpad); + PL_curpad = AvARRAY((AV*)*av_fetch(CvPADLIST(cv),1,FALSE)); RETURNOP(CvSTART(cv)); } else @@ -1344,31 +1568,57 @@ PP(pp_scope) PP(pp_enteriter) { - dSP; dMARK; - register CONTEXT *cx; + djSP; dMARK; + register PERL_CONTEXT *cx; I32 gimme = GIMME_V; SV **svp; ENTER; SAVETMPS; - if (op->op_targ) - svp = &curpad[op->op_targ]; /* "my" variable */ +#ifdef USE_THREADS + if (PL_op->op_flags & OPf_SPECIAL) { + dTHR; + svp = &THREADSV(PL_op->op_targ); /* per-thread variable */ + SAVEGENERICSV(*svp); + *svp = NEWSV(0,0); + } else +#endif /* USE_THREADS */ + if (PL_op->op_targ) { + svp = &PL_curpad[PL_op->op_targ]; /* "my" variable */ + SAVESPTR(*svp); + } + else { svp = &GvSV((GV*)POPs); /* symbol table variable */ - - SAVESPTR(*svp); + SAVEGENERICSV(*svp); + *svp = NEWSV(0,0); + } ENTER; PUSHBLOCK(cx, CXt_LOOP, SP); PUSHLOOP(cx, svp, MARK); - if (op->op_flags & OPf_STACKED) + if (PL_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) + Perl_croak(aTHX_ "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; - AvFILL(curstack) = sp - stack_base; - cx->blk_loop.iterix = MARK - stack_base; + cx->blk_loop.iterary = PL_curstack; + AvFILLp(PL_curstack) = SP - PL_stack_base; + cx->blk_loop.iterix = MARK - PL_stack_base; } RETURN; @@ -1376,8 +1626,8 @@ PP(pp_enteriter) PP(pp_enterloop) { - dSP; - register CONTEXT *cx; + djSP; + register PERL_CONTEXT *cx; I32 gimme = GIMME_V; ENTER; @@ -1392,8 +1642,8 @@ PP(pp_enterloop) PP(pp_leaveloop) { - dSP; - register CONTEXT *cx; + djSP; + register PERL_CONTEXT *cx; struct block_loop cxloop; I32 gimme; SV **newsp; @@ -1411,7 +1661,7 @@ PP(pp_leaveloop) if (mark < SP) *++newsp = sv_mortalcopy(*SP); else - *++newsp = &sv_undef; + *++newsp = &PL_sv_undef; } else { while (mark < SP) { @@ -1423,7 +1673,7 @@ PP(pp_leaveloop) PUTBACK; POPLOOP2(); /* Stack values are safe: release loop vars ... */ - curpm = newpm; /* ... and pop $1 et al */ + PL_curpm = newpm; /* ... and pop $1 et al */ LEAVE; LEAVE; @@ -1433,9 +1683,9 @@ PP(pp_leaveloop) PP(pp_return) { - dSP; dMARK; + djSP; dMARK; I32 cxix; - register CONTEXT *cx; + register PERL_CONTEXT *cx; struct block_sub cxsub; bool popsub2 = FALSE; I32 gimme; @@ -1443,50 +1693,65 @@ PP(pp_return) PMOP *newpm; I32 optype = 0; - if (curstack == sortstack) { - if (cxstack_ix == sortcxix || dopoptosub(cxstack_ix) <= sortcxix) { - if (cxstack_ix > sortcxix) - dounwind(sortcxix); - AvARRAY(curstack)[1] = *SP; - stack_sp = stack_base + 1; + if (PL_curstackinfo->si_type == PERLSI_SORT) { + if (cxstack_ix == PL_sortcxix || dopoptosub(cxstack_ix) <= PL_sortcxix) { + if (cxstack_ix > PL_sortcxix) + dounwind(PL_sortcxix); + AvARRAY(PL_curstack)[1] = *SP; + PL_stack_sp = PL_stack_base + 1; return 0; } } cxix = dopoptosub(cxstack_ix); if (cxix < 0) - DIE("Can't return outside a subroutine"); + DIE(aTHX_ "Can't return outside a subroutine"); if (cxix < cxstack_ix) dounwind(cxix); POPBLOCK(cx,newpm); - switch (cx->cx_type) { + switch (CxTYPE(cx)) { case CXt_SUB: POPSUB1(cx); /* Delay POPSUB2 until stack values are safe */ popsub2 = TRUE; break; case CXt_EVAL: POPEVAL(cx); + if (AvFILLp(PL_comppad_name) >= 0) + free_closures(); + lex_end(); if (optype == OP_REQUIRE && (MARK == SP || (gimme == G_SCALAR && !SvTRUE(*SP))) ) { /* Unassume the success we assumed earlier. */ char *name = cx->blk_eval.old_name; - (void)hv_delete(GvHVn(incgv), name, strlen(name), G_DISCARD); - DIE("%s did not return a true value", name); + (void)hv_delete(GvHVn(PL_incgv), name, strlen(name), G_DISCARD); + DIE(aTHX_ "%s did not return a true value", name); } break; default: - DIE("panic: return"); + DIE(aTHX_ "panic: return"); } TAINT_NOT; if (gimme == G_SCALAR) { - if (MARK < SP) - *++newsp = (popsub2 && SvTEMP(*SP)) - ? *SP : sv_mortalcopy(*SP); - else - *++newsp = &sv_undef; + 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 = &PL_sv_undef; } else if (gimme == G_ARRAY) { while (++MARK <= SP) { @@ -1495,13 +1760,13 @@ PP(pp_return) TAINT_NOT; /* Each item is independent */ } } - stack_sp = newsp; + PL_stack_sp = newsp; /* Stack values are safe: */ if (popsub2) { POPSUB2(); /* release CV and @_ ... */ } - curpm = newpm; /* ... and pop $1 et al */ + PL_curpm = newpm; /* ... and pop $1 et al */ LEAVE; return pop_return(); @@ -1509,9 +1774,9 @@ PP(pp_return) PP(pp_last) { - dSP; + djSP; I32 cxix; - register CONTEXT *cx; + register PERL_CONTEXT *cx; struct block_loop cxloop; struct block_sub cxsub; I32 pop2 = 0; @@ -1520,23 +1785,23 @@ PP(pp_last) OP *nextop; SV **newsp; PMOP *newpm; - SV **mark = stack_base + cxstack[cxstack_ix].blk_oldsp; + SV **mark = PL_stack_base + cxstack[cxstack_ix].blk_oldsp; - if (op->op_flags & OPf_SPECIAL) { + if (PL_op->op_flags & OPf_SPECIAL) { cxix = dopoptoloop(cxstack_ix); if (cxix < 0) - DIE("Can't \"last\" outside a block"); + DIE(aTHX_ "Can't \"last\" outside a block"); } else { cxix = dopoptolabel(cPVOP->op_pv); if (cxix < 0) - DIE("Label not found for \"last %s\"", cPVOP->op_pv); + DIE(aTHX_ "Label not found for \"last %s\"", cPVOP->op_pv); } if (cxix < cxstack_ix) dounwind(cxix); POPBLOCK(cx,newpm); - switch (cx->cx_type) { + switch (CxTYPE(cx)) { case CXt_LOOP: POPLOOP1(cx); /* Delay POPLOOP2 until stack values are safe */ pop2 = CXt_LOOP; @@ -1552,7 +1817,7 @@ PP(pp_last) nextop = pop_return(); break; default: - DIE("panic: last"); + DIE(aTHX_ "panic: last"); } TAINT_NOT; @@ -1561,7 +1826,7 @@ PP(pp_last) *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*SP)) ? *SP : sv_mortalcopy(*SP); else - *++newsp = &sv_undef; + *++newsp = &PL_sv_undef; } else if (gimme == G_ARRAY) { while (++MARK <= SP) { @@ -1583,7 +1848,7 @@ PP(pp_last) POPSUB2(); /* release CV and @_ ... */ break; } - curpm = newpm; /* ... and pop $1 et al */ + PL_curpm = newpm; /* ... and pop $1 et al */ LEAVE; return nextop; @@ -1592,24 +1857,24 @@ PP(pp_last) PP(pp_next) { I32 cxix; - register CONTEXT *cx; + register PERL_CONTEXT *cx; I32 oldsave; - if (op->op_flags & OPf_SPECIAL) { + if (PL_op->op_flags & OPf_SPECIAL) { cxix = dopoptoloop(cxstack_ix); if (cxix < 0) - DIE("Can't \"next\" outside a block"); + DIE(aTHX_ "Can't \"next\" outside a block"); } else { cxix = dopoptolabel(cPVOP->op_pv); if (cxix < 0) - DIE("Label not found for \"next %s\"", cPVOP->op_pv); + DIE(aTHX_ "Label not found for \"next %s\"", cPVOP->op_pv); } if (cxix < cxstack_ix) dounwind(cxix); TOPBLOCK(cx); - oldsave = scopestack[scopestack_ix - 1]; + oldsave = PL_scopestack[PL_scopestack_ix - 1]; LEAVE_SCOPE(oldsave); return cx->blk_loop.next_op; } @@ -1617,43 +1882,37 @@ PP(pp_next) PP(pp_redo) { I32 cxix; - register CONTEXT *cx; + register PERL_CONTEXT *cx; I32 oldsave; - if (op->op_flags & OPf_SPECIAL) { + if (PL_op->op_flags & OPf_SPECIAL) { cxix = dopoptoloop(cxstack_ix); if (cxix < 0) - DIE("Can't \"redo\" outside a block"); + DIE(aTHX_ "Can't \"redo\" outside a block"); } else { cxix = dopoptolabel(cPVOP->op_pv); if (cxix < 0) - DIE("Label not found for \"redo %s\"", cPVOP->op_pv); + DIE(aTHX_ "Label not found for \"redo %s\"", cPVOP->op_pv); } if (cxix < cxstack_ix) dounwind(cxix); TOPBLOCK(cx); - oldsave = scopestack[scopestack_ix - 1]; + oldsave = PL_scopestack[PL_scopestack_ix - 1]; LEAVE_SCOPE(oldsave); return cx->blk_loop.redo_op; } -static OP* lastgotoprobe; - -static OP * -dofindlabel(o,label,opstack,oplimit) -OP *o; -char *label; -OP **opstack; -OP **oplimit; +STATIC OP * +S_dofindlabel(pTHX_ OP *o, char *label, OP **opstack, OP **oplimit) { OP *kid; OP **ops = opstack; static char too_deep[] = "Target of goto is too deeply nested"; if (ops >= oplimit) - croak(too_deep); + Perl_croak(aTHX_ too_deep); if (o->op_type == OP_LEAVE || o->op_type == OP_SCOPE || o->op_type == OP_LEAVELOOP || @@ -1661,10 +1920,11 @@ OP **oplimit; { *ops++ = cUNOPo->op_first; if (ops >= oplimit) - croak(too_deep); + Perl_croak(aTHX_ too_deep); } *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) && @@ -1672,7 +1932,7 @@ OP **oplimit; return kid; } for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) { - if (kid == lastgotoprobe) + if (kid == PL_lastgotoprobe) continue; if ((kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) && (ops == opstack || @@ -1689,89 +1949,135 @@ OP **oplimit; PP(pp_dump) { - return pp_goto(ARGS); + return pp_goto(); /*NOTREACHED*/ } PP(pp_goto) { - dSP; + djSP; OP *retop = 0; I32 ix; - register CONTEXT *cx; + register PERL_CONTEXT *cx; #define GOTO_DEPTH 64 OP *enterops[GOTO_DEPTH]; char *label; - int do_dump = (op->op_type == OP_DUMP); + int do_dump = (PL_op->op_type == OP_DUMP); + static char must_have_label[] = "goto must have label"; label = 0; - if (op->op_flags & OPf_STACKED) { + if (PL_op->op_flags & OPf_STACKED) { SV *sv = POPs; + STRLEN n_a; /* This egregious kludge implements goto &subroutine */ if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVCV) { I32 cxix; - register CONTEXT *cx; + register PERL_CONTEXT *cx; CV* cv = (CV*)SvRV(sv); SV** mark; I32 items = 0; I32 oldsave; + int arg_was_real = 0; + retry: if (!CvROOT(cv) && !CvXSUB(cv)) { - if (CvGV(cv)) { - SV *tmpstr = sv_newmortal(); - gv_efullname3(tmpstr, CvGV(cv), Nullch); - DIE("Goto undefined subroutine &%s",SvPVX(tmpstr)); + GV *gv = CvGV(cv); + GV *autogv; + if (gv) { + SV *tmpstr; + /* autoloaded stub? */ + if (cv != GvCV(gv) && (cv = GvCV(gv))) + goto retry; + autogv = gv_autoload4(GvSTASH(gv), GvNAME(gv), + GvNAMELEN(gv), FALSE); + if (autogv && (cv = GvCV(autogv))) + goto retry; + tmpstr = sv_newmortal(); + gv_efullname3(tmpstr, gv, Nullch); + DIE(aTHX_ "Goto undefined subroutine &%s",SvPVX(tmpstr)); } - DIE("Goto undefined subroutine"); + DIE(aTHX_ "Goto undefined subroutine"); } /* First do some returnish stuff. */ cxix = dopoptosub(cxstack_ix); if (cxix < 0) - DIE("Can't goto subroutine outside a subroutine"); + DIE(aTHX_ "Can't goto subroutine outside a subroutine"); if (cxix < cxstack_ix) dounwind(cxix); TOPBLOCK(cx); - mark = stack_sp; - if (cx->blk_sub.hasargs) { /* put @_ back onto stack */ + if (CxTYPE(cx) == CXt_EVAL && cx->blk_eval.old_op_type == OP_ENTEREVAL) + 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 = AvFILL(av) + 1; - stack_sp++; - EXTEND(stack_sp, items); /* @_ could have been extended. */ - Copy(AvARRAY(av), stack_sp, items, SV*); - stack_sp += items; + 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; #ifndef USE_THREADS - SvREFCNT_dec(GvAV(defgv)); - GvAV(defgv) = cx->blk_sub.savearray; + SvREFCNT_dec(GvAV(PL_defgv)); + GvAV(PL_defgv) = cx->blk_sub.savearray; #endif /* USE_THREADS */ - AvREAL_off(av); + if (AvREAL(av)) { + arg_was_real = 1; + AvREAL_off(av); /* so av_clear() won't clobber elts */ + } av_clear(av); } - if (!(CvDEPTH(cx->blk_sub.cv) = cx->blk_sub.olddepth)) + else if (CvXSUB(cv)) { /* put GvAV(defgv) back onto stack */ + AV* av; + int i; +#ifdef USE_THREADS + av = (AV*)PL_curpad[0]; +#else + av = GvAV(PL_defgv); +#endif + 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; + } + if (CxTYPE(cx) == CXt_SUB && + !(CvDEPTH(cx->blk_sub.cv) = cx->blk_sub.olddepth)) SvREFCNT_dec(cx->blk_sub.cv); - oldsave = scopestack[scopestack_ix - 1]; + oldsave = PL_scopestack[PL_scopestack_ix - 1]; LEAVE_SCOPE(oldsave); /* Now do some callish stuff. */ SAVETMPS; if (CvXSUB(cv)) { +#ifdef PERL_XSUB_OLDSTYLE if (CvOLDSTYLE(cv)) { - I32 (*fp3)_((int,int,int)); - while (sp > mark) { - sp[1] = sp[0]; - sp--; + I32 (*fp3)(int,int,int); + while (SP > mark) { + SP[1] = SP[0]; + SP--; } - fp3 = (I32(*)_((int,int,int)))CvXSUB(cv); + fp3 = (I32(*)(int,int,int)))CvXSUB(cv; items = (*fp3)(CvXSUBANY(cv).any_i32, - mark - stack_base + 1, + mark - PL_stack_base + 1, items); - sp = stack_base + items; + SP = PL_stack_base + items; } - else { - stack_sp--; /* There is no cv arg. */ - (void)(*CvXSUB(cv))(cv); + else +#endif /* PERL_XSUB_OLDSTYLE */ + { + SV **newsp; + I32 gimme; + + PL_stack_sp--; /* There is no cv arg. */ + /* Push a mark for the start of arglist */ + PUSHMARK(mark); + (void)(*CvXSUB(cv))(aTHXo_ 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(); @@ -1779,21 +2085,27 @@ PP(pp_goto) else { AV* padlist = CvPADLIST(cv); SV** svp = AvARRAY(padlist); + if (CxTYPE(cx) == CXt_EVAL) { + PL_in_eval = cx->blk_eval.old_in_eval; + PL_eval_root = cx->blk_eval.old_eval_root; + cx->cx_type = CXt_SUB; + cx->blk_sub.hasargs = 0; + } cx->blk_sub.cv = cv; cx->blk_sub.olddepth = CvDEPTH(cv); CvDEPTH(cv)++; if (CvDEPTH(cv) < 2) (void)SvREFCNT_inc(cv); else { /* save temporaries on recursion? */ - if (CvDEPTH(cv) == 100 && dowarn) + if (CvDEPTH(cv) == 100 && ckWARN(WARN_RECURSION)) sub_crush_depth(cv); - if (CvDEPTH(cv) > AvFILL(padlist)) { + if (CvDEPTH(cv) > AvFILLp(padlist)) { AV *newpad = newAV(); SV **oldpad = AvARRAY(svp[CvDEPTH(cv)-1]); - I32 ix = AvFILL((AV*)svp[1]); + I32 ix = AvFILLp((AV*)svp[1]); svp = AvARRAY(svp[0]); for ( ;ix > 0; ix--) { - if (svp[ix] != &sv_undef) { + if (svp[ix] != &PL_sv_undef) { char *name = SvPVX(svp[ix]); if ((SvFLAGS(svp[ix]) & SVf_FAKE) || *name == '&') @@ -1824,36 +2136,36 @@ PP(pp_goto) AvFLAGS(av) = AVf_REIFY; } av_store(padlist, CvDEPTH(cv), (SV*)newpad); - AvFILL(padlist) = CvDEPTH(cv); + AvFILLp(padlist) = CvDEPTH(cv); svp = AvARRAY(padlist); } } #ifdef USE_THREADS if (!cx->blk_sub.hasargs) { - AV* av = (AV*)curpad[0]; + AV* av = (AV*)PL_curpad[0]; - items = AvFILL(av) + 1; + items = AvFILLp(av) + 1; if (items) { /* Mark is at the end of the stack. */ - EXTEND(sp, items); - Copy(AvARRAY(av), sp + 1, items, SV*); - sp += items; + EXTEND(SP, items); + Copy(AvARRAY(av), SP + 1, items, SV*); + SP += items; PUTBACK ; } } #endif /* USE_THREADS */ - SAVESPTR(curpad); - curpad = AvARRAY((AV*)svp[CvDEPTH(cv)]); + SAVESPTR(PL_curpad); + PL_curpad = AvARRAY((AV*)svp[CvDEPTH(cv)]); #ifndef USE_THREADS if (cx->blk_sub.hasargs) #endif /* USE_THREADS */ { - AV* av = (AV*)curpad[0]; + AV* av = (AV*)PL_curpad[0]; SV** ary; #ifndef USE_THREADS - cx->blk_sub.savearray = GvAV(defgv); - GvAV(defgv) = (AV*)SvREFCNT_inc(av); + cx->blk_sub.savearray = GvAV(PL_defgv); + GvAV(PL_defgv) = (AV*)SvREFCNT_inc(av); #endif /* USE_THREADS */ cx->blk_sub.argarray = av; ++mark; @@ -1872,32 +2184,51 @@ PP(pp_goto) } } Copy(mark,AvARRAY(av),items,SV*); - AvFILL(av) = items - 1; - + AvFILLp(av) = items - 1; + /* preserve @_ nature */ + if (arg_was_real) { + AvREIFY_off(av); + AvREAL_on(av); + } while (items--) { if (*mark) SvTEMP_off(*mark); mark++; } } - if (perldb && curstash != debstash) { + if (PERLDB_SUB) { /* Checking curstash breaks DProf. */ /* * We do not care about using sv to call CV; * it's for informational purposes only. */ - SV *sv = GvSV(DBsub); - save_item(sv); - gv_efullname3(sv, CvGV(cv), Nullch); + SV *sv = GvSV(PL_DBsub); + CV *gotocv; + + if (PERLDB_SUB_NN) { + SvIVX(sv) = (IV)cv; /* Already upgraded, saved */ + } else { + save_item(sv); + gv_efullname3(sv, CvGV(cv), Nullch); + } + if ( PERLDB_GOTO + && (gotocv = get_cv("DB::goto", FALSE)) ) { + PUSHMARK( PL_stack_sp ); + call_sv((SV*)gotocv, G_SCALAR | G_NODEBUG); + PL_stack_sp--; + } } RETURNOP(CvSTART(cv)); } } - else - label = SvPV(sv,na); + else { + label = SvPV(sv,n_a); + if (!(do_dump || *label)) + DIE(aTHX_ must_have_label); + } } - else if (op->op_flags & OPf_SPECIAL) { + else if (PL_op->op_flags & OPf_SPECIAL) { if (! do_dump) - DIE("goto must have label"); + DIE(aTHX_ must_have_label); } else label = cPVOP->op_pv; @@ -1907,13 +2238,13 @@ PP(pp_goto) /* find label */ - lastgotoprobe = 0; + PL_lastgotoprobe = 0; *enterops = 0; for (ix = cxstack_ix; ix >= 0; ix--) { cx = &cxstack[ix]; - switch (cx->cx_type) { + switch (CxTYPE(cx)) { case CXt_EVAL: - gotoprobe = eval_root; /* XXX not good for nested eval */ + gotoprobe = PL_eval_root; /* XXX not good for nested eval */ break; case CXt_LOOP: gotoprobe = cx->blk_oldcop->op_sibling; @@ -1924,7 +2255,7 @@ PP(pp_goto) if (ix) gotoprobe = cx->blk_oldcop->op_sibling; else - gotoprobe = main_root; + gotoprobe = PL_main_root; break; case CXt_SUB: if (CvDEPTH(cx->blk_sub.cv)) { @@ -1933,21 +2264,21 @@ PP(pp_goto) } /* FALL THROUGH */ case CXt_NULL: - DIE("Can't \"goto\" outside a block"); + DIE(aTHX_ "Can't \"goto\" outside a block"); default: if (ix) - DIE("panic: goto"); - gotoprobe = main_root; + DIE(aTHX_ "panic: goto"); + gotoprobe = PL_main_root; break; } retop = dofindlabel(gotoprobe, label, enterops, enterops + GOTO_DEPTH); if (retop) break; - lastgotoprobe = gotoprobe; + PL_lastgotoprobe = gotoprobe; } if (!retop) - DIE("Can't find label %s", label); + DIE(aTHX_ "Can't find label %s", label); /* pop unwanted frames */ @@ -1958,38 +2289,38 @@ PP(pp_goto) ix = 0; dounwind(ix); TOPBLOCK(cx); - oldsave = scopestack[scopestack_ix]; + oldsave = PL_scopestack[PL_scopestack_ix]; LEAVE_SCOPE(oldsave); } /* push wanted frames */ if (*enterops && enterops[1]) { - OP *oldop = op; + OP *oldop = PL_op; for (ix = 1; enterops[ix]; ix++) { - op = enterops[ix]; - (*op->op_ppaddr)(ARGS); + PL_op = enterops[ix]; + /* Eventually we may want to stack the needed arguments + * for each op. For now, we punt on the hard ones. */ + if (PL_op->op_type == OP_ENTERITER) + DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop", + label); + (CALLOP->op_ppaddr)(aTHX); } - op = oldop; + PL_op = oldop; } } if (do_dump) { #ifdef VMS - if (!retop) retop = main_start; + if (!retop) retop = PL_main_start; #endif - restartop = retop; - do_undump = TRUE; + PL_restartop = retop; + PL_do_undump = TRUE; my_unexec(); - restartop = 0; /* hmm, must be GNU unexec().. */ - do_undump = FALSE; - } - - if (curstack == signalstack) { - restartop = retop; - JMPENV_JUMP(3); + PL_restartop = 0; /* hmm, must be GNU unexec().. */ + PL_do_undump = FALSE; } RETURNOP(retop); @@ -1997,7 +2328,7 @@ PP(pp_goto) PP(pp_exit) { - dSP; + djSP; I32 anum; if (MAXARG < 1) @@ -2010,19 +2341,19 @@ PP(pp_exit) #endif } my_exit(anum); - PUSHs(&sv_undef); + PUSHs(&PL_sv_undef); RETURN; } #ifdef NOTYET PP(pp_nswitch) { - dSP; - double value = SvNVx(GvSV(cCOP->cop_gv)); + djSP; + NV value = SvNVx(GvSV(cCOP->cop_gv)); register I32 match = I_32(value); if (value < 0.0) { - if (((double)match) > value) + if (((NV)match) > value) --match; /* was fractional--truncate other way */ } match -= cCOP->uop.scop.scop_offset; @@ -2030,36 +2361,35 @@ PP(pp_nswitch) match = 0; else if (match > cCOP->uop.scop.scop_max) match = cCOP->uop.scop.scop_max; - op = cCOP->uop.scop.scop_next[match]; - RETURNOP(op); + PL_op = cCOP->uop.scop.scop_next[match]; + RETURNOP(PL_op); } PP(pp_cswitch) { - dSP; + djSP; register I32 match; - if (multiline) - op = op->op_next; /* can't assume anything */ + if (PL_multiline) + PL_op = PL_op->op_next; /* can't assume anything */ else { - match = *(SvPVx(GvSV(cCOP->cop_gv), na)) & 255; + STRLEN n_a; + match = *(SvPVx(GvSV(cCOP->cop_gv), n_a)) & 255; match -= cCOP->uop.scop.scop_offset; if (match < 0) match = 0; else if (match > cCOP->uop.scop.scop_max) match = cCOP->uop.scop.scop_max; - op = cCOP->uop.scop.scop_next[match]; + PL_op = cCOP->uop.scop.scop_next[match]; } - RETURNOP(op); + RETURNOP(PL_op); } #endif /* Eval. */ -static void -save_lines(array, sv) -AV *array; -SV *sv; +STATIC void +S_save_lines(pTHX_ AV *array, SV *sv) { register char *s = SvPVX(sv); register char *send = SvPVX(sv) + SvCUR(sv); @@ -2082,231 +2412,354 @@ SV *sv; } } -static OP * -docatch(o) -OP *o; +STATIC void * +S_docatch_body(pTHX_ va_list args) +{ + CALLRUNOPS(aTHX); + return NULL; +} + +STATIC OP * +S_docatch(pTHX_ OP *o) { dTHR; int ret; - I32 oldrunlevel = runlevel; - OP *oldop = op; - dJMPENV; + OP *oldop = PL_op; - op = o; #ifdef DEBUGGING assert(CATCH_GET == TRUE); - DEBUG_l(deb("(Setting up local jumplevel, runlevel = %ld)\n", (long)runlevel+1)); #endif - JMPENV_PUSH(ret); + PL_op = o; + redo_body: + CALLPROTECT(aTHX_ &ret, MEMBER_TO_FPTR(S_docatch_body)); switch (ret) { - default: /* topmost level handles it */ - JMPENV_POP; - runlevel = oldrunlevel; - op = oldop; - JMPENV_JUMP(ret); - /* NOTREACHED */ + case 0: + break; case 3: - if (!restartop) { - PerlIO_printf(PerlIO_stderr(), "panic: restartop\n"); - break; + if (PL_restartop) { + PL_op = PL_restartop; + PL_restartop = 0; + goto redo_body; } - op = restartop; - restartop = 0; /* FALL THROUGH */ - case 0: - runops(); - break; + default: + PL_op = oldop; + JMPENV_JUMP(ret); + /* NOTREACHED */ } - JMPENV_POP; - runlevel = oldrunlevel; - op = oldop; + PL_op = oldop; return Nullop; } -static OP * -doeval(gimme) -int gimme; +OP * +Perl_sv_compile_2op(pTHX_ SV *sv, OP** startop, char *code, AV** avp) +/* sv Text to convert to OP tree. */ +/* startop op_free() this to undo. */ +/* code Short string id of the caller. */ +{ + dSP; /* Make POPBLOCK work. */ + PERL_CONTEXT *cx; + SV **newsp; + I32 gimme = 0; /* SUSPECT - INITIALZE TO WHAT? NI-S */ + I32 optype; + OP dummy; + OP *oop = PL_op, *rop; + char tmpbuf[TYPE_DIGITS(long) + 12 + 10]; + char *safestr; + + ENTER; + lex_start(sv); + SAVETMPS; + /* switch to eval mode */ + + if (PL_curcop == &PL_compiling) { + SAVESPTR(PL_compiling.cop_stash); + PL_compiling.cop_stash = PL_curstash; + } + SAVESPTR(PL_compiling.cop_filegv); + SAVEI16(PL_compiling.cop_line); + sprintf(tmpbuf, "_<(%.10s_eval %lu)", code, (unsigned long)++PL_evalseq); + PL_compiling.cop_filegv = gv_fetchfile(tmpbuf+2); + PL_compiling.cop_line = 1; + /* XXX For Cs within BEGIN {} blocks, this ends up + deleting the eval's FILEGV from the stash before gv_check() runs + (i.e. before run-time proper). To work around the coredump that + ensues, we always turn GvMULTI_on for any globals that were + introduced within evals. See force_ident(). GSAR 96-10-12 */ + safestr = savepv(tmpbuf); + SAVEDELETE(PL_defstash, safestr, strlen(safestr)); + SAVEHINTS(); +#ifdef OP_IN_REGISTER + PL_opsave = op; +#else + SAVEPPTR(PL_op); +#endif + PL_hints = 0; + + PL_op = &dummy; + PL_op->op_type = OP_ENTEREVAL; + PL_op->op_flags = 0; /* Avoid uninit warning. */ + PUSHBLOCK(cx, CXt_EVAL, SP); + PUSHEVAL(cx, 0, PL_compiling.cop_filegv); + rop = doeval(G_SCALAR, startop); + POPBLOCK(cx,PL_curpm); + POPEVAL(cx); + + (*startop)->op_type = OP_NULL; + (*startop)->op_ppaddr = PL_ppaddr[OP_NULL]; + lex_end(); + *avp = (AV*)SvREFCNT_inc(PL_comppad); + LEAVE; + if (PL_curcop == &PL_compiling) + PL_compiling.op_private = PL_hints; +#ifdef OP_IN_REGISTER + op = PL_opsave; +#endif + return rop; +} + +/* With USE_THREADS, eval_owner must be held on entry to doeval */ +STATIC OP * +S_doeval(pTHX_ int gimme, OP** startop) { - dTHR; dSP; - OP *saveop = op; + OP *saveop = PL_op; HV *newstash; CV *caller; AV* comppadlist; + I32 i; -#ifdef USE_THREADS - MUTEX_LOCK(&eval_mutex); - if (eval_owner && eval_owner != thr) - while (eval_owner) - COND_WAIT(&eval_cond, &eval_mutex); - eval_owner = thr; - MUTEX_UNLOCK(&eval_mutex); -#endif /* USE_THREADS */ - in_eval = 1; + PL_in_eval = EVAL_INEVAL; PUSHMARK(SP); /* set up a scratch pad */ - SAVEI32(padix); - SAVESPTR(curpad); - SAVESPTR(comppad); - SAVESPTR(comppad_name); - SAVEI32(comppad_name_fill); - SAVEI32(min_intro_pending); - SAVEI32(max_intro_pending); - - caller = compcv; - SAVESPTR(compcv); - compcv = (CV*)NEWSV(1104,0); - sv_upgrade((SV *)compcv, SVt_PVCV); - CvUNIQUE_on(compcv); + SAVEI32(PL_padix); + SAVESPTR(PL_curpad); + SAVESPTR(PL_comppad); + SAVESPTR(PL_comppad_name); + SAVEI32(PL_comppad_name_fill); + SAVEI32(PL_min_intro_pending); + SAVEI32(PL_max_intro_pending); + + caller = PL_compcv; + for (i = cxstack_ix - 1; i >= 0; i--) { + PERL_CONTEXT *cx = &cxstack[i]; + if (CxTYPE(cx) == CXt_EVAL) + break; + else if (CxTYPE(cx) == CXt_SUB) { + caller = cx->blk_sub.cv; + break; + } + } + + SAVESPTR(PL_compcv); + PL_compcv = (CV*)NEWSV(1104,0); + sv_upgrade((SV *)PL_compcv, SVt_PVCV); + CvEVAL_on(PL_compcv); #ifdef USE_THREADS - CvOWNER(compcv) = 0; - New(666, CvMUTEXP(compcv), 1, pthread_mutex_t); - MUTEX_INIT(CvMUTEXP(compcv)); - New(666, CvCONDP(compcv), 1, pthread_cond_t); - COND_INIT(CvCONDP(compcv)); + CvOWNER(PL_compcv) = 0; + New(666, CvMUTEXP(PL_compcv), 1, perl_mutex); + MUTEX_INIT(CvMUTEXP(PL_compcv)); #endif /* USE_THREADS */ - comppad = newAV(); - av_push(comppad, Nullsv); - curpad = AvARRAY(comppad); - comppad_name = newAV(); - comppad_name_fill = 0; - min_intro_pending = 0; - padix = 0; + PL_comppad = newAV(); + av_push(PL_comppad, Nullsv); + PL_curpad = AvARRAY(PL_comppad); + PL_comppad_name = newAV(); + PL_comppad_name_fill = 0; + PL_min_intro_pending = 0; + PL_padix = 0; #ifdef USE_THREADS - av_store(comppad_name, 0, newSVpv("@_", 2)); - curpad[0] = (SV*)newAV(); - SvPADMY_on(curpad[0]); /* XXX Needed? */ + av_store(PL_comppad_name, 0, newSVpvn("@_", 2)); + PL_curpad[0] = (SV*)newAV(); + SvPADMY_on(PL_curpad[0]); /* XXX Needed? */ #endif /* USE_THREADS */ comppadlist = newAV(); AvREAL_off(comppadlist); - av_store(comppadlist, 0, (SV*)comppad_name); - av_store(comppadlist, 1, (SV*)comppad); - CvPADLIST(compcv) = comppadlist; + av_store(comppadlist, 0, (SV*)PL_comppad_name); + av_store(comppadlist, 1, (SV*)PL_comppad); + CvPADLIST(PL_compcv) = comppadlist; - if (saveop->op_type != OP_REQUIRE) - CvOUTSIDE(compcv) = (CV*)SvREFCNT_inc(caller); + if (!saveop || saveop->op_type != OP_REQUIRE) + CvOUTSIDE(PL_compcv) = (CV*)SvREFCNT_inc(caller); - SAVEFREESV(compcv); + SAVEFREESV(PL_compcv); /* make sure we compile in the right package */ - newstash = curcop->cop_stash; - if (curstash != newstash) { - SAVESPTR(curstash); - curstash = newstash; + newstash = PL_curcop->cop_stash; + if (PL_curstash != newstash) { + SAVESPTR(PL_curstash); + PL_curstash = newstash; } - SAVESPTR(beginav); - beginav = newAV(); - SAVEFREESV(beginav); + SAVESPTR(PL_beginav); + PL_beginav = newAV(); + SAVEFREESV(PL_beginav); /* try to compile it */ - eval_root = Nullop; - error_count = 0; - curcop = &compiling; - curcop->cop_arybase = 0; - SvREFCNT_dec(rs); - rs = newSVpv("\n", 1); - if (saveop->op_flags & OPf_SPECIAL) - in_eval |= 4; + PL_eval_root = Nullop; + PL_error_count = 0; + PL_curcop = &PL_compiling; + PL_curcop->cop_arybase = 0; + SvREFCNT_dec(PL_rs); + PL_rs = newSVpvn("\n", 1); + if (saveop && saveop->op_flags & OPf_SPECIAL) + PL_in_eval |= EVAL_KEEPERR; else - sv_setpv(GvSV(errgv),""); - if (yyparse() || error_count || !eval_root) { + sv_setpv(ERRSV,""); + if (yyparse() || PL_error_count || !PL_eval_root) { SV **newsp; I32 gimme; - CONTEXT *cx; - I32 optype; - - op = saveop; - if (eval_root) { - op_free(eval_root); - eval_root = Nullop; + PERL_CONTEXT *cx; + I32 optype = 0; /* Might be reset by POPEVAL. */ + STRLEN n_a; + + PL_op = saveop; + if (PL_eval_root) { + op_free(PL_eval_root); + PL_eval_root = Nullop; + } + SP = PL_stack_base + POPMARK; /* pop original mark */ + if (!startop) { + POPBLOCK(cx,PL_curpm); + POPEVAL(cx); + pop_return(); } - SP = stack_base + POPMARK; /* pop original mark */ - POPBLOCK(cx,curpm); - POPEVAL(cx); - pop_return(); lex_end(); LEAVE; if (optype == OP_REQUIRE) { - char* msg = SvPVx(GvSV(errgv), na); - DIE("%s", *msg ? msg : "Compilation failed in require"); + char* msg = SvPVx(ERRSV, n_a); + DIE(aTHX_ "%s", *msg ? msg : "Compilation failed in require"); + } else if (startop) { + char* msg = SvPVx(ERRSV, n_a); + + POPBLOCK(cx,PL_curpm); + POPEVAL(cx); + Perl_croak(aTHX_ "%sCompilation failed in regexp", (*msg ? msg : "Unknown error\n")); } - SvREFCNT_dec(rs); - rs = SvREFCNT_inc(nrs); + SvREFCNT_dec(PL_rs); + PL_rs = SvREFCNT_inc(PL_nrs); +#ifdef USE_THREADS + MUTEX_LOCK(&PL_eval_mutex); + PL_eval_owner = 0; + COND_SIGNAL(&PL_eval_cond); + MUTEX_UNLOCK(&PL_eval_mutex); +#endif /* USE_THREADS */ RETPUSHUNDEF; } - SvREFCNT_dec(rs); - rs = SvREFCNT_inc(nrs); - compiling.cop_line = 0; - SAVEFREEOP(eval_root); + SvREFCNT_dec(PL_rs); + PL_rs = SvREFCNT_inc(PL_nrs); + PL_compiling.cop_line = 0; + if (startop) { + *startop = PL_eval_root; + SvREFCNT_dec(CvOUTSIDE(PL_compcv)); + CvOUTSIDE(PL_compcv) = Nullcv; + } else + SAVEFREEOP(PL_eval_root); if (gimme & G_VOID) - scalarvoid(eval_root); + scalarvoid(PL_eval_root); else if (gimme & G_ARRAY) - list(eval_root); + list(PL_eval_root); else - scalar(eval_root); + scalar(PL_eval_root); DEBUG_x(dump_eval()); /* Register with debugger: */ - if (perldb && saveop->op_type == OP_REQUIRE) { - CV *cv = perl_get_cv("DB::postponed", FALSE); + if (PERLDB_INTER && saveop->op_type == OP_REQUIRE) { + CV *cv = get_cv("DB::postponed", FALSE); if (cv) { dSP; - PUSHMARK(sp); - XPUSHs((SV*)compiling.cop_filegv); + PUSHMARK(SP); + XPUSHs((SV*)PL_compiling.cop_filegv); PUTBACK; - perl_call_sv((SV*)cv, G_DISCARD); + call_sv((SV*)cv, G_DISCARD); } } /* compiled okay, so do it */ - CvDEPTH(compcv) = 1; - SP = stack_base + POPMARK; /* pop original mark */ + CvDEPTH(PL_compcv) = 1; + SP = PL_stack_base + POPMARK; /* pop original mark */ + PL_op = saveop; /* The caller may need it. */ #ifdef USE_THREADS - MUTEX_LOCK(&eval_mutex); - eval_owner = 0; - COND_SIGNAL(&eval_cond); - MUTEX_UNLOCK(&eval_mutex); + MUTEX_LOCK(&PL_eval_mutex); + PL_eval_owner = 0; + COND_SIGNAL(&PL_eval_cond); + MUTEX_UNLOCK(&PL_eval_mutex); #endif /* USE_THREADS */ - RETURNOP(eval_start); + RETURNOP(PL_eval_start); +} + +STATIC PerlIO * +S_doopen_pmc(pTHX_ const char *name, const char *mode) +{ + STRLEN namelen = strlen(name); + PerlIO *fp; + + if (namelen > 3 && strEQ(name + namelen - 3, ".pm")) { + SV *pmcsv = Perl_newSVpvf(aTHX_ "%s%c", name, 'c'); + char *pmc = SvPV_nolen(pmcsv); + Stat_t pmstat; + Stat_t pmcstat; + if (PerlLIO_stat(pmc, &pmcstat) < 0) { + fp = PerlIO_open(name, mode); + } + else { + if (PerlLIO_stat(name, &pmstat) < 0 || + pmstat.st_mtime < pmcstat.st_mtime) + { + fp = PerlIO_open(pmc, mode); + } + else { + fp = PerlIO_open(name, mode); + } + } + SvREFCNT_dec(pmcsv); + } + else { + fp = PerlIO_open(name, mode); + } + return fp; } PP(pp_require) { - dSP; - register CONTEXT *cx; + djSP; + register PERL_CONTEXT *cx; SV *sv; char *name; + STRLEN len; char *tryname; SV *namesv = Nullsv; SV** svp; I32 gimme = G_SCALAR; PerlIO *tryrsfp = 0; + STRLEN n_a; + int filter_has_file = 0; + GV *filter_child_proc = 0; + SV *filter_state = 0; + SV *filter_sub = 0; sv = POPs; if (SvNIOKp(sv) && !SvPOKp(sv)) { - SET_NUMERIC_STANDARD(); - if (atof(patchlevel) + 0.00000999 < SvNV(sv)) - DIE("Perl %s required--this is only version %s, stopped", - SvPV(sv,na),patchlevel); + if (Atof(PL_patchlevel) + 0.00000999 < SvNV(sv)) + DIE(aTHX_ "Perl %s required--this is only version %s, stopped", + SvPV(sv,n_a),PL_patchlevel); RETPUSHYES; } - name = SvPV(sv, na); - if (!*name) - DIE("Null filename used"); + name = SvPV(sv, len); + if (!(name && len > 0 && *name)) + DIE(aTHX_ "Null filename used"); TAINT_PROPER("require"); - if (op->op_type == OP_REQUIRE && - (svp = hv_fetch(GvHVn(incgv), name, SvCUR(sv), 0)) && - *svp != &sv_undef) + if (PL_op->op_type == OP_REQUIRE && + (svp = hv_fetch(GvHVn(PL_incgv), name, len, 0)) && + *svp != &PL_sv_undef) RETPUSHYES; /* prepare to compile file */ @@ -2318,6 +2771,9 @@ PP(pp_require) #ifdef DOSISH || (name[0] && name[1] == ':') #endif +#ifdef WIN32 + || (name[0] == '\\' && name[1] == '\\') /* UNC path */ +#endif #ifdef VMS || (strchr(name,':') || ((*name == '[' || *name == '<') && (isALNUM(name[1]) || strchr("$-_]>",name[1])))) @@ -2325,10 +2781,10 @@ PP(pp_require) ) { tryname = name; - tryrsfp = PerlIO_open(name,"r"); + tryrsfp = doopen_pmc(name,PERL_SCRIPT_MODE); } else { - AV *ar = GvAVn(incgv); + AV *ar = GvAVn(PL_incgv); I32 i; #ifdef VMS char *unixname; @@ -2337,83 +2793,231 @@ PP(pp_require) { namesv = NEWSV(806, 0); for (i = 0; i <= AvFILL(ar); i++) { - char *dir = SvPVx(*av_fetch(ar, i, TRUE), na); + SV *dirsv = *av_fetch(ar, i, TRUE); + + if (SvROK(dirsv)) { + int count; + SV *loader = dirsv; + + if (SvTYPE(SvRV(loader)) == SVt_PVAV) { + loader = *av_fetch((AV *)SvRV(loader), 0, TRUE); + } + + Perl_sv_setpvf(aTHX_ namesv, "/loader/0x%lx/%s", + SvANY(loader), name); + tryname = SvPVX(namesv); + tryrsfp = 0; + + ENTER; + SAVETMPS; + EXTEND(SP, 2); + + PUSHMARK(SP); + PUSHs(dirsv); + PUSHs(sv); + PUTBACK; + count = call_sv(loader, G_ARRAY); + SPAGAIN; + + if (count > 0) { + int i = 0; + SV *arg; + + SP -= count - 1; + arg = SP[i++]; + + if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVGV) { + arg = SvRV(arg); + } + + if (SvTYPE(arg) == SVt_PVGV) { + IO *io = GvIO((GV *)arg); + + ++filter_has_file; + + if (io) { + tryrsfp = IoIFP(io); + if (IoTYPE(io) == '|') { + /* reading from a child process doesn't + nest -- when returning from reading + the inner module, the outer one is + unreadable (closed?) I've tried to + save the gv to manage the lifespan of + the pipe, but this didn't help. XXX */ + filter_child_proc = (GV *)arg; + (void)SvREFCNT_inc(filter_child_proc); + } + else { + if (IoOFP(io) && IoOFP(io) != IoIFP(io)) { + PerlIO_close(IoOFP(io)); + } + IoIFP(io) = Nullfp; + IoOFP(io) = Nullfp; + } + } + + if (i < count) { + arg = SP[i++]; + } + } + + if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVCV) { + filter_sub = arg; + (void)SvREFCNT_inc(filter_sub); + + if (i < count) { + filter_state = SP[i]; + (void)SvREFCNT_inc(filter_state); + } + + if (tryrsfp == 0) { + tryrsfp = PerlIO_open("/dev/null", + PERL_SCRIPT_MODE); + } + } + } + + PUTBACK; + FREETMPS; + LEAVE; + + if (tryrsfp) { + break; + } + + filter_has_file = 0; + if (filter_child_proc) { + SvREFCNT_dec(filter_child_proc); + filter_child_proc = 0; + } + if (filter_state) { + SvREFCNT_dec(filter_state); + filter_state = 0; + } + if (filter_sub) { + SvREFCNT_dec(filter_sub); + filter_sub = 0; + } + } + else { + char *dir = SvPVx(dirsv, n_a); #ifdef VMS - char *unixdir; - if ((unixdir = tounixpath(dir, Nullch)) == Nullch) - continue; - sv_setpv(namesv, unixdir); - sv_catpv(namesv, unixname); + char *unixdir; + if ((unixdir = tounixpath(dir, Nullch)) == Nullch) + continue; + sv_setpv(namesv, unixdir); + sv_catpv(namesv, unixname); #else - sv_setpvf(namesv, "%s/%s", dir, name); + Perl_sv_setpvf(aTHX_ namesv, "%s/%s", dir, name); #endif - tryname = SvPVX(namesv); - tryrsfp = PerlIO_open(tryname, "r"); - if (tryrsfp) { - if (tryname[0] == '.' && tryname[1] == '/') - tryname += 2; - break; + TAINT_PROPER("require"); + tryname = SvPVX(namesv); + tryrsfp = doopen_pmc(tryname, PERL_SCRIPT_MODE); + if (tryrsfp) { + if (tryname[0] == '.' && tryname[1] == '/') + tryname += 2; + break; + } } } } } - SAVESPTR(compiling.cop_filegv); - compiling.cop_filegv = gv_fetchfile(tryrsfp ? tryname : name); + SAVESPTR(PL_compiling.cop_filegv); + PL_compiling.cop_filegv = gv_fetchfile(tryrsfp ? tryname : name); SvREFCNT_dec(namesv); if (!tryrsfp) { - if (op->op_type == OP_REQUIRE) { - SV *msg = sv_2mortal(newSVpvf("Can't locate %s in @INC", name)); - if (instr(SvPVX(msg), ".h ")) - sv_catpv(msg, " (change .h to .ph maybe?)"); - if (instr(SvPVX(msg), ".ph ")) - sv_catpv(msg, " (did you run h2ph?)"); - DIE("%_", msg); + if (PL_op->op_type == OP_REQUIRE) { + char *msgstr = name; + if (namesv) { /* did we lookup @INC? */ + SV *msg = sv_2mortal(newSVpv(msgstr,0)); + SV *dirmsgsv = NEWSV(0, 0); + AV *ar = GvAVn(PL_incgv); + I32 i; + sv_catpvn(msg, " in @INC", 8); + if (instr(SvPVX(msg), ".h ")) + sv_catpv(msg, " (change .h to .ph maybe?)"); + if (instr(SvPVX(msg), ".ph ")) + sv_catpv(msg, " (did you run h2ph?)"); + sv_catpv(msg, " (@INC contains:"); + for (i = 0; i <= AvFILL(ar); i++) { + char *dir = SvPVx(*av_fetch(ar, i, TRUE), n_a); + Perl_sv_setpvf(aTHX_ dirmsgsv, " %s", dir); + sv_catsv(msg, dirmsgsv); + } + sv_catpvn(msg, ")", 1); + SvREFCNT_dec(dirmsgsv); + msgstr = SvPV_nolen(msg); + } + DIE(aTHX_ "Can't locate %s", msgstr); } RETPUSHUNDEF; } + else + SETERRNO(0, SS$_NORMAL); /* Assume success here to prevent recursive requirement. */ - (void)hv_store(GvHVn(incgv), name, strlen(name), - newSVsv(GvSV(compiling.cop_filegv)), 0 ); + (void)hv_store(GvHVn(PL_incgv), name, strlen(name), + newSVsv(GvSV(PL_compiling.cop_filegv)), 0 ); ENTER; SAVETMPS; - lex_start(sv_2mortal(newSVpv("",0))); - if (rsfp_filters){ - save_aptr(&rsfp_filters); - rsfp_filters = NULL; - } + lex_start(sv_2mortal(newSVpvn("",0))); + SAVEGENERICSV(PL_rsfp_filters); + PL_rsfp_filters = Nullav; - rsfp = tryrsfp; + PL_rsfp = tryrsfp; name = savepv(name); SAVEFREEPV(name); - SAVEI32(hints); - hints = 0; - - /* switch to eval mode */ + SAVEHINTS(); + PL_hints = 0; + SAVEPPTR(PL_compiling.cop_warnings); + if (PL_dowarn & G_WARN_ALL_ON) + PL_compiling.cop_warnings = WARN_ALL ; + else if (PL_dowarn & G_WARN_ALL_OFF) + PL_compiling.cop_warnings = WARN_NONE ; + else + PL_compiling.cop_warnings = WARN_STD ; + + if (filter_sub || filter_child_proc) { + SV *datasv = filter_add(run_user_filter, Nullsv); + IoLINES(datasv) = filter_has_file; + IoFMT_GV(datasv) = (GV *)filter_child_proc; + IoTOP_GV(datasv) = (GV *)filter_state; + IoBOTTOM_GV(datasv) = (GV *)filter_sub; + } - push_return(op->op_next); + /* switch to eval mode */ + push_return(PL_op->op_next); PUSHBLOCK(cx, CXt_EVAL, SP); - PUSHEVAL(cx, name, compiling.cop_filegv); + PUSHEVAL(cx, name, PL_compiling.cop_filegv); - compiling.cop_line = 0; + SAVEI16(PL_compiling.cop_line); + PL_compiling.cop_line = 0; PUTBACK; - return DOCATCH(doeval(G_SCALAR)); +#ifdef USE_THREADS + MUTEX_LOCK(&PL_eval_mutex); + if (PL_eval_owner && PL_eval_owner != thr) + while (PL_eval_owner) + COND_WAIT(&PL_eval_cond, &PL_eval_mutex); + PL_eval_owner = thr; + MUTEX_UNLOCK(&PL_eval_mutex); +#endif /* USE_THREADS */ + return DOCATCH(doeval(G_SCALAR, NULL)); } PP(pp_dofile) { - return pp_require(ARGS); + return pp_require(); } PP(pp_entereval) { - dSP; - register CONTEXT *cx; + djSP; + register PERL_CONTEXT *cx; dPOPss; - I32 gimme = GIMME_V, was = sub_generation; + I32 gimme = GIMME_V, was = PL_sub_generation; char tmpbuf[TYPE_DIGITS(long) + 12]; char *safestr; STRLEN len; @@ -2429,31 +3033,45 @@ PP(pp_entereval) /* switch to eval mode */ - SAVESPTR(compiling.cop_filegv); - sprintf(tmpbuf, "_<(eval %lu)", (unsigned long)++evalseq); - compiling.cop_filegv = gv_fetchfile(tmpbuf+2); - compiling.cop_line = 1; + SAVESPTR(PL_compiling.cop_filegv); + sprintf(tmpbuf, "_<(eval %lu)", (unsigned long)++PL_evalseq); + PL_compiling.cop_filegv = gv_fetchfile(tmpbuf+2); + PL_compiling.cop_line = 1; /* XXX For Cs within BEGIN {} blocks, this ends up deleting the eval's FILEGV from the stash before gv_check() runs (i.e. before run-time proper). To work around the coredump that ensues, we always turn GvMULTI_on for any globals that were introduced within evals. See force_ident(). GSAR 96-10-12 */ safestr = savepv(tmpbuf); - SAVEDELETE(defstash, safestr, strlen(safestr)); - SAVEI32(hints); - hints = op->op_targ; + SAVEDELETE(PL_defstash, safestr, strlen(safestr)); + SAVEHINTS(); + PL_hints = PL_op->op_targ; + SAVEPPTR(PL_compiling.cop_warnings); + if (!specialWARN(PL_compiling.cop_warnings)) { + PL_compiling.cop_warnings = newSVsv(PL_compiling.cop_warnings) ; + SAVEFREESV(PL_compiling.cop_warnings) ; + } - push_return(op->op_next); - PUSHBLOCK(cx, CXt_EVAL, SP); - PUSHEVAL(cx, 0, compiling.cop_filegv); + push_return(PL_op->op_next); + PUSHBLOCK(cx, (CXt_EVAL|CXp_REAL), SP); + PUSHEVAL(cx, 0, PL_compiling.cop_filegv); /* prepare to compile string */ - if (perldb && curstash != debstash) - save_lines(GvAV(compiling.cop_filegv), linestr); + if (PERLDB_LINE && PL_curstash != PL_debstash) + save_lines(GvAV(PL_compiling.cop_filegv), PL_linestr); PUTBACK; - ret = doeval(gimme); - if (perldb && was != sub_generation) { /* Some subs defined here. */ +#ifdef USE_THREADS + MUTEX_LOCK(&PL_eval_mutex); + if (PL_eval_owner && PL_eval_owner != thr) + while (PL_eval_owner) + COND_WAIT(&PL_eval_cond, &PL_eval_mutex); + PL_eval_owner = thr; + MUTEX_UNLOCK(&PL_eval_mutex); +#endif /* USE_THREADS */ + ret = doeval(gimme, NULL); + if (PERLDB_INTER && was != PL_sub_generation /* Some subs defined here. */ + && ret != PL_op->op_next) { /* Successive compilation. */ strcpy(safestr, "_<(eval )"); /* Anything fake and short. */ } return DOCATCH(ret); @@ -2461,14 +3079,14 @@ PP(pp_entereval) PP(pp_leaveeval) { - dSP; + djSP; register SV **mark; SV **newsp; PMOP *newpm; I32 gimme; - register CONTEXT *cx; + register PERL_CONTEXT *cx; OP *retop; - U8 save_flags = op -> op_flags; + U8 save_flags = PL_op -> op_flags; I32 optype; POPBLOCK(cx,newpm); @@ -2488,7 +3106,7 @@ PP(pp_leaveeval) } else { MEXTEND(mark,0); - *MARK = &sv_undef; + *MARK = &PL_sv_undef; } } else { @@ -2500,35 +3118,39 @@ PP(pp_leaveeval) } } } - curpm = newpm; /* Don't pop $1 et al till now */ + PL_curpm = newpm; /* Don't pop $1 et al till now */ + + if (AvFILLp(PL_comppad_name) >= 0) + free_closures(); #ifdef DEBUGGING - assert(CvDEPTH(compcv) == 1); + assert(CvDEPTH(PL_compcv) == 1); #endif - CvDEPTH(compcv) = 0; + CvDEPTH(PL_compcv) = 0; + lex_end(); if (optype == OP_REQUIRE && - !(gimme == G_SCALAR ? SvTRUE(*sp) : sp > newsp)) + !(gimme == G_SCALAR ? SvTRUE(*SP) : SP > newsp)) { /* Unassume the success we assumed earlier. */ char *name = cx->blk_eval.old_name; - (void)hv_delete(GvHVn(incgv), name, strlen(name), G_DISCARD); - retop = die("%s did not return a true value", name); + (void)hv_delete(GvHVn(PL_incgv), name, strlen(name), G_DISCARD); + retop = Perl_die(aTHX_ "%s did not return a true value", name); + /* die_where() did LEAVE, or we won't be here */ + } + else { + LEAVE; + if (!(save_flags & OPf_SPECIAL)) + sv_setpv(ERRSV,""); } - - lex_end(); - LEAVE; - - if (!(save_flags & OPf_SPECIAL)) - sv_setpv(GvSV(errgv),""); RETURNOP(retop); } PP(pp_entertry) { - dSP; - register CONTEXT *cx; + djSP; + register PERL_CONTEXT *cx; I32 gimme = GIMME_V; ENTER; @@ -2537,22 +3159,22 @@ PP(pp_entertry) push_return(cLOGOP->op_other->op_next); PUSHBLOCK(cx, CXt_EVAL, SP); PUSHEVAL(cx, 0, 0); - eval_root = op; /* Only needed so that goto works right. */ + PL_eval_root = PL_op; /* Only needed so that goto works right. */ - in_eval = 1; - sv_setpv(GvSV(errgv),""); + PL_in_eval = EVAL_INEVAL; + sv_setpv(ERRSV,""); PUTBACK; - return DOCATCH(op->op_next); + return DOCATCH(PL_op->op_next); } PP(pp_leavetry) { - dSP; + djSP; register SV **mark; SV **newsp; PMOP *newpm; I32 gimme; - register CONTEXT *cx; + register PERL_CONTEXT *cx; I32 optype; POPBLOCK(cx,newpm); @@ -2572,7 +3194,7 @@ PP(pp_leavetry) } else { MEXTEND(mark,0); - *MARK = &sv_undef; + *MARK = &PL_sv_undef; } SP = MARK; } @@ -2585,16 +3207,15 @@ PP(pp_leavetry) } } } - curpm = newpm; /* Don't pop $1 et al till now */ + PL_curpm = newpm; /* Don't pop $1 et al till now */ LEAVE; - sv_setpv(GvSV(errgv),""); + sv_setpv(ERRSV,""); RETURN; } -static void -doparseform(sv) -SV *sv; +STATIC void +S_doparseform(pTHX_ SV *sv) { STRLEN len; register char *s = SvPV_force(sv, len); @@ -2611,7 +3232,7 @@ SV *sv; bool ischop; if (len == 0) - croak("Null picture in formline"); + Perl_croak(aTHX_ "Null picture in formline"); New(804, fops, (send - s)*3+10, U16); /* Almost certainly too long... */ fpc = fops; @@ -2770,3 +3391,916 @@ SV *sv; sv_magic(sv, Nullsv, 'f', Nullch, 0); SvCOMPILED_on(sv); } + +/* + * The rest of this file was derived from source code contributed + * by Tom Horsley. + * + * NOTE: this code was derived from Tom Horsley's qsort replacement + * and should not be confused with the original code. + */ + +/* Copyright (C) Tom Horsley, 1997. All rights reserved. + + Permission granted to distribute under the same terms as perl which are + (briefly): + + This program is free software; you can redistribute it and/or modify + it under the terms of either: + + a) the GNU General Public License as published by the Free + Software Foundation; either version 1, or (at your option) any + later version, or + + b) the "Artistic License" which comes with this Kit. + + Details on the perl license can be found in the perl source code which + may be located via the www.perl.com web page. + + This is the most wonderfulest possible qsort I can come up with (and + still be mostly portable) My (limited) tests indicate it consistently + does about 20% fewer calls to compare than does the qsort in the Visual + C++ library, other vendors may vary. + + Some of the ideas in here can be found in "Algorithms" by Sedgewick, + others I invented myself (or more likely re-invented since they seemed + pretty obvious once I watched the algorithm operate for a while). + + Most of this code was written while watching the Marlins sweep the Giants + in the 1997 National League Playoffs - no Braves fans allowed to use this + code (just kidding :-). + + I realize that if I wanted to be true to the perl tradition, the only + comment in this file would be something like: + + ...they shuffled back towards the rear of the line. 'No, not at the + rear!' the slave-driver shouted. 'Three files up. And stay there... + + However, I really needed to violate that tradition just so I could keep + track of what happens myself, not to mention some poor fool trying to + understand this years from now :-). +*/ + +/* ********************************************************** Configuration */ + +#ifndef QSORT_ORDER_GUESS +#define QSORT_ORDER_GUESS 2 /* Select doubling version of the netBSD trick */ +#endif + +/* QSORT_MAX_STACK is the largest number of partitions that can be stacked up for + future processing - a good max upper bound is log base 2 of memory size + (32 on 32 bit machines, 64 on 64 bit machines, etc). In reality can + safely be smaller than that since the program is taking up some space and + most operating systems only let you grab some subset of contiguous + memory (not to mention that you are normally sorting data larger than + 1 byte element size :-). +*/ +#ifndef QSORT_MAX_STACK +#define QSORT_MAX_STACK 32 +#endif + +/* QSORT_BREAK_EVEN is the size of the largest partition we should insertion sort. + Anything bigger and we use qsort. If you make this too small, the qsort + will probably break (or become less efficient), because it doesn't expect + the middle element of a partition to be the same as the right or left - + you have been warned). +*/ +#ifndef QSORT_BREAK_EVEN +#define QSORT_BREAK_EVEN 6 +#endif + +/* ************************************************************* Data Types */ + +/* hold left and right index values of a partition waiting to be sorted (the + partition includes both left and right - right is NOT one past the end or + anything like that). +*/ +struct partition_stack_entry { + int left; + int right; +#ifdef QSORT_ORDER_GUESS + int qsort_break_even; +#endif +}; + +/* ******************************************************* Shorthand Macros */ + +/* Note that these macros will be used from inside the qsort function where + we happen to know that the variable 'elt_size' contains the size of an + array element and the variable 'temp' points to enough space to hold a + temp element and the variable 'array' points to the array being sorted + and 'compare' is the pointer to the compare routine. + + Also note that there are very many highly architecture specific ways + these might be sped up, but this is simply the most generally portable + code I could think of. +*/ + +/* Return < 0 == 0 or > 0 as the value of elt1 is < elt2, == elt2, > elt2 +*/ +#define qsort_cmp(elt1, elt2) \ + ((*compare)(aTHXo_ array[elt1], array[elt2])) + +#ifdef QSORT_ORDER_GUESS +#define QSORT_NOTICE_SWAP swapped++; +#else +#define QSORT_NOTICE_SWAP +#endif + +/* swaps contents of array elements elt1, elt2. +*/ +#define qsort_swap(elt1, elt2) \ + STMT_START { \ + QSORT_NOTICE_SWAP \ + temp = array[elt1]; \ + array[elt1] = array[elt2]; \ + array[elt2] = temp; \ + } STMT_END + +/* rotate contents of elt1, elt2, elt3 such that elt1 gets elt2, elt2 gets + elt3 and elt3 gets elt1. +*/ +#define qsort_rotate(elt1, elt2, elt3) \ + STMT_START { \ + QSORT_NOTICE_SWAP \ + temp = array[elt1]; \ + array[elt1] = array[elt2]; \ + array[elt2] = array[elt3]; \ + array[elt3] = temp; \ + } STMT_END + +/* ************************************************************ Debug stuff */ + +#ifdef QSORT_DEBUG + +static void +break_here() +{ + return; /* good place to set a breakpoint */ +} + +#define qsort_assert(t) (void)( (t) || (break_here(), 0) ) + +static void +doqsort_all_asserts( + void * array, + size_t num_elts, + size_t elt_size, + int (*compare)(const void * elt1, const void * elt2), + int pc_left, int pc_right, int u_left, int u_right) +{ + int i; + + qsort_assert(pc_left <= pc_right); + qsort_assert(u_right < pc_left); + qsort_assert(pc_right < u_left); + for (i = u_right + 1; i < pc_left; ++i) { + qsort_assert(qsort_cmp(i, pc_left) < 0); + } + for (i = pc_left; i < pc_right; ++i) { + qsort_assert(qsort_cmp(i, pc_right) == 0); + } + for (i = pc_right + 1; i < u_left; ++i) { + qsort_assert(qsort_cmp(pc_right, i) < 0); + } +} + +#define qsort_all_asserts(PC_LEFT, PC_RIGHT, U_LEFT, U_RIGHT) \ + doqsort_all_asserts(array, num_elts, elt_size, compare, \ + PC_LEFT, PC_RIGHT, U_LEFT, U_RIGHT) + +#else + +#define qsort_assert(t) ((void)0) + +#define qsort_all_asserts(PC_LEFT, PC_RIGHT, U_LEFT, U_RIGHT) ((void)0) + +#endif + +/* ****************************************************************** qsort */ + +STATIC void +S_qsortsv(pTHX_ SV ** array, size_t num_elts, SVCOMPARE_t compare) +{ + register SV * temp; + + struct partition_stack_entry partition_stack[QSORT_MAX_STACK]; + int next_stack_entry = 0; + + int part_left; + int part_right; +#ifdef QSORT_ORDER_GUESS + int qsort_break_even; + int swapped; +#endif + + /* Make sure we actually have work to do. + */ + if (num_elts <= 1) { + return; + } + + /* Setup the initial partition definition and fall into the sorting loop + */ + part_left = 0; + part_right = (int)(num_elts - 1); +#ifdef QSORT_ORDER_GUESS + qsort_break_even = QSORT_BREAK_EVEN; +#else +#define qsort_break_even QSORT_BREAK_EVEN +#endif + for ( ; ; ) { + if ((part_right - part_left) >= qsort_break_even) { + /* OK, this is gonna get hairy, so lets try to document all the + concepts and abbreviations and variables and what they keep + track of: + + pc: pivot chunk - the set of array elements we accumulate in the + middle of the partition, all equal in value to the original + pivot element selected. The pc is defined by: + + pc_left - the leftmost array index of the pc + pc_right - the rightmost array index of the pc + + we start with pc_left == pc_right and only one element + in the pivot chunk (but it can grow during the scan). + + u: uncompared elements - the set of elements in the partition + we have not yet compared to the pivot value. There are two + uncompared sets during the scan - one to the left of the pc + and one to the right. + + u_right - the rightmost index of the left side's uncompared set + u_left - the leftmost index of the right side's uncompared set + + The leftmost index of the left sides's uncompared set + doesn't need its own variable because it is always defined + by the leftmost edge of the whole partition (part_left). The + same goes for the rightmost edge of the right partition + (part_right). + + We know there are no uncompared elements on the left once we + get u_right < part_left and no uncompared elements on the + right once u_left > part_right. When both these conditions + are met, we have completed the scan of the partition. + + Any elements which are between the pivot chunk and the + uncompared elements should be less than the pivot value on + the left side and greater than the pivot value on the right + side (in fact, the goal of the whole algorithm is to arrange + for that to be true and make the groups of less-than and + greater-then elements into new partitions to sort again). + + As you marvel at the complexity of the code and wonder why it + has to be so confusing. Consider some of the things this level + of confusion brings: + + Once I do a compare, I squeeze every ounce of juice out of it. I + never do compare calls I don't have to do, and I certainly never + do redundant calls. + + I also never swap any elements unless I can prove there is a + good reason. Many sort algorithms will swap a known value with + an uncompared value just to get things in the right place (or + avoid complexity :-), but that uncompared value, once it gets + compared, may then have to be swapped again. A lot of the + complexity of this code is due to the fact that it never swaps + anything except compared values, and it only swaps them when the + compare shows they are out of position. + */ + int pc_left, pc_right; + int u_right, u_left; + + int s; + + pc_left = ((part_left + part_right) / 2); + pc_right = pc_left; + u_right = pc_left - 1; + u_left = pc_right + 1; + + /* Qsort works best when the pivot value is also the median value + in the partition (unfortunately you can't find the median value + without first sorting :-), so to give the algorithm a helping + hand, we pick 3 elements and sort them and use the median value + of that tiny set as the pivot value. + + Some versions of qsort like to use the left middle and right as + the 3 elements to sort so they can insure the ends of the + partition will contain values which will stop the scan in the + compare loop, but when you have to call an arbitrarily complex + routine to do a compare, its really better to just keep track of + array index values to know when you hit the edge of the + partition and avoid the extra compare. An even better reason to + avoid using a compare call is the fact that you can drop off the + edge of the array if someone foolishly provides you with an + unstable compare function that doesn't always provide consistent + results. + + So, since it is simpler for us to compare the three adjacent + elements in the middle of the partition, those are the ones we + pick here (conveniently pointed at by u_right, pc_left, and + u_left). The values of the left, center, and right elements + are refered to as l c and r in the following comments. + */ + +#ifdef QSORT_ORDER_GUESS + swapped = 0; +#endif + s = qsort_cmp(u_right, pc_left); + if (s < 0) { + /* l < c */ + s = qsort_cmp(pc_left, u_left); + /* if l < c, c < r - already in order - nothing to do */ + if (s == 0) { + /* l < c, c == r - already in order, pc grows */ + ++pc_right; + qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1); + } else if (s > 0) { + /* l < c, c > r - need to know more */ + s = qsort_cmp(u_right, u_left); + if (s < 0) { + /* l < c, c > r, l < r - swap c & r to get ordered */ + qsort_swap(pc_left, u_left); + qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1); + } else if (s == 0) { + /* l < c, c > r, l == r - swap c&r, grow pc */ + qsort_swap(pc_left, u_left); + --pc_left; + qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1); + } else { + /* l < c, c > r, l > r - make lcr into rlc to get ordered */ + qsort_rotate(pc_left, u_right, u_left); + qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1); + } + } + } else if (s == 0) { + /* l == c */ + s = qsort_cmp(pc_left, u_left); + if (s < 0) { + /* l == c, c < r - already in order, grow pc */ + --pc_left; + qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1); + } else if (s == 0) { + /* l == c, c == r - already in order, grow pc both ways */ + --pc_left; + ++pc_right; + qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1); + } else { + /* l == c, c > r - swap l & r, grow pc */ + qsort_swap(u_right, u_left); + ++pc_right; + qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1); + } + } else { + /* l > c */ + s = qsort_cmp(pc_left, u_left); + if (s < 0) { + /* l > c, c < r - need to know more */ + s = qsort_cmp(u_right, u_left); + if (s < 0) { + /* l > c, c < r, l < r - swap l & c to get ordered */ + qsort_swap(u_right, pc_left); + qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1); + } else if (s == 0) { + /* l > c, c < r, l == r - swap l & c, grow pc */ + qsort_swap(u_right, pc_left); + ++pc_right; + qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1); + } else { + /* l > c, c < r, l > r - rotate lcr into crl to order */ + qsort_rotate(u_right, pc_left, u_left); + qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1); + } + } else if (s == 0) { + /* l > c, c == r - swap ends, grow pc */ + qsort_swap(u_right, u_left); + --pc_left; + qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1); + } else { + /* l > c, c > r - swap ends to get in order */ + qsort_swap(u_right, u_left); + qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1); + } + } + /* We now know the 3 middle elements have been compared and + arranged in the desired order, so we can shrink the uncompared + sets on both sides + */ + --u_right; + ++u_left; + qsort_all_asserts(pc_left, pc_right, u_left, u_right); + + /* The above massive nested if was the simple part :-). We now have + the middle 3 elements ordered and we need to scan through the + uncompared sets on either side, swapping elements that are on + the wrong side or simply shuffling equal elements around to get + all equal elements into the pivot chunk. + */ + + for ( ; ; ) { + int still_work_on_left; + int still_work_on_right; + + /* Scan the uncompared values on the left. If I find a value + equal to the pivot value, move it over so it is adjacent to + the pivot chunk and expand the pivot chunk. If I find a value + less than the pivot value, then just leave it - its already + on the correct side of the partition. If I find a greater + value, then stop the scan. + */ + while (still_work_on_left = (u_right >= part_left)) { + s = qsort_cmp(u_right, pc_left); + if (s < 0) { + --u_right; + } else if (s == 0) { + --pc_left; + if (pc_left != u_right) { + qsort_swap(u_right, pc_left); + } + --u_right; + } else { + break; + } + qsort_assert(u_right < pc_left); + qsort_assert(pc_left <= pc_right); + qsort_assert(qsort_cmp(u_right + 1, pc_left) <= 0); + qsort_assert(qsort_cmp(pc_left, pc_right) == 0); + } + + /* Do a mirror image scan of uncompared values on the right + */ + while (still_work_on_right = (u_left <= part_right)) { + s = qsort_cmp(pc_right, u_left); + if (s < 0) { + ++u_left; + } else if (s == 0) { + ++pc_right; + if (pc_right != u_left) { + qsort_swap(pc_right, u_left); + } + ++u_left; + } else { + break; + } + qsort_assert(u_left > pc_right); + qsort_assert(pc_left <= pc_right); + qsort_assert(qsort_cmp(pc_right, u_left - 1) <= 0); + qsort_assert(qsort_cmp(pc_left, pc_right) == 0); + } + + if (still_work_on_left) { + /* I know I have a value on the left side which needs to be + on the right side, but I need to know more to decide + exactly the best thing to do with it. + */ + if (still_work_on_right) { + /* I know I have values on both side which are out of + position. This is a big win because I kill two birds + with one swap (so to speak). I can advance the + uncompared pointers on both sides after swapping both + of them into the right place. + */ + qsort_swap(u_right, u_left); + --u_right; + ++u_left; + qsort_all_asserts(pc_left, pc_right, u_left, u_right); + } else { + /* I have an out of position value on the left, but the + right is fully scanned, so I "slide" the pivot chunk + and any less-than values left one to make room for the + greater value over on the right. If the out of position + value is immediately adjacent to the pivot chunk (there + are no less-than values), I can do that with a swap, + otherwise, I have to rotate one of the less than values + into the former position of the out of position value + and the right end of the pivot chunk into the left end + (got all that?). + */ + --pc_left; + if (pc_left == u_right) { + qsort_swap(u_right, pc_right); + qsort_all_asserts(pc_left, pc_right-1, u_left, u_right-1); + } else { + qsort_rotate(u_right, pc_left, pc_right); + qsort_all_asserts(pc_left, pc_right-1, u_left, u_right-1); + } + --pc_right; + --u_right; + } + } else if (still_work_on_right) { + /* Mirror image of complex case above: I have an out of + position value on the right, but the left is fully + scanned, so I need to shuffle things around to make room + for the right value on the left. + */ + ++pc_right; + if (pc_right == u_left) { + qsort_swap(u_left, pc_left); + qsort_all_asserts(pc_left+1, pc_right, u_left+1, u_right); + } else { + qsort_rotate(pc_right, pc_left, u_left); + qsort_all_asserts(pc_left+1, pc_right, u_left+1, u_right); + } + ++pc_left; + ++u_left; + } else { + /* No more scanning required on either side of partition, + break out of loop and figure out next set of partitions + */ + break; + } + } + + /* The elements in the pivot chunk are now in the right place. They + will never move or be compared again. All I have to do is decide + what to do with the stuff to the left and right of the pivot + chunk. + + Notes on the QSORT_ORDER_GUESS ifdef code: + + 1. If I just built these partitions without swapping any (or + very many) elements, there is a chance that the elements are + already ordered properly (being properly ordered will + certainly result in no swapping, but the converse can't be + proved :-). + + 2. A (properly written) insertion sort will run faster on + already ordered data than qsort will. + + 3. Perhaps there is some way to make a good guess about + switching to an insertion sort earlier than partition size 6 + (for instance - we could save the partition size on the stack + and increase the size each time we find we didn't swap, thus + switching to insertion sort earlier for partitions with a + history of not swapping). + + 4. Naturally, if I just switch right away, it will make + artificial benchmarks with pure ascending (or descending) + data look really good, but is that a good reason in general? + Hard to say... + */ + +#ifdef QSORT_ORDER_GUESS + if (swapped < 3) { +#if QSORT_ORDER_GUESS == 1 + qsort_break_even = (part_right - part_left) + 1; +#endif +#if QSORT_ORDER_GUESS == 2 + qsort_break_even *= 2; +#endif +#if QSORT_ORDER_GUESS == 3 + int prev_break = qsort_break_even; + qsort_break_even *= qsort_break_even; + if (qsort_break_even < prev_break) { + qsort_break_even = (part_right - part_left) + 1; + } +#endif + } else { + qsort_break_even = QSORT_BREAK_EVEN; + } +#endif + + if (part_left < pc_left) { + /* There are elements on the left which need more processing. + Check the right as well before deciding what to do. + */ + if (pc_right < part_right) { + /* We have two partitions to be sorted. Stack the biggest one + and process the smallest one on the next iteration. This + minimizes the stack height by insuring that any additional + stack entries must come from the smallest partition which + (because it is smallest) will have the fewest + opportunities to generate additional stack entries. + */ + if ((part_right - pc_right) > (pc_left - part_left)) { + /* stack the right partition, process the left */ + partition_stack[next_stack_entry].left = pc_right + 1; + partition_stack[next_stack_entry].right = part_right; +#ifdef QSORT_ORDER_GUESS + partition_stack[next_stack_entry].qsort_break_even = qsort_break_even; +#endif + part_right = pc_left - 1; + } else { + /* stack the left partition, process the right */ + partition_stack[next_stack_entry].left = part_left; + partition_stack[next_stack_entry].right = pc_left - 1; +#ifdef QSORT_ORDER_GUESS + partition_stack[next_stack_entry].qsort_break_even = qsort_break_even; +#endif + part_left = pc_right + 1; + } + qsort_assert(next_stack_entry < QSORT_MAX_STACK); + ++next_stack_entry; + } else { + /* The elements on the left are the only remaining elements + that need sorting, arrange for them to be processed as the + next partition. + */ + part_right = pc_left - 1; + } + } else if (pc_right < part_right) { + /* There is only one chunk on the right to be sorted, make it + the new partition and loop back around. + */ + part_left = pc_right + 1; + } else { + /* This whole partition wound up in the pivot chunk, so + we need to get a new partition off the stack. + */ + if (next_stack_entry == 0) { + /* the stack is empty - we are done */ + break; + } + --next_stack_entry; + part_left = partition_stack[next_stack_entry].left; + part_right = partition_stack[next_stack_entry].right; +#ifdef QSORT_ORDER_GUESS + qsort_break_even = partition_stack[next_stack_entry].qsort_break_even; +#endif + } + } else { + /* This partition is too small to fool with qsort complexity, just + do an ordinary insertion sort to minimize overhead. + */ + int i; + /* Assume 1st element is in right place already, and start checking + at 2nd element to see where it should be inserted. + */ + for (i = part_left + 1; i <= part_right; ++i) { + int j; + /* Scan (backwards - just in case 'i' is already in right place) + through the elements already sorted to see if the ith element + belongs ahead of one of them. + */ + for (j = i - 1; j >= part_left; --j) { + if (qsort_cmp(i, j) >= 0) { + /* i belongs right after j + */ + break; + } + } + ++j; + if (j != i) { + /* Looks like we really need to move some things + */ + int k; + temp = array[i]; + for (k = i - 1; k >= j; --k) + array[k + 1] = array[k]; + array[j] = temp; + } + } + + /* That partition is now sorted, grab the next one, or get out + of the loop if there aren't any more. + */ + + if (next_stack_entry == 0) { + /* the stack is empty - we are done */ + break; + } + --next_stack_entry; + part_left = partition_stack[next_stack_entry].left; + part_right = partition_stack[next_stack_entry].right; +#ifdef QSORT_ORDER_GUESS + qsort_break_even = partition_stack[next_stack_entry].qsort_break_even; +#endif + } + } + + /* Believe it or not, the array is sorted at this point! */ +} + + +#ifdef PERL_OBJECT +#define NO_XSLOCKS +#undef this +#define this pPerl +#include "XSUB.h" +#endif + + +static I32 +sortcv(pTHXo_ SV *a, SV *b) +{ + dTHR; + I32 oldsaveix = PL_savestack_ix; + I32 oldscopeix = PL_scopestack_ix; + I32 result; + GvSV(PL_firstgv) = a; + GvSV(PL_secondgv) = b; + PL_stack_sp = PL_stack_base; + PL_op = PL_sortcop; + CALLRUNOPS(aTHX); + if (PL_stack_sp != PL_stack_base + 1) + Perl_croak(aTHX_ "Sort subroutine didn't return single value"); + if (!SvNIOKp(*PL_stack_sp)) + Perl_croak(aTHX_ "Sort subroutine didn't return a numeric value"); + result = SvIV(*PL_stack_sp); + while (PL_scopestack_ix > oldscopeix) { + LEAVE; + } + leave_scope(oldsaveix); + return result; +} + + +static I32 +sv_ncmp(pTHXo_ SV *a, SV *b) +{ + NV nv1 = SvNV(a); + NV nv2 = SvNV(b); + return nv1 < nv2 ? -1 : nv1 > nv2 ? 1 : 0; +} + +static I32 +sv_i_ncmp(pTHXo_ SV *a, SV *b) +{ + IV iv1 = SvIV(a); + IV iv2 = SvIV(b); + return iv1 < iv2 ? -1 : iv1 > iv2 ? 1 : 0; +} +#define tryCALL_AMAGICbin(left,right,meth,svp) STMT_START { \ + *svp = Nullsv; \ + if (PL_amagic_generation) { \ + if (SvAMAGIC(left)||SvAMAGIC(right))\ + *svp = amagic_call(left, \ + right, \ + CAT2(meth,_amg), \ + 0); \ + } \ + } STMT_END + +static I32 +amagic_ncmp(pTHXo_ register SV *a, register SV *b) +{ + SV *tmpsv; + tryCALL_AMAGICbin(a,b,ncmp,&tmpsv); + if (tmpsv) { + NV d; + + if (SvIOK(tmpsv)) { + I32 i = SvIVX(tmpsv); + if (i > 0) + return 1; + return i? -1 : 0; + } + d = SvNV(tmpsv); + if (d > 0) + return 1; + return d? -1 : 0; + } + return sv_ncmp(aTHXo_ a, b); +} + +static I32 +amagic_i_ncmp(pTHXo_ register SV *a, register SV *b) +{ + SV *tmpsv; + tryCALL_AMAGICbin(a,b,ncmp,&tmpsv); + if (tmpsv) { + NV d; + + if (SvIOK(tmpsv)) { + I32 i = SvIVX(tmpsv); + if (i > 0) + return 1; + return i? -1 : 0; + } + d = SvNV(tmpsv); + if (d > 0) + return 1; + return d? -1 : 0; + } + return sv_i_ncmp(aTHXo_ a, b); +} + +static I32 +amagic_cmp(pTHXo_ register SV *str1, register SV *str2) +{ + SV *tmpsv; + tryCALL_AMAGICbin(str1,str2,scmp,&tmpsv); + if (tmpsv) { + NV d; + + if (SvIOK(tmpsv)) { + I32 i = SvIVX(tmpsv); + if (i > 0) + return 1; + return i? -1 : 0; + } + d = SvNV(tmpsv); + if (d > 0) + return 1; + return d? -1 : 0; + } + return sv_cmp(str1, str2); +} + +static I32 +amagic_cmp_locale(pTHXo_ register SV *str1, register SV *str2) +{ + SV *tmpsv; + tryCALL_AMAGICbin(str1,str2,scmp,&tmpsv); + if (tmpsv) { + NV d; + + if (SvIOK(tmpsv)) { + I32 i = SvIVX(tmpsv); + if (i > 0) + return 1; + return i? -1 : 0; + } + d = SvNV(tmpsv); + if (d > 0) + return 1; + return d? -1 : 0; + } + return sv_cmp_locale(str1, str2); +} + +static I32 +run_user_filter(pTHXo_ int idx, SV *buf_sv, int maxlen) +{ + SV *datasv = FILTER_DATA(idx); + int filter_has_file = IoLINES(datasv); + GV *filter_child_proc = (GV *)IoFMT_GV(datasv); + SV *filter_state = (SV *)IoTOP_GV(datasv); + SV *filter_sub = (SV *)IoBOTTOM_GV(datasv); + int len = 0; + + /* I was having segfault trouble under Linux 2.2.5 after a + parse error occured. (Had to hack around it with a test + for PL_error_count == 0.) Solaris doesn't segfault -- + not sure where the trouble is yet. XXX */ + + if (filter_has_file) { + len = FILTER_READ(idx+1, buf_sv, maxlen); + } + + if (filter_sub && len >= 0) { + djSP; + int count; + + ENTER; + SAVE_DEFSV; + SAVETMPS; + EXTEND(SP, 2); + + DEFSV = buf_sv; + PUSHMARK(SP); + PUSHs(sv_2mortal(newSViv(maxlen))); + if (filter_state) { + PUSHs(filter_state); + } + PUTBACK; + count = call_sv(filter_sub, G_SCALAR); + SPAGAIN; + + if (count > 0) { + SV *out = POPs; + if (SvOK(out)) { + len = SvIV(out); + } + } + + PUTBACK; + FREETMPS; + LEAVE; + } + + if (len <= 0) { + IoLINES(datasv) = 0; + if (filter_child_proc) { + SvREFCNT_dec(filter_child_proc); + IoFMT_GV(datasv) = Nullgv; + } + if (filter_state) { + SvREFCNT_dec(filter_state); + IoTOP_GV(datasv) = Nullgv; + } + if (filter_sub) { + SvREFCNT_dec(filter_sub); + IoBOTTOM_GV(datasv) = Nullgv; + } + filter_del(run_user_filter); + } + + return len; +} + +#ifdef PERL_OBJECT + +static I32 +sv_cmp_locale_static(pTHXo_ register SV *str1, register SV *str2) +{ + return sv_cmp_locale(str1, str2); +} + +static I32 +sv_cmp_static(pTHXo_ register SV *str1, register SV *str2) +{ + return sv_cmp(str1, str2); +} + +#endif /* PERL_OBJECT */