X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=pp_ctl.c;h=22c83aa8d085587378fbf1ab37998559bd959e79;hb=11faa288e292c27cb2ddc4ccdc483b523d26ce19;hp=19bfb2183c4470128e651f00438f11ff04575661;hpb=288ec9e31566cfd8e9a63e1dd3d7e670d6e519b8;p=p5sagit%2Fp5-mst-13.2.git diff --git a/pp_ctl.c b/pp_ctl.c index 19bfb21..22c83aa 100644 --- a/pp_ctl.c +++ b/pp_ctl.c @@ -17,6 +17,7 @@ */ #include "EXTERN.h" +#define PERL_IN_PP_CTL_C #include "perl.h" #ifndef WORD_ALIGN @@ -25,30 +26,21 @@ #define DOCATCH(o) ((CATCH_GET == TRUE) ? docatch(o) : (o)) +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 -#define CALLOP this->*PL_op +static I32 sv_cmp_static(pTHXo_ SV *a, SV *b); +static I32 sv_cmp_locale_static(pTHXo_ SV *a, SV *b); #else -#define CALLOP *PL_op -static void *docatch_body _((va_list args)); -static OP *docatch _((OP *o)); -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 I32 dopoptosub_at _((PERL_CONTEXT *cxstk, I32 startingblock)); -static void save_lines _((AV *array, SV *sv)); -static I32 sortcv _((SV *a, SV *b)); -static void qsortsv _((SV **array, size_t num_elts, I32 (*fun)(SV *a, SV *b))); -static OP *doeval _((int gimme, OP** startop)); -static PerlIO *doopen_pmc _((const char *name, const char *mode)); -static I32 sv_ncmp _((SV *a, SV *b)); -static I32 sv_i_ncmp _((SV *a, SV *b)); -static I32 amagic_ncmp _((SV *a, SV *b)); -static I32 amagic_i_ncmp _((SV *a, SV *b)); -static I32 amagic_cmp _((SV *str1, SV *str2)); -static I32 amagic_cmp_locale _((SV *str1, SV *str2)); +#define sv_cmp_static Perl_sv_cmp +#define sv_cmp_locale_static Perl_sv_cmp_locale #endif PP(pp_wantarray) @@ -120,7 +112,7 @@ PP(pp_regcomp) PL_reginterp_cnt = I32_MAX; /* Mark as safe. */ pm->op_pmflags = pm->op_pmpermflags; /* reset case sensitivity */ - pm->op_pmregexp = CALLREGCOMP(t, t + len, pm); + pm->op_pmregexp = CALLREGCOMP(aTHX_ t, t + len, pm); PL_reginterp_cnt = 0; /* XXXX Be extra paranoid - needed inside tie/overload accessors. */ } @@ -162,18 +154,18 @@ 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 & 2) && SvTAINTED(TOPs)) cx->sb_rxtainted |= 2; sv_catsv(dstr, POPs); /* Are we done */ - if (cx->sb_once || !CALLREGEXEC(rx, s, cx->sb_strend, orig, + 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_COPY_STR|REXEC_IGNOREPOS)))) + ? (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); @@ -201,23 +193,23 @@ PP(pp_substcont) 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_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(void **rsp, REGEXP *rx) +Perl_rxres_save(pTHX_ void **rsp, REGEXP *rx) { UV *p = (UV*)*rsp; U32 i; @@ -231,13 +223,13 @@ rxres_save(void **rsp, REGEXP *rx) *rsp = (void*)p; } - *p++ = (UV)rx->subbase; - rx->subbase = Nullch; + *p++ = PTR2UV(RX_MATCH_COPIED(rx) ? rx->subbeg : Nullch); + RX_MATCH_COPIED_off(rx); *p++ = rx->nparens; - *p++ = (UV)rx->subbeg; - *p++ = (UV)rx->subend; + *p++ = PTR2UV(rx->subbeg); + *p++ = (UV)rx->sublen; for (i = 0; i <= rx->nparens; ++i) { *p++ = (UV)rx->startp[i]; *p++ = (UV)rx->endp[i]; @@ -245,32 +237,33 @@ rxres_save(void **rsp, REGEXP *rx) } void -rxres_restore(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->subbeg = INT2PTR(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(void **rsp) +Perl_rxres_free(pTHX_ void **rsp) { UV *p = (UV*)*rsp; if (p) { - Safefree((char*)(*p)); + Safefree(INT2PTR(char*,*p)); Safefree(p); *rsp = Null(void*); } @@ -294,7 +287,7 @@ PP(pp_formline) 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; @@ -337,9 +330,9 @@ PP(pp_formline) case FF_END: name = "END"; break; } if (arg >= 0) - PerlIO_printf(PerlIO_stderr(), "%-16s%ld\n", name, (long) arg); + PerlIO_printf(Perl_debug_log, "%-16s%ld\n", name, (long) arg); else - PerlIO_printf(PerlIO_stderr(), "%-16s\n", name); + PerlIO_printf(Perl_debug_log, "%-16s\n", name); } ) switch (*fpc++) { case FF_LINEMARK: @@ -368,7 +361,7 @@ PP(pp_formline) else { sv = &PL_sv_no; if (ckWARN(WARN_SYNTAX)) - warner(WARN_SYNTAX, "Not enough format arguments"); + Perl_warner(aTHX_ WARN_SYNTAX, "Not enough format arguments"); } break; @@ -585,11 +578,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; @@ -611,7 +618,7 @@ PP(pp_formline) if (lines == 200) { arg = t - linemark; if (strnEQ(linemark, linemark - arg, arg)) - DIE("Runaway format"); + DIE(aTHX_ "Runaway format"); } FmLINES(PL_formtarget) = lines; SP = ORIGMARK; @@ -667,12 +674,12 @@ PP(pp_grepstart) if (PL_stack_base + *PL_markstack_ptr == SP) { (void)POPMARK; if (GIMME_V == G_SCALAR) - XPUSHi(0); + XPUSHs(sv_2mortal(newSViv(0))); RETURNOP(PL_op->op_next->op_next); } PL_stack_sp = PL_stack_base + *PL_markstack_ptr + 1; - pp_pushmark(ARGS); /* push dst */ - pp_pushmark(ARGS); /* push src */ + pp_pushmark(); /* push dst */ + pp_pushmark(); /* push src */ ENTER; /* enter outer scope */ SAVETMPS; @@ -687,13 +694,13 @@ PP(pp_grepstart) PUTBACK; if (PL_op->op_type == OP_MAPSTART) - pp_pushmark(ARGS); /* push top */ + 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) @@ -759,119 +766,6 @@ PP(pp_mapwhile) } } -STATIC I32 -sv_ncmp (SV *a, SV *b) -{ - double nv1 = SvNV(a); - double nv2 = SvNV(b); - return nv1 < nv2 ? -1 : nv1 > nv2 ? 1 : 0; -} -STATIC I32 -sv_i_ncmp (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(register SV *a, register SV *b) -{ - SV *tmpsv; - tryCALL_AMAGICbin(a,b,ncmp,&tmpsv); - if (tmpsv) { - double 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(a, b); -} - -STATIC I32 -amagic_i_ncmp(register SV *a, register SV *b) -{ - SV *tmpsv; - tryCALL_AMAGICbin(a,b,ncmp,&tmpsv); - if (tmpsv) { - double 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(a, b); -} - -STATIC I32 -amagic_cmp(register SV *str1, register SV *str2) -{ - SV *tmpsv; - tryCALL_AMAGICbin(str1,str2,scmp,&tmpsv); - if (tmpsv) { - double 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(register SV *str1, register SV *str2) -{ - SV *tmpsv; - tryCALL_AMAGICbin(str1,str2,scmp,&tmpsv); - if (tmpsv) { - double 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); -} - PP(pp_sort) { djSP; dMARK; dORIGMARK; @@ -898,7 +792,7 @@ PP(pp_sort) kid = kUNOP->op_first; /* pass rv2gv */ kid = kUNOP->op_first; /* pass leave */ PL_sortcop = kid->op_next; - stash = PL_curcop->cop_stash; + stash = CopSTASH(PL_curcop); } else { cv = sv_2cv(*++MARK, &stash, &gv, 0); @@ -907,16 +801,16 @@ 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"); } PL_sortcop = CvSTART(cv); SAVESPTR(CvROOT(cv)->op_ppaddr); @@ -928,7 +822,7 @@ PP(pp_sort) } else { PL_sortcop = Nullop; - stash = PL_curcop->cop_stash; + stash = CopSTASH(PL_curcop); } up = myorigmark + 1; @@ -977,7 +871,7 @@ PP(pp_sort) (void)SvREFCNT_inc(cv); /* in preparation for POPSUB */ } PL_sortcxix = cxstack_ix; - qsortsv((myorigmark+1), max, FUNC_NAME_TO_PTR(sortcv)); + qsortsv((myorigmark+1), max, sortcv); POPBLOCK(cx,PL_curpm); PL_stack_sp = newsp; @@ -991,19 +885,13 @@ PP(pp_sort) qsortsv(ORIGMARK+1, max, (PL_op->op_private & OPpSORT_NUMERIC) ? ( (PL_op->op_private & OPpSORT_INTEGER) - ? ( overloading - ? FUNC_NAME_TO_PTR(amagic_i_ncmp) - : FUNC_NAME_TO_PTR(sv_i_ncmp)) - : ( overloading - ? FUNC_NAME_TO_PTR(amagic_ncmp) - : FUNC_NAME_TO_PTR(sv_ncmp))) + ? ( overloading ? amagic_i_ncmp : sv_i_ncmp) + : ( overloading ? amagic_ncmp : sv_ncmp)) : ( (PL_op->op_private & OPpLOCALE) ? ( overloading - ? FUNC_NAME_TO_PTR(amagic_cmp_locale) - : FUNC_NAME_TO_PTR(sv_cmp_locale)) - : ( overloading - ? FUNC_NAME_TO_PTR(amagic_cmp) - : FUNC_NAME_TO_PTR(sv_cmp) ))); + ? 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; @@ -1025,11 +913,11 @@ PP(pp_sort) PP(pp_range) { if (GIMME == G_ARRAY) - return cCONDOP->op_true; + return NORMAL; if (SvTRUEx(PAD_SV(PL_op->op_targ))) - return cCONDOP->op_false; + return cLOGOP->op_other; else - return cCONDOP->op_true; + return NORMAL; } PP(pp_flip) @@ -1037,7 +925,7 @@ PP(pp_flip) djSP; if (GIMME == G_ARRAY) { - RETURNOP(((CONDOP*)cUNOP->op_first)->op_false); + RETURNOP(((LOGOP*)cUNOP->op_first)->op_other); } else { dTOPss; @@ -1055,7 +943,7 @@ PP(pp_flip) else { sv_setiv(targ, 0); SP--; - RETURNOP(((CONDOP*)cUNOP->op_first)->op_false); + RETURNOP(((LOGOP*)cUNOP->op_first)->op_other); } } sv_setpv(TARG, ""); @@ -1083,7 +971,7 @@ PP(pp_flop) (looks_like_number(left) && *SvPVX(left) != '0') ) { if (SvNV(left) < IV_MIN || SvNV(right) > IV_MAX) - croak("Range iterator outside integer range"); + DIE(aTHX_ "Range iterator outside integer range"); i = SvIV(left); max = SvIV(right); if (max >= i) { @@ -1133,7 +1021,7 @@ PP(pp_flop) /* Control. */ STATIC I32 -dopoptolabel(char *label) +S_dopoptolabel(pTHX_ char *label) { dTHR; register I32 i; @@ -1144,32 +1032,32 @@ dopoptolabel(char *label) switch (CxTYPE(cx)) { case CXt_SUBST: if (ckWARN(WARN_UNSAFE)) - warner(WARN_UNSAFE, "Exiting substitution via %s", + Perl_warner(aTHX_ WARN_UNSAFE, "Exiting substitution via %s", PL_op_name[PL_op->op_type]); break; case CXt_SUB: if (ckWARN(WARN_UNSAFE)) - warner(WARN_UNSAFE, "Exiting subroutine via %s", + Perl_warner(aTHX_ WARN_UNSAFE, "Exiting subroutine via %s", PL_op_name[PL_op->op_type]); break; case CXt_EVAL: if (ckWARN(WARN_UNSAFE)) - warner(WARN_UNSAFE, "Exiting eval via %s", + Perl_warner(aTHX_ WARN_UNSAFE, "Exiting eval via %s", PL_op_name[PL_op->op_type]); break; case CXt_NULL: if (ckWARN(WARN_UNSAFE)) - warner(WARN_UNSAFE, "Exiting pseudo-block via %s", + 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; } } @@ -1177,14 +1065,14 @@ dopoptolabel(char *label) } I32 -dowantarray(void) +Perl_dowantarray(pTHX) { I32 gimme = block_gimme(); return (gimme == G_VOID) ? G_SCALAR : gimme; } I32 -block_gimme(void) +Perl_block_gimme(pTHX) { dTHR; I32 cxix; @@ -1201,21 +1089,21 @@ block_gimme(void) 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(I32 startingblock) +S_dopoptosub(pTHX_ I32 startingblock) { dTHR; return dopoptosub_at(cxstack, startingblock); } STATIC I32 -dopoptosub_at(PERL_CONTEXT *cxstk, I32 startingblock) +S_dopoptosub_at(pTHX_ PERL_CONTEXT *cxstk, I32 startingblock) { dTHR; I32 i; @@ -1227,7 +1115,7 @@ dopoptosub_at(PERL_CONTEXT *cxstk, I32 startingblock) 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; } } @@ -1235,7 +1123,7 @@ dopoptosub_at(PERL_CONTEXT *cxstk, I32 startingblock) } STATIC I32 -dopoptoeval(I32 startingblock) +S_dopoptoeval(pTHX_ I32 startingblock) { dTHR; I32 i; @@ -1246,7 +1134,7 @@ dopoptoeval(I32 startingblock) 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; } } @@ -1254,7 +1142,7 @@ dopoptoeval(I32 startingblock) } STATIC I32 -dopoptoloop(I32 startingblock) +S_dopoptoloop(pTHX_ I32 startingblock) { dTHR; I32 i; @@ -1264,26 +1152,26 @@ dopoptoloop(I32 startingblock) switch (CxTYPE(cx)) { case CXt_SUBST: if (ckWARN(WARN_UNSAFE)) - warner(WARN_UNSAFE, "Exiting substitution via %s", + Perl_warner(aTHX_ WARN_UNSAFE, "Exiting substitution via %s", PL_op_name[PL_op->op_type]); break; case CXt_SUB: if (ckWARN(WARN_UNSAFE)) - warner(WARN_UNSAFE, "Exiting subroutine via %s", + Perl_warner(aTHX_ WARN_UNSAFE, "Exiting subroutine via %s", PL_op_name[PL_op->op_type]); break; case CXt_EVAL: if (ckWARN(WARN_UNSAFE)) - warner(WARN_UNSAFE, "Exiting eval via %s", + Perl_warner(aTHX_ WARN_UNSAFE, "Exiting eval via %s", PL_op_name[PL_op->op_type]); break; case CXt_NULL: if (ckWARN(WARN_UNSAFE)) - warner(WARN_UNSAFE, "Exiting pseudo-block via %s", + 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; } } @@ -1291,7 +1179,7 @@ dopoptoloop(I32 startingblock) } void -dounwind(I32 cxix) +Perl_dounwind(pTHX_ I32 cxix) { dTHR; register PERL_CONTEXT *cx; @@ -1299,6 +1187,7 @@ dounwind(I32 cxix) I32 optype; while (cxstack_ix > cxix) { + SV *sv; cx = &cxstack[cxstack_ix]; DEBUG_l(PerlIO_printf(Perl_debug_log, "Unwinding block %ld, type %s\n", (long) cxstack_ix, PL_block_type[CxTYPE(cx)])); @@ -1308,7 +1197,8 @@ dounwind(I32 cxix) POPSUBST(cx); continue; /* not break */ case CXt_SUB: - POPSUB(cx); + POPSUB(cx,sv); + LEAVESUB(sv); break; case CXt_EVAL: POPEVAL(cx); @@ -1323,8 +1213,56 @@ dounwind(I32 cxix) } } +/* + * 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; + 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; + } + } + } +} + +void +Perl_qerror(pTHX_ SV *err) +{ + if (PL_in_eval) + sv_catsv(ERRSV, err); + else if (PL_errors) + sv_catsv(PL_errors, err); + else + Perl_warn(aTHX_ "%_", err); + ++PL_error_count; +} + OP * -die_where(char *message, STRLEN msglen) +Perl_die_where(pTHX_ char *message, STRLEN msglen) { dSP; STRLEN n_a; @@ -1335,27 +1273,26 @@ die_where(char *message, STRLEN msglen) SV **newsp; if (message) { - if (PL_in_eval & 4) { - 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; - warner(WARN_UNSAFE, SvPVX(err)+start); - } + if (PL_in_eval & EVAL_KEEPERR) { + static char prefix[] = "\t(in cleanup) "; + SV *err = ERRSV; + char *e = Nullch; + if (!SvPOK(err)) + sv_setpv(err,""); + else if (SvCUR(err) >= sizeof(prefix)+msglen-1) { + e = SvPV(err, n_a); + e += n_a - msglen; + if (*e != *message || strNE(e,message)) + e = Nullch; + } + if (!e) { + 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); } } else @@ -1364,7 +1301,9 @@ die_where(char *message, STRLEN msglen) else message = SvPVx(ERRSV, msglen); - while ((cxix = dopoptoeval(cxstack_ix)) < 0 && PL_curstackinfo->si_prev) { + while ((cxix = dopoptoeval(cxstack_ix)) < 0 + && PL_curstackinfo->si_prev) + { dounwind(-1); POPSTACK; } @@ -1377,8 +1316,8 @@ die_where(char *message, STRLEN msglen) POPBLOCK(cx,PL_curpm); if (CxTYPE(cx) != CXt_EVAL) { - PerlIO_write(PerlIO_stderr(), "panic: die ", 11); - PerlIO_write(PerlIO_stderr(), message, msglen); + PerlIO_write(Perl_error_log, "panic: die ", 11); + PerlIO_write(Perl_error_log, message, msglen); my_exit(1); } POPEVAL(cx); @@ -1391,7 +1330,8 @@ die_where(char *message, STRLEN msglen) if (optype == OP_REQUIRE) { char* msg = SvPVx(ERRSV, n_a); - DIE("%s", *msg ? msg : "Compilation failed in require"); + DIE(aTHX_ "%sCompilation failed in require", + *msg ? msg : "Unknown error\n"); } return pop_return(); } @@ -1403,8 +1343,10 @@ die_where(char *message, STRLEN msglen) /* SFIO can really mess with your errno */ int e = errno; #endif - PerlIO_write(PerlIO_stderr(), message, msglen); - (void)PerlIO_flush(PerlIO_stderr()); + PerlIO *serr = Perl_error_log; + + PerlIO_write(serr, message, msglen); + (void)PerlIO_flush(serr); #ifdef USE_SFIO errno = e; #endif @@ -1456,7 +1398,7 @@ PP(pp_caller) 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) { @@ -1486,8 +1428,8 @@ PP(pp_caller) cx = &ccstack[dbcxix]; } + hv = CopSTASH(cx->blk_oldcop); if (GIMME != G_ARRAY) { - hv = cx->blk_oldcop->cop_stash; if (!hv) PUSHs(&PL_sv_undef); else { @@ -1498,14 +1440,12 @@ PP(pp_caller) RETURN; } - 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))); + PUSHs(sv_2mortal(newSVsv(CopFILESV(cx->blk_oldcop)))); + PUSHs(sv_2mortal(newSViv((I32)CopLINE(cx->blk_oldcop)))); if (!MAXARG) RETURN; if (CxTYPE(cx) == CXt_SUB) { /* So is ccstack[dbcxix]. */ @@ -1534,9 +1474,12 @@ PP(pp_caller) PUSHs(&PL_sv_yes); } } - else if (CxTYPE(cx) == CXt_SUB && - cx->blk_sub.hasargs && - PL_curcop->cop_stash == PL_debstash) + else { + PUSHs(&PL_sv_undef); + PUSHs(&PL_sv_undef); + } + if (CxTYPE(cx) == CXt_SUB && cx->blk_sub.hasargs + && CopSTASH(PL_curcop) == PL_debstash) { AV *ary = cx->blk_sub.argarray; int off = AvARRAY(ary) - AvALLOC(ary); @@ -1554,33 +1497,14 @@ PP(pp_caller) 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 I32 -sortcv(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(); - if (PL_stack_sp != PL_stack_base + 1) - croak("Sort subroutine didn't return single value"); - if (!SvNIOKp(*PL_stack_sp)) - croak("Sort subroutine didn't return a numeric value"); - result = SvIV(*PL_stack_sp); - while (PL_scopestack_ix > oldscopeix) { - LEAVE; - } - leave_scope(oldsaveix); - return result; -} - PP(pp_reset) { djSP; @@ -1591,7 +1515,7 @@ PP(pp_reset) tmps = ""; else tmps = POPpx; - sv_reset(tmps, PL_curcop->cop_stash); + sv_reset(tmps, CopSTASH(PL_curcop)); PUSHs(&PL_sv_yes); RETURN; } @@ -1620,7 +1544,7 @@ PP(pp_dbstate) 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 && !(PL_debug & (1<<30))) /* don't do recursive DB::DB call */ return NORMAL; @@ -1693,7 +1617,7 @@ PP(pp_enteriter) (looks_like_number(sv) && *SvPVX(sv) != '0')) { if (SvNV(sv) < IV_MIN || SvNV((SV*)cx->blk_loop.iterary) >= IV_MAX) - croak("Range iterator outside integer range"); + DIE(aTHX_ "Range iterator outside integer range"); cx->blk_loop.iterix = SvIV(sv); cx->blk_loop.itermax = SvIV((SV*)cx->blk_loop.iterary); } @@ -1730,7 +1654,6 @@ PP(pp_leaveloop) { djSP; register PERL_CONTEXT *cx; - struct block_loop cxloop; I32 gimme; SV **newsp; PMOP *newpm; @@ -1738,7 +1661,7 @@ PP(pp_leaveloop) POPBLOCK(cx,newpm); mark = newsp; - POPLOOP1(cx); /* Delay POPLOOP2 until stack values are safe */ + newsp = PL_stack_base + cx->blk_loop.resetsp; TAINT_NOT; if (gimme == G_VOID) @@ -1758,7 +1681,7 @@ PP(pp_leaveloop) SP = newsp; PUTBACK; - POPLOOP2(); /* Stack values are safe: release loop vars ... */ + POPLOOP(cx); /* Stack values are safe: release loop vars ... */ PL_curpm = newpm; /* ... and pop $1 et al */ LEAVE; @@ -1772,12 +1695,12 @@ PP(pp_return) djSP; dMARK; I32 cxix; register PERL_CONTEXT *cx; - struct block_sub cxsub; bool popsub2 = FALSE; I32 gimme; SV **newsp; PMOP *newpm; I32 optype = 0; + SV *sv; if (PL_curstackinfo->si_type == PERLSI_SORT) { if (cxstack_ix == PL_sortcxix || dopoptosub(cxstack_ix) <= PL_sortcxix) { @@ -1791,36 +1714,38 @@ PP(pp_return) 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 (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(PL_incgv), name, strlen(name), G_DISCARD); - DIE("%s did not return a true value", name); + 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) { if (popsub2) { - if (cxsub.cv && CvDEPTH(cxsub.cv) > 1) { + if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) { if (SvTEMP(TOPs)) { *++newsp = SvREFCNT_inc(*SP); FREETMPS; @@ -1847,11 +1772,14 @@ PP(pp_return) /* Stack values are safe: */ if (popsub2) { - POPSUB2(); /* release CV and @_ ... */ + POPSUB(cx,sv); /* release CV and @_ ... */ } + else + sv = Nullsv; PL_curpm = newpm; /* ... and pop $1 et al */ LEAVE; + LEAVESUB(sv); return pop_return(); } @@ -1860,38 +1788,37 @@ PP(pp_last) djSP; I32 cxix; register PERL_CONTEXT *cx; - struct block_loop cxloop; - struct block_sub cxsub; I32 pop2 = 0; I32 gimme; I32 optype; OP *nextop; SV **newsp; PMOP *newpm; - SV **mark = PL_stack_base + cxstack[cxstack_ix].blk_oldsp; + SV **mark; + SV *sv = Nullsv; 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); + mark = newsp; switch (CxTYPE(cx)) { case CXt_LOOP: - POPLOOP1(cx); /* Delay POPLOOP2 until stack values are safe */ pop2 = CXt_LOOP; - nextop = cxloop.last_op->op_next; + newsp = PL_stack_base + cx->blk_loop.resetsp; + nextop = cx->blk_loop.last_op->op_next; break; case CXt_SUB: - POPSUB1(cx); /* Delay POPSUB2 until stack values are safe */ pop2 = CXt_SUB; nextop = pop_return(); break; @@ -1900,7 +1827,7 @@ PP(pp_last) nextop = pop_return(); break; default: - DIE("panic: last"); + DIE(aTHX_ "panic: last"); } TAINT_NOT; @@ -1924,16 +1851,17 @@ PP(pp_last) /* Stack values are safe: */ switch (pop2) { case CXt_LOOP: - POPLOOP2(); /* release loop vars ... */ + POPLOOP(cx); /* release loop vars ... */ LEAVE; break; case CXt_SUB: - POPSUB2(); /* release CV and @_ ... */ + POPSUB(cx,sv); /* release CV and @_ ... */ break; } PL_curpm = newpm; /* ... and pop $1 et al */ LEAVE; + LEAVESUB(sv); return nextop; } @@ -1946,12 +1874,12 @@ PP(pp_next) 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); @@ -1971,12 +1899,12 @@ PP(pp_redo) 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); @@ -1988,14 +1916,14 @@ PP(pp_redo) } STATIC OP * -dofindlabel(OP *o, char *label, OP **opstack, OP **oplimit) +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 || @@ -2003,7 +1931,7 @@ dofindlabel(OP *o, char *label, OP **opstack, 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) { @@ -2032,7 +1960,7 @@ dofindlabel(OP *o, char *label, OP **opstack, OP **oplimit) PP(pp_dump) { - return pp_goto(ARGS); + return pp_goto(); /*NOTREACHED*/ } @@ -2061,7 +1989,6 @@ PP(pp_goto) SV** mark; I32 items = 0; I32 oldsave; - int arg_was_real = 0; retry: if (!CvROOT(cv) && !CvXSUB(cv)) { @@ -2078,23 +2005,23 @@ PP(pp_goto) goto retry; tmpstr = sv_newmortal(); gv_efullname3(tmpstr, gv, Nullch); - DIE("Goto undefined subroutine &%s",SvPVX(tmpstr)); + 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); if (CxTYPE(cx) == CXt_EVAL && cx->blk_eval.old_op_type == OP_ENTEREVAL) - DIE("Can't goto subroutine from an eval-string"); + 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 */ + if (CxTYPE(cx) == CXt_SUB && cx->blk_sub.hasargs) { + /* put @_ back onto stack */ AV* av = cx->blk_sub.argarray; items = AvFILLp(av) + 1; @@ -2106,11 +2033,14 @@ PP(pp_goto) SvREFCNT_dec(GvAV(PL_defgv)); GvAV(PL_defgv) = cx->blk_sub.savearray; #endif /* USE_THREADS */ + /* abandon @_ if it got reified */ if (AvREAL(av)) { - arg_was_real = 1; - AvREAL_off(av); /* so av_clear() won't clobber elts */ + (void)sv_2mortal((SV*)av); /* delay until return */ + av = newAV(); + av_extend(av, items-1); + AvFLAGS(av) = AVf_REIFY; + PL_curpad[0] = (SV*)(cx->blk_sub.argarray = av); } - av_clear(av); } else if (CvXSUB(cv)) { /* put GvAV(defgv) back onto stack */ AV* av; @@ -2137,12 +2067,12 @@ PP(pp_goto) if (CvXSUB(cv)) { #ifdef PERL_XSUB_OLDSTYLE if (CvOLDSTYLE(cv)) { - I32 (*fp3)_((int,int,int)); + 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 - PL_stack_base + 1, items); @@ -2157,7 +2087,7 @@ PP(pp_goto) PL_stack_sp--; /* There is no cv arg. */ /* Push a mark for the start of arglist */ PUSHMARK(mark); - (void)(*CvXSUB(cv))(cv _PERL_OBJECT_THIS); + (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! */ @@ -2207,6 +2137,9 @@ PP(pp_goto) SvPADMY_on(sv); } } + else if (IS_PADGV(oldpad[ix])) { + av_store(newpad, ix, sv = SvREFCNT_inc(oldpad[ix])); + } else { av_store(newpad, ix, sv = NEWSV(0,0)); SvPADTMP_on(sv); @@ -2268,11 +2201,7 @@ PP(pp_goto) } Copy(mark,AvARRAY(av),items,SV*); AvFILLp(av) = items - 1; - /* preserve @_ nature */ - if (arg_was_real) { - AvREIFY_off(av); - AvREAL_on(av); - } + assert(!AvREAL(av)); while (items--) { if (*mark) SvTEMP_off(*mark); @@ -2288,15 +2217,15 @@ PP(pp_goto) CV *gotocv; if (PERLDB_SUB_NN) { - SvIVX(sv) = (IV)cv; /* Already upgraded, saved */ + SvIVX(sv) = PTR2IV(cv); /* Already upgraded, saved */ } else { save_item(sv); gv_efullname3(sv, CvGV(cv), Nullch); } if ( PERLDB_GOTO - && (gotocv = perl_get_cv("DB::goto", FALSE)) ) { + && (gotocv = get_cv("DB::goto", FALSE)) ) { PUSHMARK( PL_stack_sp ); - perl_call_sv((SV*)gotocv, G_SCALAR | G_NODEBUG); + call_sv((SV*)gotocv, G_SCALAR | G_NODEBUG); PL_stack_sp--; } } @@ -2306,12 +2235,12 @@ PP(pp_goto) else { label = SvPV(sv,n_a); if (!(do_dump || *label)) - DIE(must_have_label); + DIE(aTHX_ must_have_label); } } else if (PL_op->op_flags & OPf_SPECIAL) { if (! do_dump) - DIE(must_have_label); + DIE(aTHX_ must_have_label); } else label = cPVOP->op_pv; @@ -2347,10 +2276,10 @@ 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"); + DIE(aTHX_ "panic: goto"); gotoprobe = PL_main_root; break; } @@ -2361,7 +2290,7 @@ PP(pp_goto) PL_lastgotoprobe = gotoprobe; } if (!retop) - DIE("Can't find label %s", label); + DIE(aTHX_ "Can't find label %s", label); /* pop unwanted frames */ @@ -2385,9 +2314,9 @@ PP(pp_goto) /* 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("Can't \"goto\" into the middle of a foreach loop", + DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop", label); - (CALLOP->op_ppaddr)(ARGS); + CALL_FPTR(PL_op->op_ppaddr)(aTHX); } PL_op = oldop; } @@ -2432,11 +2361,11 @@ PP(pp_exit) PP(pp_nswitch) { djSP; - double value = SvNVx(GvSV(cCOP->cop_gv)); + 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; @@ -2472,7 +2401,7 @@ PP(pp_cswitch) /* Eval. */ STATIC void -save_lines(AV *array, SV *sv) +S_save_lines(pTHX_ AV *array, SV *sv) { register char *s = SvPVX(sv); register char *send = SvPVX(sv) + SvCUR(sv); @@ -2496,30 +2425,32 @@ save_lines(AV *array, SV *sv) } STATIC void * -docatch_body(va_list args) +S_docatch_body(pTHX_ va_list args) { - CALLRUNOPS(); + CALLRUNOPS(aTHX); return NULL; } STATIC OP * -docatch(OP *o) +S_docatch(pTHX_ OP *o) { dTHR; int ret; OP *oldop = PL_op; + volatile PERL_SI *cursi = PL_curstackinfo; + dJMPENV; #ifdef DEBUGGING assert(CATCH_GET == TRUE); #endif PL_op = o; redo_body: - CALLPROTECT(&ret, FUNC_NAME_TO_PTR(docatch_body)); + CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_docatch_body)); switch (ret) { case 0: break; case 3: - if (PL_restartop) { + if (PL_restartop && cursi == PL_curstackinfo) { PL_op = PL_restartop; PL_restartop = 0; goto redo_body; @@ -2535,7 +2466,7 @@ docatch(OP *o) } OP * -sv_compile_2op(SV *sv, OP** startop, char *code, AV** avp) +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. */ @@ -2556,14 +2487,14 @@ sv_compile_2op(SV *sv, OP** startop, char *code, AV** avp) /* switch to eval mode */ if (PL_curcop == &PL_compiling) { - SAVESPTR(PL_compiling.cop_stash); - PL_compiling.cop_stash = PL_curstash; + SAVECOPSTASH(&PL_compiling); + CopSTASH_set(&PL_compiling, PL_curstash); } - SAVESPTR(PL_compiling.cop_filegv); - SAVEI16(PL_compiling.cop_line); + SAVECOPFILE(&PL_compiling); + SAVECOPLINE(&PL_compiling); sprintf(tmpbuf, "_<(%.10s_eval %lu)", code, (unsigned long)++PL_evalseq); - PL_compiling.cop_filegv = gv_fetchfile(tmpbuf+2); - PL_compiling.cop_line = 1; + CopFILE_set(&PL_compiling, tmpbuf+2); + CopLINE_set(&PL_compiling, 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 @@ -2583,7 +2514,7 @@ sv_compile_2op(SV *sv, OP** startop, char *code, AV** avp) 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); + PUSHEVAL(cx, 0, Nullgv); rop = doeval(G_SCALAR, startop); POPBLOCK(cx,PL_curpm); POPEVAL(cx); @@ -2603,7 +2534,7 @@ sv_compile_2op(SV *sv, OP** startop, char *code, AV** avp) /* With USE_THREADS, eval_owner must be held on entry to doeval */ STATIC OP * -doeval(int gimme, OP** startop) +S_doeval(pTHX_ int gimme, OP** startop) { dSP; OP *saveop = PL_op; @@ -2612,7 +2543,7 @@ doeval(int gimme, OP** startop) AV* comppadlist; I32 i; - PL_in_eval = 1; + PL_in_eval = EVAL_INEVAL; PUSHMARK(SP); @@ -2673,7 +2604,7 @@ doeval(int gimme, OP** startop) /* make sure we compile in the right package */ - newstash = PL_curcop->cop_stash; + newstash = CopSTASH(PL_curcop); if (PL_curstash != newstash) { SAVESPTR(PL_curstash); PL_curstash = newstash; @@ -2691,7 +2622,7 @@ doeval(int gimme, OP** startop) SvREFCNT_dec(PL_rs); PL_rs = newSVpvn("\n", 1); if (saveop && saveop->op_flags & OPf_SPECIAL) - PL_in_eval |= 4; + PL_in_eval |= EVAL_KEEPERR; else sv_setpv(ERRSV,""); if (yyparse() || PL_error_count || !PL_eval_root) { @@ -2700,7 +2631,7 @@ doeval(int gimme, OP** startop) 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); @@ -2716,13 +2647,16 @@ doeval(int gimme, OP** startop) LEAVE; if (optype == OP_REQUIRE) { char* msg = SvPVx(ERRSV, n_a); - DIE("%s", *msg ? msg : "Compilation failed in require"); - } else if (startop) { + DIE(aTHX_ "%sCompilation failed in require", + *msg ? msg : "Unknown error\n"); + } + else if (startop) { char* msg = SvPVx(ERRSV, n_a); POPBLOCK(cx,PL_curpm); POPEVAL(cx); - croak("%sCompilation failed in regexp", (*msg ? msg : "Unknown error\n")); + Perl_croak(aTHX_ "%sCompilation failed in regexp", + (*msg ? msg : "Unknown error\n")); } SvREFCNT_dec(PL_rs); PL_rs = SvREFCNT_inc(PL_nrs); @@ -2736,7 +2670,7 @@ doeval(int gimme, OP** startop) } SvREFCNT_dec(PL_rs); PL_rs = SvREFCNT_inc(PL_nrs); - PL_compiling.cop_line = 0; + CopLINE_set(&PL_compiling, 0); if (startop) { *startop = PL_eval_root; SvREFCNT_dec(CvOUTSIDE(PL_compcv)); @@ -2754,13 +2688,13 @@ doeval(int gimme, OP** startop) /* Register with debugger: */ if (PERLDB_INTER && saveop->op_type == OP_REQUIRE) { - CV *cv = perl_get_cv("DB::postponed", FALSE); + CV *cv = get_cv("DB::postponed", FALSE); if (cv) { dSP; PUSHMARK(SP); - XPUSHs((SV*)PL_compiling.cop_filegv); + XPUSHs((SV*)CopFILEGV(&PL_compiling)); PUTBACK; - perl_call_sv((SV*)cv, G_DISCARD); + call_sv((SV*)cv, G_DISCARD); } } @@ -2780,13 +2714,13 @@ doeval(int gimme, OP** startop) } STATIC PerlIO * -doopen_pmc(const char *name, const char *mode) +S_doopen_pmc(pTHX_ const char *name, const char *mode) { STRLEN namelen = strlen(name); PerlIO *fp; - if (namelen > 3 && strcmp(name + namelen - 3, ".pm") == 0) { - SV *pmcsv = newSVpvf("%s%c", name, 'c'); + 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; @@ -2824,18 +2758,21 @@ PP(pp_require) 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(PL_patchlevel) + 0.00000999 < SvNV(sv)) - DIE("Perl %s required--this is only version %s, stopped", + 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, len); if (!(name && len > 0 && *name)) - DIE("Null filename used"); + DIE(aTHX_ "Null filename used"); TAINT_PROPER("require"); if (PL_op->op_type == OP_REQUIRE && (svp = hv_fetch(GvHVn(PL_incgv), name, len, 0)) && @@ -2844,21 +2781,9 @@ PP(pp_require) /* prepare to compile file */ - if (*name == '/' || - (*name == '.' && - (name[1] == '/' || - (name[1] == '.' && name[2] == '/'))) -#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])))) -#endif - ) + if (PERL_FILE_IS_ABSOLUTE(name) + || (*name == '.' && (name[1] == '/' || + (name[1] == '.' && name[2] == '/')))) { tryname = name; tryrsfp = doopen_pmc(name,PERL_SCRIPT_MODE); @@ -2873,49 +2798,162 @@ PP(pp_require) { namesv = NEWSV(806, 0); for (i = 0; i <= AvFILL(ar); i++) { - char *dir = SvPVx(*av_fetch(ar, i, TRUE), n_a); + 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%"UVxf"/%s", + PTR2UV(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 - TAINT_PROPER("require"); - tryname = SvPVX(namesv); - tryrsfp = doopen_pmc(tryname, PERL_SCRIPT_MODE); - 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(PL_compiling.cop_filegv); - PL_compiling.cop_filegv = gv_fetchfile(tryrsfp ? tryname : name); + SAVECOPFILE(&PL_compiling); + CopFILE_set(&PL_compiling, tryrsfp ? tryname : name); SvREFCNT_dec(namesv); if (!tryrsfp) { if (PL_op->op_type == OP_REQUIRE) { - SV *msg = sv_2mortal(newSVpvf("Can't locate %s in @INC", name)); - SV *dirmsgsv = NEWSV(0, 0); - AV *ar = GvAVn(PL_incgv); - I32 i; - 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); - sv_setpvf(dirmsgsv, " %s", dir); - sv_catsv(msg, dirmsgsv); + 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); } - sv_catpvn(msg, ")", 1); - SvREFCNT_dec(dirmsgsv); - DIE("%_", msg); + DIE(aTHX_ "Can't locate %s", msgstr); } RETPUSHUNDEF; @@ -2925,7 +2963,7 @@ PP(pp_require) /* Assume success here to prevent recursive requirement. */ (void)hv_store(GvHVn(PL_incgv), name, strlen(name), - newSVsv(GvSV(PL_compiling.cop_filegv)), 0 ); + newSVsv(CopFILESV(&PL_compiling)), 0 ); ENTER; SAVETMPS; @@ -2939,17 +2977,28 @@ PP(pp_require) SAVEHINTS(); PL_hints = 0; SAVEPPTR(PL_compiling.cop_warnings); - PL_compiling.cop_warnings = ((PL_dowarn & G_WARN_ALL_ON) ? WARN_ALL - : WARN_NONE); - - /* switch to eval mode */ + 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; + } + /* switch to eval mode */ push_return(PL_op->op_next); PUSHBLOCK(cx, CXt_EVAL, SP); - PUSHEVAL(cx, name, PL_compiling.cop_filegv); + PUSHEVAL(cx, name, Nullgv); - SAVEI16(PL_compiling.cop_line); - PL_compiling.cop_line = 0; + SAVECOPLINE(&PL_compiling); + CopLINE_set(&PL_compiling, 0); PUTBACK; #ifdef USE_THREADS @@ -2965,7 +3014,7 @@ PP(pp_require) PP(pp_dofile) { - return pp_require(ARGS); + return pp_require(); } PP(pp_entereval) @@ -2989,10 +3038,10 @@ PP(pp_entereval) /* switch to eval mode */ - SAVESPTR(PL_compiling.cop_filegv); + SAVECOPFILE(&PL_compiling); sprintf(tmpbuf, "_<(eval %lu)", (unsigned long)++PL_evalseq); - PL_compiling.cop_filegv = gv_fetchfile(tmpbuf+2); - PL_compiling.cop_line = 1; + CopFILE_set(&PL_compiling, tmpbuf+2); + CopLINE_set(&PL_compiling, 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 @@ -3003,20 +3052,19 @@ PP(pp_entereval) SAVEHINTS(); PL_hints = PL_op->op_targ; SAVEPPTR(PL_compiling.cop_warnings); - if (PL_compiling.cop_warnings != WARN_ALL - && PL_compiling.cop_warnings != WARN_NONE){ + if (!specialWARN(PL_compiling.cop_warnings)) { PL_compiling.cop_warnings = newSVsv(PL_compiling.cop_warnings) ; SAVEFREESV(PL_compiling.cop_warnings) ; } push_return(PL_op->op_next); PUSHBLOCK(cx, (CXt_EVAL|CXp_REAL), SP); - PUSHEVAL(cx, 0, PL_compiling.cop_filegv); + PUSHEVAL(cx, 0, Nullgv); /* prepare to compile string */ if (PERLDB_LINE && PL_curstash != PL_debstash) - save_lines(GvAV(PL_compiling.cop_filegv), PL_linestr); + save_lines(CopFILEAV(&PL_compiling), PL_linestr); PUTBACK; #ifdef USE_THREADS MUTEX_LOCK(&PL_eval_mutex); @@ -3065,6 +3113,7 @@ PP(pp_leaveeval) MEXTEND(mark,0); *MARK = &PL_sv_undef; } + SP = MARK; } else { /* in case LEAVE wipes old return values */ @@ -3077,35 +3126,8 @@ PP(pp_leaveeval) } PL_curpm = newpm; /* Don't pop $1 et al till now */ - /* - * 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 - */ - if (AvFILLp(PL_comppad_name) >= 0) { - 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; - } - } - } - } + if (AvFILLp(PL_comppad_name) >= 0) + free_closures(); #ifdef DEBUGGING assert(CvDEPTH(PL_compcv) == 1); @@ -3119,7 +3141,7 @@ PP(pp_leaveeval) /* Unassume the success we assumed earlier. */ char *name = cx->blk_eval.old_name; (void)hv_delete(GvHVn(PL_incgv), name, strlen(name), G_DISCARD); - retop = die("%s did not return a true value", name); + retop = Perl_die(aTHX_ "%s did not return a true value", name); /* die_where() did LEAVE, or we won't be here */ } else { @@ -3145,7 +3167,7 @@ PP(pp_entertry) PUSHEVAL(cx, 0, 0); PL_eval_root = PL_op; /* Only needed so that goto works right. */ - PL_in_eval = 1; + PL_in_eval = EVAL_INEVAL; sv_setpv(ERRSV,""); PUTBACK; return DOCATCH(PL_op->op_next); @@ -3199,7 +3221,7 @@ PP(pp_leavetry) } STATIC void -doparseform(SV *sv) +S_doparseform(pTHX_ SV *sv) { STRLEN len; register char *s = SvPV_force(sv, len); @@ -3216,7 +3238,7 @@ doparseform(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; @@ -3482,13 +3504,8 @@ struct partition_stack_entry { /* Return < 0 == 0 or > 0 as the value of elt1 is < elt2, == elt2, > elt2 */ -#ifdef PERL_OBJECT -#define qsort_cmp(elt1, elt2) \ - ((this->*compare)(array[elt1], array[elt2])) -#else #define qsort_cmp(elt1, elt2) \ - ((*compare)(array[elt1], array[elt2])) -#endif + ((*compare)(aTHXo_ array[elt1], array[elt2])) #ifdef QSORT_ORDER_GUESS #define QSORT_NOTICE_SWAP swapped++; @@ -3569,14 +3586,7 @@ doqsort_all_asserts( /* ****************************************************************** qsort */ STATIC void -#ifdef PERL_OBJECT -qsortsv(SV ** array, size_t num_elts, SVCOMPARE compare) -#else -qsortsv( - SV ** array, - size_t num_elts, - I32 (*compare)(SV *a, SV *b)) -#endif +S_qsortsv(pTHX_ SV ** array, size_t num_elts, SVCOMPARE_t compare) { register SV * temp; @@ -4066,3 +4076,236 @@ qsortsv( /* Believe it or not, the array is sorted at this point! */ } + + +#ifdef PERL_OBJECT +#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 */