X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=pp_ctl.c;h=75673dc50face0cad016efb0e1bfdd86457b558f;hb=544f31531e7cbe3b4e7571d94c56f36d53f647fa;hp=f94bd54b895fb8892b5382acaefd70ec5182f6f8;hpb=2c15bef39460c09b2a7846a30a4fc1fc1c4f93e4;p=p5sagit%2Fp5-mst-13.2.git diff --git a/pp_ctl.c b/pp_ctl.c index f94bd54..75673dc 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,19 +26,17 @@ #define DOCATCH(o) ((CATCH_GET == TRUE) ? docatch(o) : (o)) -#ifdef PERL_OBJECT -#define CALLOP this->*PL_op -#else -#define CALLOP *PL_op -#endif - 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 static I32 sv_cmp_static(pTHXo_ SV *a, SV *b); static I32 sv_cmp_locale_static(pTHXo_ SV *a, SV *b); @@ -116,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. */ @@ -136,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; } @@ -227,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]; @@ -253,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++); @@ -267,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*); } @@ -294,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); @@ -334,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: @@ -372,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; @@ -391,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; @@ -412,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; @@ -450,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) { @@ -508,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)) { @@ -551,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; @@ -586,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) { @@ -690,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); @@ -710,36 +725,49 @@ PP(pp_mapstart) PP(pp_mapwhile) { djSP; - I32 diff = (SP - PL_stack_base) - *PL_markstack_ptr; + I32 items = (SP - PL_stack_base) - *PL_markstack_ptr; /* how many new items */ I32 count; I32 shift; SV** src; SV** dst; + /* first, move source pointer to the next item in the source list */ ++PL_markstack_ptr[-1]; - if (diff) { - if (diff > PL_markstack_ptr[-1] - PL_markstack_ptr[-2]) { - shift = diff - (PL_markstack_ptr[-1] - PL_markstack_ptr[-2]); - count = (SP - PL_stack_base) - PL_markstack_ptr[-1] + 2; + + /* if there are new items, push them into the destination list */ + if (items) { + /* might need to make room back there first */ + if (items > PL_markstack_ptr[-1] - PL_markstack_ptr[-2]) { + /* XXX this implementation is very pessimal because the stack + * is repeatedly extended for every set of items. Is possible + * to do this without any stack extension or copying at all + * by maintaining a separate list over which the map iterates + * (like foreach does). */ + + /* everything in the stack after the destination list moves + * towards the end the stack by the amount of room needed */ + shift = items - (PL_markstack_ptr[-1] - PL_markstack_ptr[-2]); + + /* items to shift up (accounting for the moved source pointer) */ + count = (SP - PL_stack_base) - (PL_markstack_ptr[-1] - 1); EXTEND(SP,shift); src = SP; dst = (SP += shift); PL_markstack_ptr[-1] += shift; *PL_markstack_ptr += shift; - while (--count) + while (count--) *dst-- = *src--; } - dst = PL_stack_base + (PL_markstack_ptr[-2] += diff) - 1; - ++diff; - while (--diff) + /* copy the new items down to the destination list */ + dst = PL_stack_base + (PL_markstack_ptr[-2] += items) - 1; + while (items--) *dst-- = SvTEMP(TOPs) ? POPs : sv_mortalcopy(POPs); } LEAVE; /* exit inner scope */ /* All done yet? */ if (PL_markstack_ptr[-1] > *PL_markstack_ptr) { - I32 items; I32 gimme = GIMME_V; (void)POPMARK; /* pop top */ @@ -760,8 +788,9 @@ PP(pp_mapwhile) SV *src; ENTER; /* enter inner scope */ - SAVESPTR(PL_curpm); + SAVEVPTR(PL_curpm); + /* set $_ to the new source item */ src = PL_stack_base[PL_markstack_ptr[-1]]; SvTEMP_off(src); DEFSV = src; @@ -782,6 +811,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; @@ -789,50 +820,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; @@ -856,18 +897,24 @@ PP(pp_sort) CATCH_SET(TRUE); PUSHSTACKi(PERLSI_SORT); - if (PL_sortstash != stash) { - PL_firstgv = gv_fetchpv("a", TRUE, SVt_PV); - PL_secondgv = gv_fetchpv("b", TRUE, SVt_PV); - PL_sortstash = stash; + if (!hasargs && !is_xsub) { + if (PL_sortstash != stash || !PL_firstgv || !PL_secondgv) { + SAVESPTR(PL_firstgv); + SAVESPTR(PL_secondgv); + PL_firstgv = gv_fetchpv("a", TRUE, SVt_PV); + PL_secondgv = gv_fetchpv("b", TRUE, SVt_PV); + PL_sortstash = stash; + } +#ifdef USE_THREADS + sv_lock((SV *)PL_firstgv); + sv_lock((SV *)PL_secondgv); +#endif + SAVESPTR(GvSV(PL_firstgv)); + SAVESPTR(GvSV(PL_secondgv)); } - SAVESPTR(GvSV(PL_firstgv)); - SAVESPTR(GvSV(PL_secondgv)); - 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); @@ -875,7 +922,20 @@ PP(pp_sort) (void)SvREFCNT_inc(cv); /* in preparation for POPSUB */ } PL_sortcxix = cxstack_ix; - qsortsv((myorigmark+1), max, 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.oldcurpad = PL_curpad; + 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; @@ -972,10 +1032,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) { @@ -1035,23 +1097,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: @@ -1119,6 +1186,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; } @@ -1155,23 +1223,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: @@ -1187,10 +1260,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)])); @@ -1200,7 +1273,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); @@ -1210,6 +1284,9 @@ Perl_dounwind(pTHX_ I32 cxix) break; case CXt_NULL: break; + case CXt_FORMAT: + POPFORMAT(cx); + break; } cxstack_ix--; } @@ -1251,10 +1328,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; @@ -1264,26 +1352,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 @@ -1292,7 +1379,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; } @@ -1305,8 +1394,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); @@ -1319,7 +1408,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(); } @@ -1331,8 +1421,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 @@ -1378,13 +1470,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) { @@ -1406,7 +1498,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. */ @@ -1414,29 +1506,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)); @@ -1452,19 +1543,28 @@ PP(pp_caller) else PUSHs(sv_2mortal(newSViv(gimme & G_ARRAY))); if (CxTYPE(cx) == CXt_EVAL) { + /* eval STRING */ 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))); + } + /* require */ + else if (cx->blk_eval.old_namesv) { + PUSHs(sv_2mortal(newSVsv(cx->blk_eval.old_namesv))); PUSHs(&PL_sv_yes); } + /* eval BLOCK (try blocks have old_namesv == 0) */ + else { + PUSHs(&PL_sv_undef); + PUSHs(&PL_sv_undef); + } } - 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); @@ -1474,7 +1574,7 @@ PP(pp_caller) PL_dbargs = GvAV(gv_AVadd(tmpgv = gv_fetchpv("DB::args", TRUE, SVt_PVAV))); GvMULTI_on(tmpgv); - AvREAL_off(PL_dbargs); /* XXX Should be REIFY */ + AvREAL_off(PL_dbargs); /* XXX should be REIFY (see av.h) */ } if (AvMAX(PL_dbargs) < AvFILLp(ary) + off) @@ -1487,6 +1587,20 @@ PP(pp_caller) * use the global PL_hints) */ PUSHs(sv_2mortal(newSViv((I32)cx->blk_oldcop->op_private & HINT_PRIVATE_MASK))); + { + SV * mask ; + SV * old_warnings = cx->blk_oldcop->cop_warnings ; + + if (old_warnings == pWARN_NONE || + (old_warnings == pWARN_STD && (PL_dowarn & G_WARN_ON) == 0)) + mask = newSVpvn(WARN_NONEstring, WARNsize) ; + else if (old_warnings == pWARN_ALL || + (old_warnings == pWARN_STD && PL_dowarn & G_WARN_ON)) + mask = newSVpvn(WARN_ALLstring, WARNsize) ; + else + mask = newSVsv(old_warnings); + PUSHs(sv_2mortal(mask)); + } RETURN; } @@ -1500,7 +1614,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; } @@ -1548,7 +1662,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)); } @@ -1567,6 +1681,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; @@ -1583,26 +1701,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); } @@ -1639,7 +1773,6 @@ PP(pp_leaveloop) { djSP; register PERL_CONTEXT *cx; - struct block_loop cxloop; I32 gimme; SV **newsp; PMOP *newpm; @@ -1647,7 +1780,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) @@ -1667,7 +1800,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; @@ -1681,15 +1814,18 @@ PP(pp_return) djSP; dMARK; I32 cxix; register PERL_CONTEXT *cx; - struct block_sub cxsub; bool popsub2 = FALSE; + bool clear_errsv = 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; @@ -1707,11 +1843,14 @@ 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: + if (!(PL_in_eval & EVAL_KEEPERR)) + clear_errsv = TRUE; POPEVAL(cx); + if (CxTRYBLOCK(cx)) + break; if (AvFILLp(PL_comppad_name) >= 0) free_closures(); lex_end(); @@ -1719,11 +1858,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"); } @@ -1732,20 +1874,26 @@ 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; sv_2mortal(*newsp); - } else { + } + else { + sv = SvREFCNT_inc(*SP); /* FREETMPS could clobber it */ FREETMPS; - *++newsp = sv_mortalcopy(*SP); + *++newsp = sv_mortalcopy(sv); + SvREFCNT_dec(sv); } - } else + } + else *++newsp = (SvTEMP(*SP)) ? *SP : sv_mortalcopy(*SP); - } else + } + else *++newsp = sv_mortalcopy(*SP); - } else + } + else *++newsp = &PL_sv_undef; } else if (gimme == G_ARRAY) { @@ -1759,11 +1907,16 @@ 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); + if (clear_errsv) + sv_setpv(ERRSV,""); return pop_return(); } @@ -1772,20 +1925,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); @@ -1796,14 +1948,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; @@ -1811,6 +1963,10 @@ PP(pp_last) POPEVAL(cx); nextop = pop_return(); break; + case CXt_FORMAT: + POPFORMAT(cx); + nextop = pop_return(); + break; default: DIE(aTHX_ "panic: last"); } @@ -1836,16 +1992,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; } @@ -1853,12 +2010,12 @@ PP(pp_next) { I32 cxix; register PERL_CONTEXT *cx; - I32 oldsave; + I32 inner; 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); @@ -1868,9 +2025,12 @@ PP(pp_next) if (cxix < cxstack_ix) dounwind(cxix); + /* clear off anything above the scope we're re-entering, but + * save the rest until after a possible continue block */ + inner = PL_scopestack_ix; TOPBLOCK(cx); - oldsave = PL_scopestack[PL_scopestack_ix - 1]; - LEAVE_SCOPE(oldsave); + if (PL_scopestack_ix < inner) + leave_scope(PL_scopestack[PL_scopestack_ix]); return cx->blk_loop.next_op; } @@ -1883,7 +2043,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); @@ -1916,32 +2076,29 @@ S_dofindlabel(pTHX_ OP *o, char *label, OP **opstack, OP **oplimit) *ops++ = cUNOPo->op_first; if (ops >= oplimit) Perl_croak(aTHX_ too_deep); - *ops = 0; } + *ops = 0; if (o->op_flags & OPf_KIDS) { dTHR; /* First try all the kids at this level, since that's likeliest. */ for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) { - if ((kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) - && kCOP->cop_label && strEQ(kCOP->cop_label, label)) - { + if ((kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) && + kCOP->cop_label && strEQ(kCOP->cop_label, label)) return kid; - } } for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) { if (kid == PL_lastgotoprobe) continue; - if ((kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) - && (ops == opstack || (ops[-1]->op_type != OP_NEXTSTATE - && ops[-1]->op_type != OP_DBSTATE))) - { + if ((kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) && + (ops == opstack || + (ops[-1]->op_type != OP_NEXTSTATE && + ops[-1]->op_type != OP_DBSTATE))) *ops++ = kid; - *ops = 0; - } - if (o = dofindlabel(kid, label, ops, oplimit)) + if ((o = dofindlabel(kid, label, ops, oplimit))) return o; } } + *ops = 0; return 0; } @@ -1976,7 +2133,6 @@ PP(pp_goto) SV** mark; I32 items = 0; I32 oldsave; - int arg_was_real = 0; retry: if (!CvROOT(cv) && !CvXSUB(cv)) { @@ -2008,8 +2164,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; @@ -2021,15 +2177,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 @@ -2057,7 +2215,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); @@ -2101,9 +2259,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 == '&') @@ -2122,6 +2281,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); @@ -2152,7 +2314,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) @@ -2165,6 +2327,7 @@ PP(pp_goto) cx->blk_sub.savearray = GvAV(PL_defgv); GvAV(PL_defgv) = (AV*)SvREFCNT_inc(av); #endif /* USE_THREADS */ + cx->blk_sub.oldcurpad = PL_curpad; cx->blk_sub.argarray = av; ++mark; @@ -2183,11 +2346,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); @@ -2203,7 +2362,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); @@ -2261,18 +2420,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) @@ -2300,9 +2462,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; } @@ -2333,11 +2494,12 @@ PP(pp_exit) anum = 0; else { anum = SvIVx(POPs); -#ifdef VMSISH_EXIT - if (anum == 1 && VMSISH_EXIT) +#ifdef VMS + if (anum == 1 && (PL_op->op_private & OPpEXIT_VMSISH)) anum = 0; #endif } + PL_exit_flags |= PERL_EXIT_EXPECTED; my_exit(anum); PUSHs(&PL_sv_undef); RETURN; @@ -2410,9 +2572,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; } @@ -2423,28 +2593,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, MEMBER_TO_FPTR(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; } @@ -2461,8 +2643,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; @@ -2471,14 +2654,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; + SAVECOPSTASH_FREE(&PL_compiling); + CopSTASH_set(&PL_compiling, PL_curstash); + } + 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); } - 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; + else + sprintf(tmpbuf, "_<(%.10s_eval %lu)", code, (unsigned long)++PL_evalseq); + SAVECOPFILE_FREE(&PL_compiling); + CopFILE_set(&PL_compiling, tmpbuf+2); + SAVECOPLINE(&PL_compiling); + 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 @@ -2490,7 +2681,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; @@ -2498,7 +2689,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); @@ -2522,7 +2713,6 @@ S_doeval(pTHX_ int gimme, OP** startop) { dSP; OP *saveop = PL_op; - HV *newstash; CV *caller; AV* comppadlist; I32 i; @@ -2534,7 +2724,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); @@ -2546,7 +2736,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; } @@ -2581,21 +2771,24 @@ 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(); SAVEFREESV(PL_beginav); + SAVEI32(PL_error_count); /* try to compile it */ @@ -2631,13 +2824,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); @@ -2651,7 +2847,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)); @@ -2673,7 +2869,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); } @@ -2739,13 +2935,69 @@ 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); - RETPUSHYES; + if (SvNIOKp(sv)) { + if (SvPOK(sv) && SvNOK(sv)) { /* require v5.6.1 */ + UV rev = 0, ver = 0, sver = 0; + 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); + } + } + 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 " + "v%d.%d.%d, stopped", rev, ver, sver, PERL_REVISION, + PERL_VERSION, PERL_SUBVERSION); + } + RETPUSHYES; + } + 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); + + /* help out with the "use 5.6" confusion */ + if (sver == 0 && (rev > 5 || (rev == 5 && ver >= 100))) { + DIE(aTHX_ "Perl v%"UVuf".%"UVuf".%"UVuf" required--" + "this is only v%d.%d.%d, stopped" + " (did you mean v%"UVuf".%"UVuf".0?)", + rev, ver, sver, PERL_REVISION, PERL_VERSION, + PERL_SUBVERSION, rev, ver/100); + } + else { + DIE(aTHX_ "Perl v%"UVuf".%"UVuf".%"UVuf" required--" + "this is only v%d.%d.%d, stopped", + rev, ver, sver, PERL_REVISION, PERL_VERSION, + PERL_SUBVERSION); + } + } + RETPUSHYES; + } } name = SvPV(sv, len); if (!(name && len > 0 && *name)) @@ -2758,26 +3010,25 @@ 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); +#ifdef MACOS_TRADITIONAL + /* We consider paths of the form :a:b ambiguous and interpret them first + as global then as local + */ + if (!tryrsfp && name[0] == ':' && name[1] != ':' && strchr(name+2, ':')) + goto trylocal; + } + else +trylocal: { +#else } else { +#endif AV *ar = GvAVn(PL_incgv); I32 i; #ifdef VMS @@ -2787,29 +3038,150 @@ 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 MACOS_TRADITIONAL + /* We have ensured in incpush that library ends with ':' */ + Perl_sv_setpvf(aTHX_ namesv, "%s%s", dir, name+(name[0] == ':')); +#else #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; +#endif + TAINT_PROPER("require"); + tryname = SvPVX(namesv); +#ifdef MACOS_TRADITIONAL + { + /* Convert slashes in the name part, but not the directory part, to colons */ + char * colon; + for (colon = tryname+strlen(dir); colon = strchr(colon, '/'); ) + *colon++ = ':'; + } +#endif + 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_FREE(&PL_compiling); + CopFILE_set(&PL_compiling, tryrsfp ? tryname : name); SvREFCNT_dec(namesv); if (!tryrsfp) { if (PL_op->op_type == OP_REQUIRE) { @@ -2844,7 +3216,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; @@ -2853,26 +3225,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 ; + PL_compiling.cop_warnings = pWARN_ALL ; else if (PL_dowarn & G_WARN_ALL_OFF) - PL_compiling.cop_warnings = WARN_NONE ; + PL_compiling.cop_warnings = pWARN_NONE ; else - PL_compiling.cop_warnings = WARN_STD ; - - /* switch to eval mode */ + PL_compiling.cop_warnings = pWARN_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 @@ -2897,7 +3274,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; @@ -2912,10 +3290,19 @@ 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; + 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); + SAVECOPFILE_FREE(&PL_compiling); + CopFILE_set(&PL_compiling, tmpbuf+2); + SAVECOPLINE(&PL_compiling); + 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 @@ -2925,20 +3312,22 @@ PP(pp_entereval) SAVEDELETE(PL_defstash, safestr, strlen(safestr)); SAVEHINTS(); PL_hints = PL_op->op_targ; - SAVEPPTR(PL_compiling.cop_warnings); - if (!specialWARN(PL_compiling.cop_warnings)) { - PL_compiling.cop_warnings = newSVsv(PL_compiling.cop_warnings) ; - SAVEFREESV(PL_compiling.cop_warnings) ; + SAVESPTR(PL_compiling.cop_warnings); + if (specialWARN(PL_curcop->cop_warnings)) + PL_compiling.cop_warnings = PL_curcop->cop_warnings; + else { + PL_compiling.cop_warnings = newSVsv(PL_curcop->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); @@ -2987,6 +3376,7 @@ PP(pp_leaveeval) MEXTEND(mark,0); *MARK = &PL_sv_undef; } + SP = MARK; } else { /* in case LEAVE wipes old return values */ @@ -3012,9 +3402,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 { @@ -3036,7 +3426,7 @@ PP(pp_entertry) SAVETMPS; push_return(cLOGOP->op_other->op_next); - PUSHBLOCK(cx, CXt_EVAL, SP); + PUSHBLOCK(cx, (CXt_EVAL|CXp_TRYBLOCK), SP); PUSHEVAL(cx, 0, 0); PL_eval_root = PL_op; /* Only needed so that goto works right. */ @@ -3687,7 +4077,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; @@ -3708,7 +4098,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; @@ -3952,7 +4342,6 @@ S_qsortsv(pTHX_ SV ** array, size_t num_elts, SVCOMPARE_t compare) #ifdef PERL_OBJECT -#define NO_XSLOCKS #undef this #define this pPerl #include "XSUB.h" @@ -3983,6 +4372,80 @@ sortcv(pTHXo_ SV *a, SV *b) 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) @@ -4098,6 +4561,76 @@ amagic_cmp_locale(pTHXo_ register SV *str1, register SV *str2) 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