X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/0453d815b8a74697ff1e5451c27aba2fe537b8e0..faa7e5bbaa1a624cf61859998ab6ab0a1323ed35:/pp_ctl.c diff --git a/pp_ctl.c b/pp_ctl.c index af6394d..42811f5 100644 --- a/pp_ctl.c +++ b/pp_ctl.c @@ -1,6 +1,6 @@ /* pp_ctl.c * - * Copyright (c) 1991-1999, Larry Wall + * Copyright (c) 1991-2000, 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. @@ -26,10 +26,23 @@ #define DOCATCH(o) ((CATCH_GET == TRUE) ? docatch(o) : (o)) +static I32 sortcv(pTHXo_ SV *a, SV *b); +static I32 sortcv_stacked(pTHXo_ SV *a, SV *b); +static I32 sortcv_xsub(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 +#define sv_cmp_static Perl_sv_cmp +#define sv_cmp_locale_static Perl_sv_cmp_locale #endif PP(pp_wantarray) @@ -101,6 +114,8 @@ PP(pp_regcomp) PL_reginterp_cnt = I32_MAX; /* Mark as safe. */ pm->op_pmflags = pm->op_pmpermflags; /* reset case sensitivity */ + if (DO_UTF8(tmpstr)) + pm->op_pmdynflags |= PMdf_UTF8; pm->op_pmregexp = CALLREGCOMP(aTHX_ t, t + len, pm); PL_reginterp_cnt = 0; /* XXXX Be extra paranoid - needed inside tie/overload accessors. */ @@ -121,9 +136,13 @@ PP(pp_regcomp) else if (strEQ("\\s+", pm->op_pmregexp->precomp)) pm->op_pmflags |= PMf_WHITE; + /* XXX runtime compiled output needs to move to the pad */ if (pm->op_pmflags & PMf_KEEP) { pm->op_private &= ~OPpRUNTIME; /* no point compiling again */ +#if !defined(USE_ITHREADS) && !defined(USE_THREADS) + /* XXX can't change the optree at runtime either */ cLOGOP->op_first->op_next = PL_op->op_next; +#endif } RETURN; } @@ -212,12 +231,12 @@ Perl_rxres_save(pTHX_ void **rsp, REGEXP *rx) *rsp = (void*)p; } - *p++ = (UV)(RX_MATCH_COPIED(rx) ? rx->subbeg : Nullch); + *p++ = PTR2UV(RX_MATCH_COPIED(rx) ? rx->subbeg : Nullch); RX_MATCH_COPIED_off(rx); *p++ = rx->nparens; - *p++ = (UV)rx->subbeg; + *p++ = PTR2UV(rx->subbeg); *p++ = (UV)rx->sublen; for (i = 0; i <= rx->nparens; ++i) { *p++ = (UV)rx->startp[i]; @@ -238,7 +257,7 @@ Perl_rxres_restore(pTHX_ void **rsp, REGEXP *rx) rx->nparens = *p++; - rx->subbeg = (char*)(*p++); + rx->subbeg = INT2PTR(char*,*p++); rx->sublen = (I32)(*p++); for (i = 0; i <= rx->nparens; ++i) { rx->startp[i] = (I32)(*p++); @@ -252,7 +271,7 @@ Perl_rxres_free(pTHX_ void **rsp) UV *p = (UV*)*rsp; if (p) { - Safefree((char*)(*p)); + Safefree(INT2PTR(char*,*p)); Safefree(p); *rsp = Null(void*); } @@ -279,11 +298,17 @@ PP(pp_formline) NV value; bool gotsome; STRLEN len; - STRLEN fudge = SvCUR(tmpForm) * (IN_UTF8 ? 3 : 1) + 1; + STRLEN fudge = SvCUR(tmpForm) * (IN_BYTE ? 1 : 3) + 1; + bool item_is_utf = FALSE; if (!SvMAGICAL(tmpForm) || !SvCOMPILED(tmpForm)) { - SvREADONLY_off(tmpForm); - doparseform(tmpForm); + if (SvREADONLY(tmpForm)) { + SvREADONLY_off(tmpForm); + doparseform(tmpForm); + SvREADONLY_on(tmpForm); + } + else + doparseform(tmpForm); } SvPV_force(PL_formtarget, len); @@ -319,9 +344,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: @@ -357,7 +382,7 @@ PP(pp_formline) case FF_CHECKNL: item = s = SvPV(sv, len); itemsize = len; - if (IN_UTF8) { + if (DO_UTF8(sv)) { itemsize = sv_len_utf8(sv); if (itemsize != len) { I32 itembytes; @@ -376,11 +401,13 @@ PP(pp_formline) break; s++; } + item_is_utf = TRUE; itemsize = s - item; sv_pos_b2u(sv, &itemsize); break; } } + item_is_utf = FALSE; if (itemsize > fieldsize) itemsize = fieldsize; send = chophere = s + itemsize; @@ -397,7 +424,7 @@ PP(pp_formline) case FF_CHECKCHOP: item = s = SvPV(sv, len); itemsize = len; - if (IN_UTF8) { + if (DO_UTF8(sv)) { itemsize = sv_len_utf8(sv); if (itemsize != len) { I32 itembytes; @@ -435,9 +462,11 @@ PP(pp_formline) itemsize = chophere - item; sv_pos_b2u(sv, &itemsize); } + item_is_utf = TRUE; break; } } + item_is_utf = FALSE; if (itemsize <= fieldsize) { send = chophere = s + itemsize; while (s < send) { @@ -493,7 +522,7 @@ PP(pp_formline) case FF_ITEM: arg = itemsize; s = item; - if (IN_UTF8) { + if (item_is_utf) { while (arg--) { if (*s & 0x80) { switch (UTF8SKIP(s)) { @@ -536,6 +565,7 @@ PP(pp_formline) case FF_LINEGLOB: item = s = SvPV(sv, len); itemsize = len; + item_is_utf = FALSE; /* XXX is this correct? */ if (itemsize) { gotsome = TRUE; send = s + itemsize; @@ -571,10 +601,10 @@ PP(pp_formline) RESTORE_NUMERIC_LOCAL(); #if defined(USE_LONG_DOUBLE) if (arg & 256) { - sprintf(t, "%#*.*Lf", + sprintf(t, "%#*.*" PERL_PRIfldbl, (int) fieldsize, (int) arg & 255, value); } else { - sprintf(t, "%*.0Lf", (int) fieldsize, value); + sprintf(t, "%*.0" PERL_PRIfldbl, (int) fieldsize, value); } #else if (arg & 256) { @@ -675,7 +705,7 @@ PP(pp_grepstart) /* SAVE_DEFSV does *not* suffice here for USE_THREADS */ SAVESPTR(DEFSV); ENTER; /* enter inner scope */ - SAVESPTR(PL_curpm); + SAVEVPTR(PL_curpm); src = PL_stack_base[*PL_markstack_ptr]; SvTEMP_off(src); @@ -745,7 +775,7 @@ PP(pp_mapwhile) SV *src; ENTER; /* enter inner scope */ - SAVESPTR(PL_curpm); + SAVEVPTR(PL_curpm); src = PL_stack_base[PL_markstack_ptr[-1]]; SvTEMP_off(src); @@ -755,120 +785,6 @@ PP(pp_mapwhile) } } -STATIC I32 -S_sv_ncmp(pTHX_ SV *a, SV *b) -{ - NV nv1 = SvNV(a); - NV nv2 = SvNV(b); - return nv1 < nv2 ? -1 : nv1 > nv2 ? 1 : 0; -} - -STATIC I32 -S_sv_i_ncmp(pTHX_ 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 -S_amagic_ncmp(pTHX_ 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(a, b); -} - -STATIC I32 -S_amagic_i_ncmp(pTHX_ 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(a, b); -} - -STATIC I32 -S_amagic_cmp(pTHX_ 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 -S_amagic_cmp_locale(pTHX_ 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); -} - PP(pp_sort) { djSP; dMARK; dORIGMARK; @@ -881,6 +797,8 @@ PP(pp_sort) I32 gimme = GIMME; OP* nextop = PL_op->op_next; I32 overloading = 0; + bool hasargs = FALSE; + I32 is_xsub = 0; if (gimme != G_ARRAY) { SP = MARK; @@ -888,50 +806,60 @@ PP(pp_sort) } ENTER; - SAVEPPTR(PL_sortcop); + SAVEVPTR(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 */ PL_sortcop = kid->op_next; - stash = PL_curcop->cop_stash; + stash = CopSTASH(PL_curcop); } else { cv = sv_2cv(*++MARK, &stash, &gv, 0); + if (cv && SvPOK(cv)) { + STRLEN n_a; + char *proto = SvPV((SV*)cv, n_a); + if (proto && strEQ(proto, "$$")) { + hasargs = TRUE; + } + } if (!(cv && CvROOT(cv))) { - if (gv) { + if (cv && CvXSUB(cv)) { + is_xsub = 1; + } + else if (gv) { SV *tmpstr = sv_newmortal(); gv_efullname3(tmpstr, gv, Nullch); - if (cv && CvXSUB(cv)) - DIE(aTHX_ "Xsub \"%s\" called in sort", SvPVX(tmpstr)); DIE(aTHX_ "Undefined sort subroutine \"%s\" called", SvPVX(tmpstr)); } - if (cv) { - if (CvXSUB(cv)) - DIE(aTHX_ "Xsub called in sort"); + else { DIE(aTHX_ "Undefined subroutine in sort"); } - DIE(aTHX_ "Not a CODE reference in sort"); } - PL_sortcop = CvSTART(cv); - SAVESPTR(CvROOT(cv)->op_ppaddr); - CvROOT(cv)->op_ppaddr = PL_ppaddr[OP_NULL]; - SAVESPTR(PL_curpad); - PL_curpad = AvARRAY((AV*)AvARRAY(CvPADLIST(cv))[1]); + if (is_xsub) + PL_sortcop = (OP*)cv; + else { + PL_sortcop = CvSTART(cv); + SAVEVPTR(CvROOT(cv)->op_ppaddr); + CvROOT(cv)->op_ppaddr = PL_ppaddr[OP_NULL]; + + SAVEVPTR(PL_curpad); + PL_curpad = AvARRAY((AV*)AvARRAY(CvPADLIST(cv))[1]); + } } } else { PL_sortcop = Nullop; - stash = PL_curcop->cop_stash; + stash = CopSTASH(PL_curcop); } up = myorigmark + 1; while (MARK < SP) { /* This may or may not shift down one here. */ /*SUPPRESS 560*/ - if (*up = *++MARK) { /* Weed out nulls. */ + if ((*up = *++MARK)) { /* Weed out nulls. */ SvTEMP_off(*up); if (!PL_sortcop && !SvPOK(*up)) { STRLEN n_a; @@ -966,7 +894,6 @@ PP(pp_sort) 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); @@ -974,7 +901,19 @@ PP(pp_sort) (void)SvREFCNT_inc(cv); /* in preparation for POPSUB */ } PL_sortcxix = cxstack_ix; - qsortsv((myorigmark+1), max, FUNC_NAME_TO_PTR(S_sortcv)); + + if (hasargs && !is_xsub) { + /* This is mostly copied from pp_entersub */ + AV *av = (AV*)PL_curpad[0]; + +#ifndef USE_THREADS + cx->blk_sub.savearray = GvAV(PL_defgv); + GvAV(PL_defgv) = (AV*)SvREFCNT_inc(av); +#endif /* USE_THREADS */ + cx->blk_sub.argarray = av; + } + qsortsv((myorigmark+1), max, + is_xsub ? sortcv_xsub : hasargs ? sortcv_stacked : sortcv); POPBLOCK(cx,PL_curpm); PL_stack_sp = newsp; @@ -988,19 +927,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(S_amagic_i_ncmp) - : FUNC_NAME_TO_PTR(S_sv_i_ncmp)) - : ( overloading - ? FUNC_NAME_TO_PTR(S_amagic_ncmp) - : FUNC_NAME_TO_PTR(S_sv_ncmp))) + ? ( overloading ? amagic_i_ncmp : sv_i_ncmp) + : ( overloading ? amagic_ncmp : sv_ncmp)) : ( (PL_op->op_private & OPpLOCALE) ? ( overloading - ? FUNC_NAME_TO_PTR(S_amagic_cmp_locale) - : FUNC_NAME_TO_PTR(Perl_sv_cmp_locale)) - : ( overloading - ? FUNC_NAME_TO_PTR(S_amagic_cmp) - : FUNC_NAME_TO_PTR(Perl_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; @@ -1077,10 +1010,12 @@ PP(pp_flop) mg_get(right); if (SvNIOKp(left) || !SvPOKp(left) || - (looks_like_number(left) && *SvPVX(left) != '0') ) + SvNIOKp(right) || !SvPOKp(right) || + (looks_like_number(left) && *SvPVX(left) != '0' && + looks_like_number(right) && *SvPVX(right) != '0')) { if (SvNV(left) < IV_MIN || SvNV(right) > IV_MAX) - Perl_croak(aTHX_ "Range iterator outside integer range"); + DIE(aTHX_ "Range iterator outside integer range"); i = SvIV(left); max = SvIV(right); if (max >= i) { @@ -1140,23 +1075,28 @@ S_dopoptolabel(pTHX_ char *label) cx = &cxstack[i]; switch (CxTYPE(cx)) { case CXt_SUBST: - if (ckWARN(WARN_UNSAFE)) - Perl_warner(aTHX_ WARN_UNSAFE, "Exiting substitution via %s", + if (ckWARN(WARN_EXITING)) + Perl_warner(aTHX_ WARN_EXITING, "Exiting substitution via %s", PL_op_name[PL_op->op_type]); break; case CXt_SUB: - if (ckWARN(WARN_UNSAFE)) - Perl_warner(aTHX_ WARN_UNSAFE, "Exiting subroutine via %s", + if (ckWARN(WARN_EXITING)) + Perl_warner(aTHX_ WARN_EXITING, "Exiting subroutine via %s", + PL_op_name[PL_op->op_type]); + break; + case CXt_FORMAT: + if (ckWARN(WARN_EXITING)) + Perl_warner(aTHX_ WARN_EXITING, "Exiting format via %s", PL_op_name[PL_op->op_type]); break; case CXt_EVAL: - if (ckWARN(WARN_UNSAFE)) - Perl_warner(aTHX_ WARN_UNSAFE, "Exiting eval via %s", + if (ckWARN(WARN_EXITING)) + Perl_warner(aTHX_ WARN_EXITING, "Exiting eval via %s", PL_op_name[PL_op->op_type]); break; case CXt_NULL: - if (ckWARN(WARN_UNSAFE)) - Perl_warner(aTHX_ WARN_UNSAFE, "Exiting pseudo-block via %s", + if (ckWARN(WARN_EXITING)) + Perl_warner(aTHX_ WARN_EXITING, "Exiting pseudo-block via %s", PL_op_name[PL_op->op_type]); return -1; case CXt_LOOP: @@ -1224,6 +1164,7 @@ S_dopoptosub_at(pTHX_ PERL_CONTEXT *cxstk, I32 startingblock) continue; case CXt_EVAL: case CXt_SUB: + case CXt_FORMAT: DEBUG_l( Perl_deb(aTHX_ "(Found sub #%ld)\n", (long)i)); return i; } @@ -1260,23 +1201,28 @@ S_dopoptoloop(pTHX_ I32 startingblock) cx = &cxstack[i]; switch (CxTYPE(cx)) { case CXt_SUBST: - if (ckWARN(WARN_UNSAFE)) - Perl_warner(aTHX_ WARN_UNSAFE, "Exiting substitution via %s", + if (ckWARN(WARN_EXITING)) + Perl_warner(aTHX_ WARN_EXITING, "Exiting substitution via %s", PL_op_name[PL_op->op_type]); break; case CXt_SUB: - if (ckWARN(WARN_UNSAFE)) - Perl_warner(aTHX_ WARN_UNSAFE, "Exiting subroutine via %s", + if (ckWARN(WARN_EXITING)) + Perl_warner(aTHX_ WARN_EXITING, "Exiting subroutine via %s", + PL_op_name[PL_op->op_type]); + break; + case CXt_FORMAT: + if (ckWARN(WARN_EXITING)) + Perl_warner(aTHX_ WARN_EXITING, "Exiting format via %s", PL_op_name[PL_op->op_type]); break; case CXt_EVAL: - if (ckWARN(WARN_UNSAFE)) - Perl_warner(aTHX_ WARN_UNSAFE, "Exiting eval via %s", + if (ckWARN(WARN_EXITING)) + Perl_warner(aTHX_ WARN_EXITING, "Exiting eval via %s", PL_op_name[PL_op->op_type]); break; case CXt_NULL: - if (ckWARN(WARN_UNSAFE)) - Perl_warner(aTHX_ WARN_UNSAFE, "Exiting pseudo-block via %s", + if (ckWARN(WARN_EXITING)) + Perl_warner(aTHX_ WARN_EXITING, "Exiting pseudo-block via %s", PL_op_name[PL_op->op_type]); return -1; case CXt_LOOP: @@ -1292,10 +1238,10 @@ Perl_dounwind(pTHX_ I32 cxix) { dTHR; register PERL_CONTEXT *cx; - SV **newsp; 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)])); @@ -1305,7 +1251,8 @@ Perl_dounwind(pTHX_ I32 cxix) POPSUBST(cx); continue; /* not break */ case CXt_SUB: - POPSUB(cx); + POPSUB(cx,sv); + LEAVESUB(sv); break; case CXt_EVAL: POPEVAL(cx); @@ -1315,6 +1262,9 @@ Perl_dounwind(pTHX_ I32 cxix) break; case CXt_NULL: break; + case CXt_FORMAT: + POPFORMAT(cx); + break; } cxstack_ix--; } @@ -1356,10 +1306,21 @@ S_free_closures(pTHX) } } +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_ "%"SVf, err); + ++PL_error_count; +} + OP * Perl_die_where(pTHX_ char *message, STRLEN msglen) { - dSP; STRLEN n_a; if (PL_in_eval) { I32 cxix; @@ -1369,26 +1330,25 @@ Perl_die_where(pTHX_ char *message, STRLEN msglen) 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); - } + 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_MISC)) { + STRLEN start = SvCUR(err)-msglen-sizeof(prefix)+1; + Perl_warner(aTHX_ WARN_MISC, SvPVX(err)+start); } - sv_inc(*svp); } } else @@ -1397,7 +1357,9 @@ Perl_die_where(pTHX_ 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; } @@ -1410,8 +1372,8 @@ Perl_die_where(pTHX_ 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); @@ -1424,7 +1386,8 @@ Perl_die_where(pTHX_ char *message, STRLEN msglen) if (optype == OP_REQUIRE) { char* msg = SvPVx(ERRSV, n_a); - DIE(aTHX_ "%s", *msg ? msg : "Compilation failed in require"); + DIE(aTHX_ "%sCompilation failed in require", + *msg ? msg : "Unknown error\n"); } return pop_return(); } @@ -1436,8 +1399,10 @@ Perl_die_where(pTHX_ 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 @@ -1483,13 +1448,13 @@ PP(pp_caller) PERL_SI *top_si = PL_curstackinfo; I32 dbcxix; I32 gimme; - HV *hv; + char *stashname; SV *sv; I32 count = 0; if (MAXARG) count = POPi; - EXTEND(SP, 7); + EXTEND(SP, 10); for (;;) { /* we may be in a higher stacklevel, so dig down deeper */ while (cxix < 0 && top_si->si_type != PERLSI_MAIN) { @@ -1511,7 +1476,7 @@ PP(pp_caller) } cx = &ccstack[cxix]; - if (CxTYPE(cx) == CXt_SUB) { + if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) { dbcxix = dopoptosub_at(ccstack, cxix - 1); /* We expect that ccstack[dbcxix] is CXt_SUB, anyway, the field below is defined for any cx. */ @@ -1519,29 +1484,28 @@ PP(pp_caller) cx = &ccstack[dbcxix]; } + stashname = CopSTASHPV(cx->blk_oldcop); if (GIMME != G_ARRAY) { - hv = cx->blk_oldcop->cop_stash; - if (!hv) + if (!stashname) PUSHs(&PL_sv_undef); else { dTARGET; - sv_setpv(TARG, HvNAME(hv)); + sv_setpv(TARG, stashname); PUSHs(TARG); } RETURN; } - hv = cx->blk_oldcop->cop_stash; - if (!hv) + if (!stashname) 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(newSVpv(stashname, 0))); + PUSHs(sv_2mortal(newSVpv(CopFILE(cx->blk_oldcop), 0))); + PUSHs(sv_2mortal(newSViv((I32)CopLINE(cx->blk_oldcop)))); if (!MAXARG) RETURN; - if (CxTYPE(cx) == CXt_SUB) { /* So is ccstack[dbcxix]. */ + if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) { + /* So is ccstack[dbcxix]. */ sv = NEWSV(49, 0); gv_efullname3(sv, CvGV(ccstack[cxix].blk_sub.cv), Nullch); PUSHs(sv_2mortal(sv)); @@ -1560,16 +1524,19 @@ PP(pp_caller) if (cx->blk_eval.old_op_type == OP_ENTEREVAL) { PUSHs(cx->blk_eval.cur_text); 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))); + } + /* try blocks have old_namesv == 0 */ + else if (cx->blk_eval.old_namesv) { + PUSHs(sv_2mortal(newSVsv(cx->blk_eval.old_namesv))); 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_eq(PL_curcop, PL_debstash)) { AV *ary = cx->blk_sub.argarray; int off = AvARRAY(ary) - AvALLOC(ary); @@ -1592,31 +1559,18 @@ PP(pp_caller) * use the global PL_hints) */ PUSHs(sv_2mortal(newSViv((I32)cx->blk_oldcop->op_private & HINT_PRIVATE_MASK))); - RETURN; -} - -STATIC I32 -S_sortcv(pTHX_ 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; + { + SV * mask ; + SV * old_warnings = cx->blk_oldcop->cop_warnings ; + if (old_warnings == WARN_NONE || old_warnings == WARN_STD) + mask = newSVpvn(WARN_NONEstring, WARNsize) ; + else if (old_warnings == WARN_ALL) + mask = newSVpvn(WARN_ALLstring, WARNsize) ; + else + mask = newSVsv(old_warnings); + PUSHs(sv_2mortal(mask)); } - leave_scope(oldsaveix); - return result; + RETURN; } PP(pp_reset) @@ -1629,7 +1583,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; } @@ -1677,7 +1631,7 @@ PP(pp_dbstate) PUSHSUB(cx); CvDEPTH(cv)++; (void)SvREFCNT_inc(cv); - SAVESPTR(PL_curpad); + SAVEVPTR(PL_curpad); PL_curpad = AvARRAY((AV*)*av_fetch(CvPADLIST(cv),1,FALSE)); RETURNOP(CvSTART(cv)); } @@ -1696,6 +1650,10 @@ PP(pp_enteriter) register PERL_CONTEXT *cx; I32 gimme = GIMME_V; SV **svp; + U32 cxtype = CXt_LOOP; +#ifdef USE_ITHREADS + void *iterdata; +#endif ENTER; SAVETMPS; @@ -1712,26 +1670,42 @@ PP(pp_enteriter) if (PL_op->op_targ) { svp = &PL_curpad[PL_op->op_targ]; /* "my" variable */ SAVESPTR(*svp); +#ifdef USE_ITHREADS + iterdata = (void*)PL_op->op_targ; + cxtype |= CXp_PADVAR; +#endif } else { - svp = &GvSV((GV*)POPs); /* symbol table variable */ + GV *gv = (GV*)POPs; + svp = &GvSV(gv); /* symbol table variable */ SAVEGENERICSV(*svp); *svp = NEWSV(0,0); +#ifdef USE_ITHREADS + iterdata = (void*)gv; +#endif } ENTER; - PUSHBLOCK(cx, CXt_LOOP, SP); + PUSHBLOCK(cx, cxtype, SP); +#ifdef USE_ITHREADS + PUSHLOOP(cx, iterdata, MARK); +#else PUSHLOOP(cx, svp, MARK); +#endif 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')) { + SvNIOKp(cx->blk_loop.iterary) || !SvPOKp(cx->blk_loop.iterary) || + (looks_like_number(sv) && *SvPVX(sv) != '0' && + looks_like_number((SV*)cx->blk_loop.iterary) && + *SvPVX(cx->blk_loop.iterary) != '0')) + { if (SvNV(sv) < IV_MIN || SvNV((SV*)cx->blk_loop.iterary) >= IV_MAX) - Perl_croak(aTHX_ "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); } @@ -1768,7 +1742,6 @@ PP(pp_leaveloop) { djSP; register PERL_CONTEXT *cx; - struct block_loop cxloop; I32 gimme; SV **newsp; PMOP *newpm; @@ -1776,7 +1749,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) @@ -1796,7 +1769,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; @@ -1810,15 +1783,17 @@ 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) { + if (cxstack_ix == PL_sortcxix + || dopoptosub(cxstack_ix) <= PL_sortcxix) + { if (cxstack_ix > PL_sortcxix) dounwind(PL_sortcxix); AvARRAY(PL_curstack)[1] = *SP; @@ -1836,7 +1811,6 @@ PP(pp_return) POPBLOCK(cx,newpm); switch (CxTYPE(cx)) { case CXt_SUB: - POPSUB1(cx); /* Delay POPSUB2 until stack values are safe */ popsub2 = TRUE; break; case CXt_EVAL: @@ -1848,11 +1822,14 @@ PP(pp_return) (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(aTHX_ "%s did not return a true value", name); + SV *nsv = cx->blk_eval.old_namesv; + (void)hv_delete(GvHVn(PL_incgv), SvPVX(nsv), SvCUR(nsv), G_DISCARD); + DIE(aTHX_ "%s did not return a true value", SvPVX(nsv)); } break; + case CXt_FORMAT: + POPFORMAT(cx); + break; default: DIE(aTHX_ "panic: return"); } @@ -1861,7 +1838,7 @@ PP(pp_return) 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; @@ -1888,11 +1865,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(); } @@ -1901,20 +1881,19 @@ 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(aTHX_ "Can't \"last\" outside a block"); + DIE(aTHX_ "Can't \"last\" outside a loop block"); } else { cxix = dopoptolabel(cPVOP->op_pv); @@ -1925,14 +1904,14 @@ PP(pp_last) 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; @@ -1940,6 +1919,10 @@ PP(pp_last) POPEVAL(cx); nextop = pop_return(); break; + case CXt_FORMAT: + POPFORMAT(cx); + nextop = pop_return(); + break; default: DIE(aTHX_ "panic: last"); } @@ -1965,16 +1948,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; } @@ -1987,7 +1971,7 @@ PP(pp_next) if (PL_op->op_flags & OPf_SPECIAL) { cxix = dopoptoloop(cxstack_ix); if (cxix < 0) - DIE(aTHX_ "Can't \"next\" outside a block"); + DIE(aTHX_ "Can't \"next\" outside a loop block"); } else { cxix = dopoptolabel(cPVOP->op_pv); @@ -1998,8 +1982,12 @@ PP(pp_next) dounwind(cxix); TOPBLOCK(cx); - oldsave = PL_scopestack[PL_scopestack_ix - 1]; - LEAVE_SCOPE(oldsave); + + /* clean scope, but only if there's no continue block */ + if (!(cx->blk_loop.last_op->op_private & OPpLOOP_CONTINUE)) { + oldsave = PL_scopestack[PL_scopestack_ix - 1]; + LEAVE_SCOPE(oldsave); + } return cx->blk_loop.next_op; } @@ -2012,7 +2000,7 @@ PP(pp_redo) if (PL_op->op_flags & OPf_SPECIAL) { cxix = dopoptoloop(cxstack_ix); if (cxix < 0) - DIE(aTHX_ "Can't \"redo\" outside a block"); + DIE(aTHX_ "Can't \"redo\" outside a loop block"); } else { cxix = dopoptolabel(cPVOP->op_pv); @@ -2063,7 +2051,7 @@ S_dofindlabel(pTHX_ OP *o, char *label, OP **opstack, OP **oplimit) (ops[-1]->op_type != OP_NEXTSTATE && ops[-1]->op_type != OP_DBSTATE))) *ops++ = kid; - if (o = dofindlabel(kid, label, ops, oplimit)) + if ((o = dofindlabel(kid, label, ops, oplimit))) return o; } } @@ -2102,7 +2090,6 @@ PP(pp_goto) SV** mark; I32 items = 0; I32 oldsave; - int arg_was_real = 0; retry: if (!CvROOT(cv) && !CvXSUB(cv)) { @@ -2134,8 +2121,8 @@ PP(pp_goto) 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 */ + if (CxTYPE(cx) == CXt_SUB && cx->blk_sub.hasargs) { + /* put @_ back onto stack */ AV* av = cx->blk_sub.argarray; items = AvFILLp(av) + 1; @@ -2147,15 +2134,17 @@ 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; - int i; #ifdef USE_THREADS av = (AV*)PL_curpad[0]; #else @@ -2183,7 +2172,7 @@ PP(pp_goto) 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); @@ -2227,9 +2216,10 @@ PP(pp_goto) AV *newpad = newAV(); SV **oldpad = AvARRAY(svp[CvDEPTH(cv)-1]); I32 ix = AvFILLp((AV*)svp[1]); + I32 names_fill = AvFILLp((AV*)svp[0]); svp = AvARRAY(svp[0]); for ( ;ix > 0; ix--) { - if (svp[ix] != &PL_sv_undef) { + if (names_fill >= ix && svp[ix] != &PL_sv_undef) { char *name = SvPVX(svp[ix]); if ((SvFLAGS(svp[ix]) & SVf_FAKE) || *name == '&') @@ -2248,6 +2238,9 @@ PP(pp_goto) SvPADMY_on(sv); } } + else if (IS_PADGV(oldpad[ix]) || IS_PADCONST(oldpad[ix])) { + av_store(newpad, ix, sv = SvREFCNT_inc(oldpad[ix])); + } else { av_store(newpad, ix, sv = NEWSV(0,0)); SvPADTMP_on(sv); @@ -2278,7 +2271,7 @@ PP(pp_goto) } } #endif /* USE_THREADS */ - SAVESPTR(PL_curpad); + SAVEVPTR(PL_curpad); PL_curpad = AvARRAY((AV*)svp[CvDEPTH(cv)]); #ifndef USE_THREADS if (cx->blk_sub.hasargs) @@ -2309,11 +2302,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); @@ -2329,7 +2318,7 @@ 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); @@ -2387,18 +2376,21 @@ PP(pp_goto) break; } /* FALL THROUGH */ + case CXt_FORMAT: case CXt_NULL: - DIE(aTHX_ "Can't \"goto\" outside a block"); + DIE(aTHX_ "Can't \"goto\" out of a pseudo block"); default: if (ix) DIE(aTHX_ "panic: goto"); gotoprobe = PL_main_root; break; } - retop = dofindlabel(gotoprobe, label, - enterops, enterops + GOTO_DEPTH); - if (retop) - break; + if (gotoprobe) { + retop = dofindlabel(gotoprobe, label, + enterops, enterops + GOTO_DEPTH); + if (retop) + break; + } PL_lastgotoprobe = gotoprobe; } if (!retop) @@ -2426,9 +2418,8 @@ 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(aTHX_ "Can't \"goto\" into the middle of a foreach loop", - label); - (CALLOP->op_ppaddr)(aTHX); + DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop"); + CALL_FPTR(PL_op->op_ppaddr)(aTHX); } PL_op = oldop; } @@ -2464,6 +2455,7 @@ PP(pp_exit) anum = 0; #endif } + PL_exit_flags |= PERL_EXIT_EXPECTED; my_exit(anum); PUSHs(&PL_sv_undef); RETURN; @@ -2536,9 +2528,17 @@ S_save_lines(pTHX_ AV *array, SV *sv) } } +#ifdef PERL_FLEXIBLE_EXCEPTIONS STATIC void * S_docatch_body(pTHX_ va_list args) { + return docatch_body(); +} +#endif + +STATIC void * +S_docatch_body(pTHX) +{ CALLRUNOPS(aTHX); return NULL; } @@ -2549,28 +2549,40 @@ 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; +#ifdef PERL_FLEXIBLE_EXCEPTIONS redo_body: - CALLPROTECT(aTHX_ &ret, FUNC_NAME_TO_PTR(S_docatch_body)); + CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_docatch_body)); +#else + JMPENV_PUSH(ret); +#endif switch (ret) { case 0: +#ifndef PERL_FLEXIBLE_EXCEPTIONS + redo_body: + docatch_body(); +#endif break; case 3: - if (PL_restartop) { + if (PL_restartop && cursi == PL_curstackinfo) { PL_op = PL_restartop; PL_restartop = 0; goto redo_body; } /* FALL THROUGH */ default: + JMPENV_POP; PL_op = oldop; JMPENV_JUMP(ret); /* NOTREACHED */ } + JMPENV_POP; PL_op = oldop; return Nullop; } @@ -2587,8 +2599,9 @@ Perl_sv_compile_2op(pTHX_ SV *sv, OP** startop, char *code, AV** avp) 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]; + OP *rop; + char tbuf[TYPE_DIGITS(long) + 12 + 10]; + char *tmpbuf = tbuf; char *safestr; ENTER; @@ -2597,14 +2610,22 @@ Perl_sv_compile_2op(pTHX_ 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; - } - 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; + SAVECOPSTASH(&PL_compiling); + CopSTASH_set(&PL_compiling, PL_curstash); + } + SAVECOPFILE(&PL_compiling); + SAVECOPLINE(&PL_compiling); + if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) { + SV *sv = sv_newmortal(); + Perl_sv_setpvf(aTHX_ sv, "_<(%.10seval %lu)[%s:%"IVdf"]", + code, (unsigned long)++PL_evalseq, + CopFILE(PL_curcop), (IV)CopLINE(PL_curcop)); + tmpbuf = SvPVX(sv); + } + else + sprintf(tmpbuf, "_<(%.10s_eval %lu)", code, (unsigned long)++PL_evalseq); + 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 @@ -2616,7 +2637,7 @@ Perl_sv_compile_2op(pTHX_ SV *sv, OP** startop, char *code, AV** avp) #ifdef OP_IN_REGISTER PL_opsave = op; #else - SAVEPPTR(PL_op); + SAVEVPTR(PL_op); #endif PL_hints = 0; @@ -2624,7 +2645,7 @@ Perl_sv_compile_2op(pTHX_ 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); @@ -2648,7 +2669,6 @@ S_doeval(pTHX_ int gimme, OP** startop) { dSP; OP *saveop = PL_op; - HV *newstash; CV *caller; AV* comppadlist; I32 i; @@ -2660,7 +2680,7 @@ S_doeval(pTHX_ int gimme, OP** startop) /* set up a scratch pad */ SAVEI32(PL_padix); - SAVESPTR(PL_curpad); + SAVEVPTR(PL_curpad); SAVESPTR(PL_comppad); SAVESPTR(PL_comppad_name); SAVEI32(PL_comppad_name_fill); @@ -2672,7 +2692,7 @@ S_doeval(pTHX_ int gimme, OP** startop) PERL_CONTEXT *cx = &cxstack[i]; if (CxTYPE(cx) == CXt_EVAL) break; - else if (CxTYPE(cx) == CXt_SUB) { + else if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) { caller = cx->blk_sub.cv; break; } @@ -2707,17 +2727,19 @@ S_doeval(pTHX_ int gimme, OP** startop) av_store(comppadlist, 1, (SV*)PL_comppad); CvPADLIST(PL_compcv) = comppadlist; - if (!saveop || saveop->op_type != OP_REQUIRE) + if (!saveop || + (saveop->op_type != OP_REQUIRE && saveop->op_type != OP_DOFILE)) + { CvOUTSIDE(PL_compcv) = (CV*)SvREFCNT_inc(caller); + } SAVEFREESV(PL_compcv); /* make sure we compile in the right package */ - newstash = PL_curcop->cop_stash; - if (PL_curstash != newstash) { + if (CopSTASH_ne(PL_curcop, PL_curstash)) { SAVESPTR(PL_curstash); - PL_curstash = newstash; + PL_curstash = CopSTASH(PL_curcop); } SAVESPTR(PL_beginav); PL_beginav = newAV(); @@ -2757,13 +2779,16 @@ S_doeval(pTHX_ int gimme, OP** startop) LEAVE; if (optype == OP_REQUIRE) { char* msg = SvPVx(ERRSV, n_a); - DIE(aTHX_ "%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); - Perl_croak(aTHX_ "%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); @@ -2777,7 +2802,7 @@ S_doeval(pTHX_ 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)); @@ -2799,7 +2824,7 @@ S_doeval(pTHX_ int gimme, OP** startop) if (cv) { dSP; PUSHMARK(SP); - XPUSHs((SV*)PL_compiling.cop_filegv); + XPUSHs((SV*)CopFILEGV(&PL_compiling)); PUTBACK; call_sv((SV*)cv, G_DISCARD); } @@ -2865,12 +2890,62 @@ 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)) { - 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); + if (SvNIOKp(sv)) { + UV rev, ver, sver; + if (SvPOKp(sv)) { /* require v5.6.1 */ + I32 len; + U8 *s = (U8*)SvPVX(sv); + U8 *end = (U8*)SvPVX(sv) + SvCUR(sv); + if (s < end) { + rev = utf8_to_uv(s, &len); + s += len; + if (s < end) { + ver = utf8_to_uv(s, &len); + s += len; + if (s < end) + sver = utf8_to_uv(s, &len); + else + sver = 0; + } + else + ver = 0; + } + else + rev = 0; + if (PERL_REVISION < rev + || (PERL_REVISION == rev + && (PERL_VERSION < ver + || (PERL_VERSION == ver + && PERL_SUBVERSION < sver)))) + { + DIE(aTHX_ "Perl v%"UVuf".%"UVuf".%"UVuf" required--this is only version " + "v%d.%d.%d, stopped", rev, ver, sver, PERL_REVISION, + PERL_VERSION, PERL_SUBVERSION); + } + } + else if (!SvPOKp(sv)) { /* require 5.005_03 */ + if ((NV)PERL_REVISION + ((NV)PERL_VERSION/(NV)1000) + + ((NV)PERL_SUBVERSION/(NV)1000000) + + 0.00000099 < SvNV(sv)) + { + NV nrev = SvNV(sv); + UV rev = (UV)nrev; + NV nver = (nrev - rev) * 1000; + UV ver = (UV)(nver + 0.0009); + NV nsver = (nver - ver) * 1000; + UV sver = (UV)(nsver + 0.0009); + + DIE(aTHX_ "Perl v%"UVuf".%"UVuf".%"UVuf" required--this is only version " + "v%d.%d.%d, stopped", rev, ver, sver, PERL_REVISION, + PERL_VERSION, PERL_SUBVERSION); + } + } RETPUSHYES; } name = SvPV(sv, len); @@ -2884,21 +2959,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); @@ -2913,29 +2976,137 @@ 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 - Perl_sv_setpvf(aTHX_ 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) { @@ -2970,7 +3141,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 ); + newSVpv(CopFILE(&PL_compiling), 0), 0 ); ENTER; SAVETMPS; @@ -2979,26 +3150,31 @@ PP(pp_require) PL_rsfp_filters = Nullav; PL_rsfp = tryrsfp; - name = savepv(name); - SAVEFREEPV(name); SAVEHINTS(); PL_hints = 0; - SAVEPPTR(PL_compiling.cop_warnings); + SAVESPTR(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 ; - - /* switch to eval mode */ + 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 @@ -3023,7 +3199,8 @@ PP(pp_entereval) register PERL_CONTEXT *cx; dPOPss; I32 gimme = GIMME_V, was = PL_sub_generation; - char tmpbuf[TYPE_DIGITS(long) + 12]; + char tbuf[TYPE_DIGITS(long) + 12]; + char *tmpbuf = tbuf; char *safestr; STRLEN len; OP *ret; @@ -3038,10 +3215,18 @@ PP(pp_entereval) /* switch to eval mode */ - 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; + SAVECOPFILE(&PL_compiling); + if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) { + SV *sv = sv_newmortal(); + Perl_sv_setpvf(aTHX_ sv, "_<(eval %lu)[%s:%"IVdf"]", + (unsigned long)++PL_evalseq, + CopFILE(PL_curcop), (IV)CopLINE(PL_curcop)); + tmpbuf = SvPVX(sv); + } + else + sprintf(tmpbuf, "_<(eval %lu)", (unsigned long)++PL_evalseq); + 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 @@ -3051,7 +3236,7 @@ PP(pp_entereval) SAVEDELETE(PL_defstash, safestr, strlen(safestr)); SAVEHINTS(); PL_hints = PL_op->op_targ; - SAVEPPTR(PL_compiling.cop_warnings); + SAVESPTR(PL_compiling.cop_warnings); if (!specialWARN(PL_compiling.cop_warnings)) { PL_compiling.cop_warnings = newSVsv(PL_compiling.cop_warnings) ; SAVEFREESV(PL_compiling.cop_warnings) ; @@ -3059,12 +3244,12 @@ PP(pp_entereval) 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); @@ -3113,6 +3298,7 @@ PP(pp_leaveeval) MEXTEND(mark,0); *MARK = &PL_sv_undef; } + SP = MARK; } else { /* in case LEAVE wipes old return values */ @@ -3138,9 +3324,9 @@ PP(pp_leaveeval) !(gimme == G_SCALAR ? SvTRUE(*SP) : SP > newsp)) { /* 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 = Perl_die(aTHX_ "%s did not return a true value", name); + SV *nsv = cx->blk_eval.old_namesv; + (void)hv_delete(GvHVn(PL_incgv), SvPVX(nsv), SvCUR(nsv), G_DISCARD); + retop = Perl_die(aTHX_ "%s did not return a true value", SvPVX(nsv)); /* die_where() did LEAVE, or we won't be here */ } else { @@ -3503,13 +3689,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)(aTHX_ array[elt1], array[elt2])) -#endif + ((*compare)(aTHXo_ array[elt1], array[elt2])) #ifdef QSORT_ORDER_GUESS #define QSORT_NOTICE_SWAP swapped++; @@ -3818,7 +3999,7 @@ S_qsortsv(pTHX_ SV ** array, size_t num_elts, SVCOMPARE_t compare) 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)) { + while ((still_work_on_left = (u_right >= part_left))) { s = qsort_cmp(u_right, pc_left); if (s < 0) { --u_right; @@ -3839,7 +4020,7 @@ S_qsortsv(pTHX_ SV ** array, size_t num_elts, SVCOMPARE_t compare) /* Do a mirror image scan of uncompared values on the right */ - while (still_work_on_right = (u_left <= part_right)) { + while ((still_work_on_right = (u_left <= part_right))) { s = qsort_cmp(pc_right, u_left); if (s < 0) { ++u_left; @@ -4080,3 +4261,310 @@ S_qsortsv(pTHX_ SV ** array, size_t num_elts, SVCOMPARE_t compare) /* 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 +sortcv_stacked(pTHXo_ SV *a, SV *b) +{ + dTHR; + I32 oldsaveix = PL_savestack_ix; + I32 oldscopeix = PL_scopestack_ix; + I32 result; + AV *av; + +#ifdef USE_THREADS + av = (AV*)PL_curpad[0]; +#else + av = GvAV(PL_defgv); +#endif + + if (AvMAX(av) < 1) { + SV** ary = AvALLOC(av); + if (AvARRAY(av) != ary) { + AvMAX(av) += AvARRAY(av) - AvALLOC(av); + SvPVX(av) = (char*)ary; + } + if (AvMAX(av) < 1) { + AvMAX(av) = 1; + Renew(ary,2,SV*); + SvPVX(av) = (char*)ary; + } + } + AvFILLp(av) = 1; + + AvARRAY(av)[0] = a; + AvARRAY(av)[1] = 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 +sortcv_xsub(pTHXo_ SV *a, SV *b) +{ + dSP; + I32 oldsaveix = PL_savestack_ix; + I32 oldscopeix = PL_scopestack_ix; + I32 result; + CV *cv=(CV*)PL_sortcop; + + SP = PL_stack_base; + PUSHMARK(SP); + EXTEND(SP, 2); + *++SP = a; + *++SP = b; + PUTBACK; + (void)(*CvXSUB(cv))(aTHXo_ cv); + 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 */