X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=pp_ctl.c;h=c8dd1aebe0ff3301bb26fa40b7555d7d9f59e6d4;hb=2c8ddff3c182e26372c9343750c9b3c45e438ca2;hp=0b006855b7c587280536ff4443507cd18adf80f8;hpb=a89be09a10c36299e755a956d356eb7f1f643437;p=p5sagit%2Fp5-mst-13.2.git diff --git a/pp_ctl.c b/pp_ctl.c index 0b00685..c8dd1ae 100644 --- a/pp_ctl.c +++ b/pp_ctl.c @@ -1,6 +1,7 @@ /* pp_ctl.c * - * Copyright (c) 1991-2003, Larry Wall + * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, + * 2000, 2001, 2002, 2003, 2004, by Larry Wall and others * * You may distribute under the terms of either the GNU General Public * License or the Artistic License, as specified in the README file. @@ -21,7 +22,7 @@ #include "perl.h" #ifndef WORD_ALIGN -#define WORD_ALIGN sizeof(U16) +#define WORD_ALIGN sizeof(U32) #endif #define DOCATCH(o) ((CATCH_GET == TRUE) ? docatch(o) : (o)) @@ -58,6 +59,7 @@ PP(pp_regcreset) /* XXXX Should store the old value to allow for tie/overload - and restore in regcomp, where marked with XXXX. */ PL_reginterp_cnt = 0; + TAINT_NOT; return NORMAL; } @@ -97,7 +99,7 @@ PP(pp_regcomp) memNE(PM_GETRE(pm)->precomp, t, len)) { if (PM_GETRE(pm)) { - ReREFCNT_dec(PM_GETRE(pm)); + ReREFCNT_dec(PM_GETRE(pm)); PM_SETRE(pm, Null(REGEXP*)); /* crucial if regcomp aborts */ } if (PL_op->op_flags & OPf_SPECIAL) @@ -157,6 +159,12 @@ PP(pp_substcont) char *orig = cx->sb_orig; register REGEXP *rx = cx->sb_rx; SV *nsv = Nullsv; + REGEXP *old = PM_GETRE(pm); + if(old != rx) { + if(old) + ReREFCNT_dec(old); + PM_SETRE(pm,rx); + } rxres_restore(&cx->sb_rxres, rx); RX_MATCH_UTF8_set(rx, SvUTF8(cx->sb_targ)); @@ -179,10 +187,13 @@ PP(pp_substcont) { SV *targ = cx->sb_targ; - if (DO_UTF8(dstr) && !SvUTF8(targ)) - sv_catpvn_utf8_upgrade(dstr, s, cx->sb_strend - s, nsv); - else - sv_catpvn(dstr, s, cx->sb_strend - s); + assert(cx->sb_strend >= s); + if(cx->sb_strend > s) { + if (DO_UTF8(dstr) && !SvUTF8(targ)) + sv_catpvn_utf8_upgrade(dstr, s, cx->sb_strend - s, nsv); + else + sv_catpvn(dstr, s, cx->sb_strend - s); + } cx->sb_rxtainted |= RX_MATCH_TAINTED(rx); #ifdef PERL_COPY_ON_WRITE @@ -212,6 +223,7 @@ PP(pp_substcont) SvTAINT(targ); LEAVE_SCOPE(cx->sb_oldsave); + ReREFCNT_dec(rx); POPSUBST(cx); RETURNOP(pm->op_next); } @@ -247,6 +259,8 @@ PP(pp_substcont) sv_pos_b2u(sv, &i); mg->mg_len = i; } + if (old != rx) + ReREFCNT_inc(rx); cx->sb_rxtainted |= RX_MATCH_TAINTED(rx); rxres_save(&cx->sb_rxres, rx); RETURNOP(pm->op_pmreplstart); @@ -337,7 +351,7 @@ PP(pp_formline) { dSP; dMARK; dORIGMARK; register SV *tmpForm = *++MARK; - register U16 *fpc; + register U32 *fpc; register char *t; register char *f; register char *s; @@ -358,15 +372,20 @@ PP(pp_formline) bool item_is_utf8 = FALSE; bool targ_is_utf8 = FALSE; SV * nsv = Nullsv; + OP * parseres = 0; + char *fmt; + bool oneline; if (!SvMAGICAL(tmpForm) || !SvCOMPILED(tmpForm)) { if (SvREADONLY(tmpForm)) { SvREADONLY_off(tmpForm); - doparseform(tmpForm); + parseres = doparseform(tmpForm); SvREADONLY_on(tmpForm); } else - doparseform(tmpForm); + parseres = doparseform(tmpForm); + if (parseres) + return parseres; } SvPV_force(PL_formtarget, len); if (DO_UTF8(PL_formtarget)) @@ -377,7 +396,7 @@ PP(pp_formline) /* need to jump to the next word */ s = f + len + WORD_ALIGN - SvCUR(tmpForm) % WORD_ALIGN; - fpc = (U16*)s; + fpc = (U32*)s; for (;;) { DEBUG_f( { @@ -402,6 +421,7 @@ PP(pp_formline) case FF_LINEMARK: name = "LINEMARK"; break; case FF_END: name = "END"; break; case FF_0DECIMAL: name = "0DECIMAL"; break; + case FF_LINESNGL: name = "LINESNGL"; break; } if (arg >= 0) PerlIO_printf(Perl_debug_log, "%-16s%ld\n", name, (long) arg); @@ -508,6 +528,7 @@ PP(pp_formline) while (s < send) { if (*s == '\r') { itemsize = s - item; + chophere = s; break; } if (*s++ & ~31) @@ -547,6 +568,7 @@ PP(pp_formline) while (s < send) { if (*s == '\r') { itemsize = s - item; + chophere = s; break; } if (*s++ & ~31) @@ -637,7 +659,7 @@ PP(pp_formline) sv_catpvn_utf8_upgrade(PL_formtarget, s, arg, nsv); for (; t < SvEND(PL_formtarget); t++) { #ifdef EBCDIC - int ch = *t++ = *s++; + int ch = *t; if (iscntrl(ch)) #else if (!(*t & ~31)) @@ -664,9 +686,16 @@ PP(pp_formline) s++; } sv_chop(sv,s); + SvSETMAGIC(sv); break; + case FF_LINESNGL: + chopspace = 0; + oneline = TRUE; + goto ff_line; case FF_LINEGLOB: + oneline = FALSE; + ff_line: item = s = SvPV(sv, len); itemsize = len; if ((item_is_utf8 = DO_UTF8(sv))) @@ -675,20 +704,31 @@ PP(pp_formline) bool chopped = FALSE; gotsome = TRUE; send = s + len; + chophere = s + itemsize; while (s < send) { if (*s++ == '\n') { - if (s == send) { - itemsize--; + if (oneline) { chopped = TRUE; + chophere = s; + break; + } else { + if (s == send) { + itemsize--; + chopped = TRUE; + } else + lines++; } - else - lines++; } } SvCUR_set(PL_formtarget, t - SvPVX(PL_formtarget)); if (targ_is_utf8) SvUTF8_on(PL_formtarget); - sv_catsv(PL_formtarget, sv); + if (oneline) { + SvCUR_set(sv, chophere - item); + sv_catsv(PL_formtarget, sv); + SvCUR_set(sv, itemsize); + } else + sv_catsv(PL_formtarget, sv); if (chopped) SvCUR_set(PL_formtarget, SvCUR(PL_formtarget) - 1); SvGROW(PL_formtarget, SvCUR(PL_formtarget) + fudge + 1); @@ -698,46 +738,24 @@ PP(pp_formline) } break; + case FF_0DECIMAL: + arg = *fpc++; +#if defined(USE_LONG_DOUBLE) + fmt = (arg & 256) ? "%#0*.*" PERL_PRIfldbl : "%0*.*" PERL_PRIfldbl; +#else + fmt = (arg & 256) ? "%#0*.*f" : "%0*.*f"; +#endif + goto ff_dec; case FF_DECIMAL: - /* If the field is marked with ^ and the value is undefined, - blank it out. */ arg = *fpc++; - if ((arg & 512) && !SvOK(sv)) { - arg = fieldsize; - while (arg--) - *t++ = ' '; - break; - } - gotsome = TRUE; - value = SvNV(sv); - /* Formats aren't yet marked for locales, so assume "yes". */ - { - STORE_NUMERIC_STANDARD_SET_LOCAL(); #if defined(USE_LONG_DOUBLE) - if (arg & 256) { - sprintf(t, "%#*.*" PERL_PRIfldbl, - (int) fieldsize, (int) arg & 255, value); - } else { - sprintf(t, "%*.0" PERL_PRIfldbl, (int) fieldsize, value); - } + fmt = (arg & 256) ? "%#*.*" PERL_PRIfldbl : "%*.*" PERL_PRIfldbl; #else - if (arg & 256) { - sprintf(t, "%#*.*f", - (int) fieldsize, (int) arg & 255, value); - } else { - sprintf(t, "%*.0f", - (int) fieldsize, value); - } + fmt = (arg & 256) ? "%#*.*f" : "%*.*f"; #endif - RESTORE_NUMERIC_STANDARD(); - } - t += fieldsize; - break; - - case FF_0DECIMAL: + ff_dec: /* If the field is marked with ^ and the value is undefined, blank it out. */ - arg = *fpc++; if ((arg & 512) && !SvOK(sv)) { arg = fieldsize; while (arg--) @@ -746,31 +764,22 @@ PP(pp_formline) } gotsome = TRUE; value = SvNV(sv); + /* overflow evidence */ + if (num_overflow(value, fieldsize, arg)) { + arg = fieldsize; + while (arg--) + *t++ = '#'; + break; + } /* Formats aren't yet marked for locales, so assume "yes". */ { STORE_NUMERIC_STANDARD_SET_LOCAL(); -#if defined(USE_LONG_DOUBLE) - if (arg & 256) { - sprintf(t, "%#0*.*" PERL_PRIfldbl, - (int) fieldsize, (int) arg & 255, value); -/* is this legal? I don't have long doubles */ - } else { - sprintf(t, "%0*.0" PERL_PRIfldbl, (int) fieldsize, value); - } -#else - if (arg & 256) { - sprintf(t, "%#0*.*f", - (int) fieldsize, (int) arg & 255, value); - } else { - sprintf(t, "%0*.0f", - (int) fieldsize, value); - } -#endif + sprintf(t, fmt, (int) fieldsize, (int) arg & 255, value); RESTORE_NUMERIC_STANDARD(); } t += fieldsize; break; - + case FF_NEWLINE: f++; while (t-- > linemark && *t == ' ') ; @@ -857,14 +866,19 @@ PP(pp_grepstart) ENTER; /* enter outer scope */ SAVETMPS; - /* SAVE_DEFSV does *not* suffice here for USE_5005THREADS */ - SAVESPTR(DEFSV); + if (PL_op->op_private & OPpGREP_LEX) + SAVESPTR(PAD_SVl(PL_op->op_targ)); + else + SAVE_DEFSV; ENTER; /* enter inner scope */ SAVEVPTR(PL_curpm); src = PL_stack_base[*PL_markstack_ptr]; SvTEMP_off(src); - DEFSV = src; + if (PL_op->op_private & OPpGREP_LEX) + PAD_SVl(PL_op->op_targ) = src; + else + DEFSV = src; PUTBACK; if (PL_op->op_type == OP_MAPSTART) @@ -880,6 +894,7 @@ PP(pp_mapstart) PP(pp_mapwhile) { dSP; + I32 gimme = GIMME_V; I32 items = (SP - PL_stack_base) - *PL_markstack_ptr; /* how many new items */ I32 count; I32 shift; @@ -890,7 +905,7 @@ PP(pp_mapwhile) ++PL_markstack_ptr[-1]; /* if there are new items, push them into the destination list */ - if (items) { + if (items && gimme != G_VOID) { /* 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 @@ -927,14 +942,24 @@ PP(pp_mapwhile) } /* copy the new items down to the destination list */ dst = PL_stack_base + (PL_markstack_ptr[-2] += items) - 1; - while (items-- > 0) - *dst-- = SvTEMP(TOPs) ? POPs : sv_mortalcopy(POPs); + if (gimme == G_ARRAY) { + while (items-- > 0) + *dst-- = SvTEMP(TOPs) ? POPs : sv_mortalcopy(POPs); + } + else { + /* scalar context: we don't care about which values map returns + * (we use undef here). And so we certainly don't want to do mortal + * copies of meaningless values. */ + while (items-- > 0) { + (void)POPs; + *dst-- = &PL_sv_undef; + } + } } LEAVE; /* exit inner scope */ /* All done yet? */ if (PL_markstack_ptr[-1] > *PL_markstack_ptr) { - I32 gimme = GIMME_V; (void)POPMARK; /* pop top */ LEAVE; /* exit outer scope */ @@ -943,8 +968,15 @@ PP(pp_mapwhile) (void)POPMARK; /* pop dst */ SP = PL_stack_base + POPMARK; /* pop original mark */ if (gimme == G_SCALAR) { - dTARGET; - XPUSHi(items); + if (PL_op->op_private & OPpGREP_LEX) { + SV* sv = sv_newmortal(); + sv_setiv(sv, items); + PUSHs(sv); + } + else { + dTARGET; + XPUSHi(items); + } } else if (gimme == G_ARRAY) SP += items; @@ -959,7 +991,10 @@ PP(pp_mapwhile) /* set $_ to the new source item */ src = PL_stack_base[PL_markstack_ptr[-1]]; SvTEMP_off(src); - DEFSV = src; + if (PL_op->op_private & OPpGREP_LEX) + PAD_SVl(PL_op->op_targ) = src; + else + DEFSV = src; RETURNOP(cLOGOP->op_other); } @@ -1019,31 +1054,35 @@ PP(pp_flip) } } +/* This code tries to decide if "$left .. $right" should use the + magical string increment, or if the range is numeric (we make + an exception for .."0" [#18165]). AMS 20021031. */ + +#define RANGE_IS_NUMERIC(left,right) ( \ + SvNIOKp(left) || (SvOK(left) && !SvPOKp(left)) || \ + SvNIOKp(right) || (SvOK(right) && !SvPOKp(right)) || \ + (((!SvOK(left) && SvOK(right)) || ((!SvOK(left) || \ + looks_like_number(left)) && SvPOKp(left) && *SvPVX(left) != '0')) \ + && (!SvOK(right) || looks_like_number(right)))) + PP(pp_flop) { dSP; if (GIMME == G_ARRAY) { dPOPPOPssrl; - register I32 i, j; + register IV i, j; register SV *sv; - I32 max; + IV max; if (SvGMAGICAL(left)) mg_get(left); if (SvGMAGICAL(right)) mg_get(right); - /* This code tries to decide if "$left .. $right" should use the - magical string increment, or if the range is numeric (we make - an exception for .."0" [#18165]). AMS 20021031. */ - - if (SvNIOKp(left) || !SvPOKp(left) || - SvNIOKp(right) || !SvPOKp(right) || - (looks_like_number(left) && *SvPVX(left) != '0' && - looks_like_number(right))) - { - if (SvNV(left) < IV_MIN || SvNV(right) > IV_MAX) + if (RANGE_IS_NUMERIC(left,right)) { + if ((SvOK(left) && SvNV(left) < IV_MIN) || + (SvOK(right) && SvNV(right) > IV_MAX)) DIE(aTHX_ "Range iterator outside integer range"); i = SvIV(left); max = SvIV(right); @@ -1317,8 +1356,6 @@ OP * Perl_die_where(pTHX_ char *message, STRLEN msglen) { STRLEN n_a; - IO *io; - MAGIC *mg; if (PL_in_eval) { I32 cxix; @@ -1353,8 +1390,6 @@ Perl_die_where(pTHX_ char *message, STRLEN msglen) sv_setpvn(ERRSV, message, msglen); } } - else - message = SvPVx(ERRSV, msglen); while ((cxix = dopoptoeval(cxstack_ix)) < 0 && PL_curstackinfo->si_prev) @@ -1371,6 +1406,8 @@ Perl_die_where(pTHX_ char *message, STRLEN msglen) POPBLOCK(cx,PL_curpm); if (CxTYPE(cx) != CXt_EVAL) { + if (!message) + message = SvPVx(ERRSV, msglen); PerlIO_write(Perl_error_log, "panic: die ", 11); PerlIO_write(Perl_error_log, message, msglen); my_exit(1); @@ -1391,39 +1428,20 @@ Perl_die_where(pTHX_ char *message, STRLEN msglen) if (optype == OP_REQUIRE) { char* msg = SvPVx(ERRSV, n_a); + SV *nsv = cx->blk_eval.old_namesv; + (void)hv_store(GvHVn(PL_incgv), SvPVX(nsv), SvCUR(nsv), + &PL_sv_undef, 0); DIE(aTHX_ "%sCompilation failed in require", *msg ? msg : "Unknown error\n"); } - return pop_return(); + assert(CxTYPE(cx) == CXt_EVAL); + return cx->blk_eval.retop; } } if (!message) message = SvPVx(ERRSV, msglen); - /* if STDERR is tied, print to it instead */ - if (PL_stderrgv && (io = GvIOp(PL_stderrgv)) - && (mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar))) { - dSP; ENTER; - PUSHMARK(SP); - XPUSHs(SvTIED_obj((SV*)io, mg)); - XPUSHs(sv_2mortal(newSVpvn(message, msglen))); - PUTBACK; - call_method("PRINT", G_SCALAR); - LEAVE; - } - else { -#ifdef USE_SFIO - /* SFIO can really mess with your errno */ - int e = errno; -#endif - PerlIO *serr = Perl_error_log; - - PERL_WRITE_MSG_TO_CONSOLE(serr, message, msglen); - (void)PerlIO_flush(serr); -#ifdef USE_SFIO - errno = e; -#endif - } + write_to_stderr(message, msglen); my_failure_exit(); /* NOTREACHED */ return 0; @@ -1711,11 +1729,10 @@ PP(pp_dbstate) hasargs = 0; SPAGAIN; - push_return(PL_op->op_next); PUSHBLOCK(cx, CXt_SUB, SP); PUSHSUB_DB(cx); + cx->blk_sub.retop = PL_op->op_next; CvDEPTH(cv)++; - (void)SvREFCNT_inc(cv); PAD_SET_CUR(CvPADLIST(cv),1); RETURNOP(CvSTART(cv)); } @@ -1743,6 +1760,11 @@ PP(pp_enteriter) SAVETMPS; if (PL_op->op_targ) { + if (PL_op->op_private & OPpLVAL_INTRO) { /* for my $x (...) */ + SvPADSTALE_off(PAD_SVl(PL_op->op_targ)); + SAVESETSVFLAGS(PAD_SVl(PL_op->op_targ), + SVs_PADSTALE, SVs_PADSTALE); + } #ifndef USE_ITHREADS svp = &PAD_SVl(PL_op->op_targ); /* "my" variable */ SAVESPTR(*svp); @@ -1774,26 +1796,37 @@ PP(pp_enteriter) cx->blk_loop.iterary = (AV*)SvREFCNT_inc(POPs); if (SvTYPE(cx->blk_loop.iterary) != SVt_PVAV) { dPOPss; - /* See comment in pp_flop() */ - if (SvNIOKp(sv) || !SvPOKp(sv) || - 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))) - { - if (SvNV(sv) < IV_MIN || - SvNV((SV*)cx->blk_loop.iterary) >= IV_MAX) - DIE(aTHX_ "Range iterator outside integer range"); - cx->blk_loop.iterix = SvIV(sv); - cx->blk_loop.itermax = SvIV((SV*)cx->blk_loop.iterary); + SV *right = (SV*)cx->blk_loop.iterary; + if (RANGE_IS_NUMERIC(sv,right)) { + if ((SvOK(sv) && SvNV(sv) < IV_MIN) || + (SvOK(right) && SvNV(right) >= IV_MAX)) + DIE(aTHX_ "Range iterator outside integer range"); + cx->blk_loop.iterix = SvIV(sv); + cx->blk_loop.itermax = SvIV(right); } - else + else { + STRLEN n_a; cx->blk_loop.iterlval = newSVsv(sv); + (void) SvPV_force(cx->blk_loop.iterlval,n_a); + (void) SvPV(right,n_a); + } + } + else if (PL_op->op_private & OPpITER_REVERSED) { + cx->blk_loop.itermax = -1; + cx->blk_loop.iterix = AvFILL(cx->blk_loop.iterary); + } } else { cx->blk_loop.iterary = PL_curstack; AvFILLp(PL_curstack) = SP - PL_stack_base; - cx->blk_loop.iterix = MARK - PL_stack_base; + if (PL_op->op_private & OPpITER_REVERSED) { + cx->blk_loop.itermax = MARK - PL_stack_base; + cx->blk_loop.iterix = cx->blk_oldsp; + } + else { + cx->blk_loop.iterix = MARK - PL_stack_base; + } } RETURN; @@ -1867,6 +1900,7 @@ PP(pp_return) PMOP *newpm; I32 optype = 0; SV *sv; + OP *retop; if (PL_curstackinfo->si_type == PERLSI_SORT) { if (cxstack_ix == PL_sortcxix @@ -1890,11 +1924,14 @@ PP(pp_return) switch (CxTYPE(cx)) { case CXt_SUB: popsub2 = TRUE; + retop = cx->blk_sub.retop; + cxstack_ix++; /* preserve cx entry on stack for use by POPSUB */ break; case CXt_EVAL: if (!(PL_in_eval & EVAL_KEEPERR)) clear_errsv = TRUE; POPEVAL(cx); + retop = cx->blk_eval.retop; if (CxTRYBLOCK(cx)) break; lex_end(); @@ -1909,6 +1946,7 @@ PP(pp_return) break; case CXt_FORMAT: POPFORMAT(cx); + retop = cx->blk_sub.retop; break; default: DIE(aTHX_ "panic: return"); @@ -1952,6 +1990,7 @@ PP(pp_return) LEAVE; /* Stack values are safe: */ if (popsub2) { + cxstack_ix--; POPSUB(cx,sv); /* release CV and @_ ... */ } else @@ -1961,7 +2000,7 @@ PP(pp_return) LEAVESUB(sv); if (clear_errsv) sv_setpv(ERRSV,""); - return pop_return(); + return retop; } PP(pp_last) @@ -1992,6 +2031,7 @@ PP(pp_last) dounwind(cxix); POPBLOCK(cx,newpm); + cxstack_ix++; /* temporarily protect top context */ mark = newsp; switch (CxTYPE(cx)) { case CXt_LOOP: @@ -2001,15 +2041,15 @@ PP(pp_last) break; case CXt_SUB: pop2 = CXt_SUB; - nextop = pop_return(); + nextop = cx->blk_sub.retop; break; case CXt_EVAL: POPEVAL(cx); - nextop = pop_return(); + nextop = cx->blk_eval.retop; break; case CXt_FORMAT: POPFORMAT(cx); - nextop = pop_return(); + nextop = cx->blk_sub.retop; break; default: DIE(aTHX_ "panic: last"); @@ -2034,6 +2074,7 @@ PP(pp_last) PUTBACK; LEAVE; + cxstack_ix--; /* Stack values are safe: */ switch (pop2) { case CXt_LOOP: @@ -2100,6 +2141,7 @@ PP(pp_redo) TOPBLOCK(cx); oldsave = PL_scopestack[PL_scopestack_ix - 1]; LEAVE_SCOPE(oldsave); + FREETMPS; return cx->blk_loop.redo_op; } @@ -2167,6 +2209,7 @@ PP(pp_goto) char *label; int do_dump = (PL_op->op_type == OP_DUMP); static char must_have_label[] = "goto must have label"; + AV *oldav = Nullav; label = 0; if (PL_op->op_flags & OPf_STACKED) { @@ -2227,12 +2270,14 @@ PP(pp_goto) GvAV(PL_defgv) = cx->blk_sub.savearray; /* abandon @_ if it got reified */ if (AvREAL(av)) { - (void)sv_2mortal((SV*)av); /* delay until return */ + oldav = av; /* delay until return */ av = newAV(); av_extend(av, items-1); AvFLAGS(av) = AVf_REIFY; PAD_SVl(0) = (SV*)(cx->blk_sub.argarray = av); } + else + CLEAR_ARGARRAY(av); } else if (CvXSUB(cv)) { /* put GvAV(defgv) back onto stack */ AV* av; @@ -2251,6 +2296,9 @@ PP(pp_goto) /* Now do some callish stuff. */ SAVETMPS; + /* For reified @_, delay freeing till return from new sub */ + if (oldav) + SAVEFREESV((SV*)oldav); SAVEFREESV(cv); /* later, undo the 'avoid premature free' hack */ if (CvXSUB(cv)) { #ifdef PERL_XSUB_OLDSTYLE @@ -2281,7 +2329,8 @@ PP(pp_goto) /* Do _not_ use PUTBACK, keep the XSUB's return stack! */ } LEAVE; - return pop_return(); + assert(CxTYPE(cx) == CXt_SUB); + return cx->blk_sub.retop; } else { AV* padlist = CvPADLIST(cv); @@ -2300,7 +2349,7 @@ PP(pp_goto) else { if (CvDEPTH(cv) == 100 && ckWARN(WARN_RECURSION)) sub_crush_depth(cv); - pad_push(padlist, CvDEPTH(cv), cx->blk_sub.hasargs); + pad_push(padlist, CvDEPTH(cv), 1); } PAD_SET_CUR(padlist, CvDEPTH(cv)); if (cx->blk_sub.hasargs) @@ -2345,7 +2394,10 @@ PP(pp_goto) CV *gotocv; if (PERLDB_SUB_NN) { - SvIVX(sv) = PTR2IV(cv); /* Already upgraded, saved */ + (void)SvUPGRADE(sv, SVt_PVIV); + (void)SvIOK_on(sv); + SAVEIV(SvIVX(sv)); + SvIVX(sv) = PTR2IV(cv); /* Do it the quickest way */ } else { save_item(sv); gv_efullname3(sv, CvGV(cv), Nullch); @@ -2388,7 +2440,7 @@ PP(pp_goto) switch (CxTYPE(cx)) { case CXt_EVAL: leaving_eval = TRUE; - if (CxREALEVAL(cx)) { + if (!CxTRYBLOCK(cx)) { gotoprobe = (last_eval_cx ? last_eval_cx->blk_eval.old_eval_root : PL_eval_root); @@ -2613,8 +2665,10 @@ S_docatch(pTHX_ OP *o) * the op to Nullop, we force an exit from the inner runops() * loop. DAPM. */ - retop = pop_return(); - push_return(Nullop); + assert(cxstack_ix >= 0); + assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL); + retop = cxstack[cxstack_ix].blk_eval.retop; + cxstack[cxstack_ix].blk_eval.retop = Nullop; #ifdef PERL_FLEXIBLE_EXCEPTIONS redo_body: @@ -2675,7 +2729,7 @@ Perl_sv_compile_2op(pTHX_ SV *sv, OP** startop, char *code, PAD** padp) SAVETMPS; /* switch to eval mode */ - if (PL_curcop == &PL_compiling) { + if (IN_PERL_COMPILETIME) { SAVECOPSTASH_FREE(&PL_compiling); CopSTASH_set(&PL_compiling, PL_curstash); } @@ -2705,17 +2759,16 @@ Perl_sv_compile_2op(pTHX_ SV *sv, OP** startop, char *code, PAD** padp) #else SAVEVPTR(PL_op); #endif - PL_hints &= HINT_UTF8; /* we get here either during compilation, or via pp_regcomp at runtime */ - runtime = PL_op && (PL_op->op_type == OP_REGCOMP); + runtime = IN_PERL_RUNTIME; if (runtime) runcv = find_runcv(NULL); PL_op = &dummy; PL_op->op_type = OP_ENTEREVAL; PL_op->op_flags = 0; /* Avoid uninit warning. */ - PUSHBLOCK(cx, CXt_EVAL|(PL_curcop == &PL_compiling ? 0 : CXp_REAL), SP); + PUSHBLOCK(cx, CXt_EVAL|(IN_PERL_COMPILETIME ? 0 : CXp_REAL), SP); PUSHEVAL(cx, 0, Nullgv); if (runtime) @@ -2731,7 +2784,7 @@ Perl_sv_compile_2op(pTHX_ SV *sv, OP** startop, char *code, PAD** padp) /* XXX DAPM do this properly one year */ *padp = (AV*)SvREFCNT_inc(PL_comppad); LEAVE; - if (PL_curcop == &PL_compiling) + if (IN_PERL_COMPILETIME) PL_compiling.op_private = (U8)(PL_hints & HINT_PRIVATE_MASK); #ifdef OP_IN_REGISTER op = PL_opsave; @@ -2747,7 +2800,7 @@ Locate the CV corresponding to the currently executing sub or eval. If db_seqp is non_null, skip CVs that are in the DB package and populate *db_seqp with the cop sequence number at the point that the DB:: code was entered. (allows debuggers to eval in the scope of the breakpoint rather -than in in the scope of the debuger itself). +than in in the scope of the debugger itself). =cut */ @@ -2839,9 +2892,8 @@ S_doeval(pTHX_ int gimme, OP** startop, CV* outside, U32 seq) else sv_setpv(ERRSV,""); if (yyparse() || PL_error_count || !PL_eval_root) { - SV **newsp; - I32 gimme; - PERL_CONTEXT *cx; + SV **newsp; /* Used by POPBLOCK. */ + PERL_CONTEXT *cx = &cxstack[cxstack_ix]; I32 optype = 0; /* Might be reset by POPEVAL. */ STRLEN n_a; @@ -2854,12 +2906,14 @@ S_doeval(pTHX_ int gimme, OP** startop, CV* outside, U32 seq) if (!startop) { POPBLOCK(cx,PL_curpm); POPEVAL(cx); - pop_return(); } lex_end(); LEAVE; if (optype == OP_REQUIRE) { char* msg = SvPVx(ERRSV, n_a); + SV *nsv = cx->blk_eval.old_namesv; + (void)hv_store(GvHVn(PL_incgv), SvPVX(nsv), SvCUR(nsv), + &PL_sv_undef, 0); DIE(aTHX_ "%sCompilation failed in require", *msg ? msg : "Unknown error\n"); } @@ -2884,13 +2938,16 @@ S_doeval(pTHX_ int gimme, OP** startop, CV* outside, U32 seq) *startop = PL_eval_root; } else SAVEFREEOP(PL_eval_root); - if (gimme & G_VOID && ! PL_in_eval & EVAL_INREQUIRE) - /* - * EVAL_INREQUIRE (the code is being required) is special-cased : - * in this case we want scalar context to be forced, instead - * of void context, so a proper return value is returned from - * C via this leaveeval op. - */ + + /* Set the context for this new optree. + * If the last op is an OP_REQUIRE, force scalar context. + * Otherwise, propagate the context from the eval(). */ + if (PL_eval_root->op_type == OP_LEAVEEVAL + && cUNOPx(PL_eval_root)->op_first->op_type == OP_LINESEQ + && cLISTOPx(cUNOPx(PL_eval_root)->op_first)->op_last->op_type + == OP_REQUIRE) + scalar(PL_eval_root); + else if (gimme & G_VOID) scalarvoid(PL_eval_root); else if (gimme & G_ARRAY) list(PL_eval_root); @@ -2922,8 +2979,9 @@ S_doeval(pTHX_ int gimme, OP** startop, CV* outside, U32 seq) } STATIC PerlIO * -S_doopen_pmc(pTHX_ const char *name, const char *mode) +S_doopen_pm(pTHX_ const char *name, const char *mode) { +#ifndef PERL_DISABLE_PMC STRLEN namelen = strlen(name); PerlIO *fp; @@ -2951,6 +3009,9 @@ S_doopen_pmc(pTHX_ const char *name, const char *mode) fp = PerlIO_open(name, mode); } return fp; +#else + return PerlIO_open(name, mode); +#endif /* !PERL_DISABLE_PMC */ } PP(pp_require) @@ -3041,15 +3102,18 @@ PP(pp_require) DIE(aTHX_ "Null filename used"); TAINT_PROPER("require"); if (PL_op->op_type == OP_REQUIRE && - (svp = hv_fetch(GvHVn(PL_incgv), name, len, 0)) && - *svp != &PL_sv_undef) - RETPUSHYES; + (svp = hv_fetch(GvHVn(PL_incgv), name, len, 0))) { + if (*svp != &PL_sv_undef) + RETPUSHYES; + else + DIE(aTHX_ "Compilation failed in require"); + } /* prepare to compile file */ if (path_is_absolute(name)) { tryname = name; - tryrsfp = doopen_pmc(name,PERL_SCRIPT_MODE); + tryrsfp = doopen_pm(name,PERL_SCRIPT_MODE); } #ifdef MACOS_TRADITIONAL if (!tryrsfp) { @@ -3058,7 +3122,7 @@ PP(pp_require) MacPerl_CanonDir(name, newname, 1); if (path_is_absolute(newname)) { tryname = newname; - tryrsfp = doopen_pmc(newname,PERL_SCRIPT_MODE); + tryrsfp = doopen_pm(newname,PERL_SCRIPT_MODE); } } #endif @@ -3159,6 +3223,7 @@ PP(pp_require) PERL_SCRIPT_MODE); } } + SP--; } PUTBACK; @@ -3213,7 +3278,7 @@ PP(pp_require) #endif TAINT_PROPER("require"); tryname = SvPVX(namesv); - tryrsfp = doopen_pmc(tryname, PERL_SCRIPT_MODE); + tryrsfp = doopen_pm(tryname, PERL_SCRIPT_MODE); if (tryrsfp) { if (tryname[0] == '.' && tryname[1] == '/') tryname += 2; @@ -3298,9 +3363,9 @@ PP(pp_require) } /* switch to eval mode */ - push_return(PL_op->op_next); PUSHBLOCK(cx, CXt_EVAL, SP); PUSHEVAL(cx, name, Nullgv); + cx->blk_eval.retop = PL_op->op_next; SAVECOPLINE(&PL_compiling); CopLINE_set(&PL_compiling, 0); @@ -3391,9 +3456,9 @@ PP(pp_entereval) * to do the dirty work for us */ runcv = find_runcv(&seq); - push_return(PL_op->op_next); PUSHBLOCK(cx, (CXt_EVAL|CXp_REAL), SP); PUSHEVAL(cx, 0, Nullgv); + cx->blk_eval.retop = PL_op->op_next; /* prepare to compile string */ @@ -3422,7 +3487,7 @@ PP(pp_leaveeval) POPBLOCK(cx,newpm); POPEVAL(cx); - retop = pop_return(); + retop = cx->blk_eval.retop; TAINT_NOT; if (gimme == G_VOID) @@ -3485,9 +3550,9 @@ PP(pp_entertry) ENTER; SAVETMPS; - push_return(cLOGOP->op_other->op_next); PUSHBLOCK(cx, (CXt_EVAL|CXp_TRYBLOCK), SP); PUSHEVAL(cx, 0, 0); + cx->blk_eval.retop = cLOGOP->op_other->op_next; PL_in_eval = EVAL_INEVAL; sv_setpv(ERRSV,""); @@ -3508,7 +3573,7 @@ PP(pp_leavetry) POPBLOCK(cx,newpm); POPEVAL(cx); - retop = pop_return(); + retop = cx->blk_eval.retop; TAINT_NOT; if (gimme == G_VOID) @@ -3543,7 +3608,7 @@ PP(pp_leavetry) RETURNOP(retop); } -STATIC void +STATIC OP * S_doparseform(pTHX_ SV *sv) { STRLEN len; @@ -3554,16 +3619,26 @@ S_doparseform(pTHX_ SV *sv) bool noblank = FALSE; bool repeat = FALSE; bool postspace = FALSE; - U16 *fops; - register U16 *fpc; - U16 *linepc = 0; + U32 *fops; + register U32 *fpc; + U32 *linepc = 0; register I32 arg; bool ischop; + bool unchopnum = FALSE; + int maxops = 12; /* FF_LINEMARK + FF_END + 10 (\0 without preceding \n) */ if (len == 0) Perl_croak(aTHX_ "Null picture in formline"); - New(804, fops, (send - s)*3+10, U16); /* Almost certainly too long... */ + /* estimate the buffer size needed */ + for (base = s; s <= send; s++) { + if (*s == '\n' || *s == '@' || *s == '^') + maxops += 10; + } + s = base; + base = Nullch; + + New(804, fops, maxops, U32); fpc = fops; if (s < send) { @@ -3590,8 +3665,12 @@ S_doparseform(pTHX_ SV *sv) case ' ': case '\t': skipspaces++; continue; - - case '\n': case 0: + case 0: + if (s < send) { + skipspaces = 0; + continue; + } /* else FALL THROUGH */ + case '\n': arg = s - base; skipspaces++; arg -= skipspaces; @@ -3647,8 +3726,12 @@ S_doparseform(pTHX_ SV *sv) *fpc++ = FF_FETCH; if (*s == '*') { s++; - *fpc++ = 0; - *fpc++ = FF_LINEGLOB; + *fpc++ = 2; /* skip the @* or ^* */ + if (ischop) { + *fpc++ = FF_LINESNGL; + *fpc++ = FF_CHOP; + } else + *fpc++ = FF_LINEGLOB; } else if (*s == '#' || (*s == '.' && s[1] == '#')) { arg = ischop ? 512 : 0; @@ -3666,6 +3749,7 @@ S_doparseform(pTHX_ SV *sv) *fpc++ = s - base; /* fieldsize for FETCH */ *fpc++ = FF_DECIMAL; *fpc++ = (U16)arg; + unchopnum |= ! ischop; } else if (*s == '0' && s[1] == '#') { /* Zero padded decimals */ arg = ischop ? 512 : 0; @@ -3684,6 +3768,7 @@ S_doparseform(pTHX_ SV *sv) *fpc++ = s - base; /* fieldsize for FETCH */ *fpc++ = FF_0DECIMAL; *fpc++ = (U16)arg; + unchopnum |= ! ischop; } else { I32 prespace = 0; @@ -3726,17 +3811,50 @@ S_doparseform(pTHX_ SV *sv) } *fpc++ = FF_END; + assert (fpc <= fops + maxops); /* ensure our buffer estimate was valid */ arg = fpc - fops; { /* need to jump to the next word */ int z; z = WORD_ALIGN - SvCUR(sv) % WORD_ALIGN; - SvGROW(sv, SvCUR(sv) + z + arg * sizeof(U16) + 4); + SvGROW(sv, SvCUR(sv) + z + arg * sizeof(U32) + 4); s = SvPVX(sv) + SvCUR(sv) + z; } - Copy(fops, s, arg, U16); + Copy(fops, s, arg, U32); Safefree(fops); sv_magic(sv, Nullsv, PERL_MAGIC_fm, Nullch, 0); SvCOMPILED_on(sv); + + if (unchopnum && repeat) + DIE(aTHX_ "Repeated format line will never terminate (~~ and @#)"); + return 0; +} + + +STATIC bool +S_num_overflow(NV value, I32 fldsize, I32 frcsize) +{ + /* Can value be printed in fldsize chars, using %*.*f ? */ + NV pwr = 1; + NV eps = 0.5; + bool res = FALSE; + int intsize = fldsize - (value < 0 ? 1 : 0); + + if (frcsize & 256) + intsize--; + frcsize &= 255; + intsize -= frcsize; + + while (intsize--) pwr *= 10.0; + while (frcsize--) eps /= 10.0; + + if( value >= 0 ){ + if (value + eps >= pwr) + res = TRUE; + } else { + if (value - eps <= -pwr) + res = TRUE; + } + return res; } static I32