X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=pp_ctl.c;h=f726ab79bdaa66a56f8f74cc608c6a9122f7d2b6;hb=fa76202e3aa22e9755f1a461416769c368b47afc;hp=68204ce53ced4b09c86993d6ea0aaa9c8767307a;hpb=4c79ee7a1e7564ef83d0ac25d6677fdebb3ec7aa;p=p5sagit%2Fp5-mst-13.2.git diff --git a/pp_ctl.c b/pp_ctl.c index 68204ce..f726ab7 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, 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. @@ -97,7 +98,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) @@ -158,6 +159,15 @@ PP(pp_substcont) 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)); @@ -212,6 +222,7 @@ PP(pp_substcont) SvTAINT(targ); LEAVE_SCOPE(cx->sb_oldsave); + ReREFCNT_dec(rx); POPSUBST(cx); RETURNOP(pm->op_next); } @@ -247,6 +258,7 @@ PP(pp_substcont) sv_pos_b2u(sv, &i); mg->mg_len = i; } + ReREFCNT_inc(rx); cx->sb_rxtainted |= RX_MATCH_TAINTED(rx); rxres_save(&cx->sb_rxres, rx); RETURNOP(pm->op_pmreplstart); @@ -1635,8 +1647,18 @@ PP(pp_caller) (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) ; + (old_warnings == pWARN_STD && PL_dowarn & G_WARN_ON)) { + /* Get the bit mask for $warnings::Bits{all}, because + * it could have been extended by warnings::register */ + SV **bits_all; + HV *bits = get_hv("warnings::Bits", FALSE); + if (bits && (bits_all=hv_fetch(bits, "all", 3, FALSE))) { + mask = newSVsv(*bits_all); + } + else { + mask = newSVpvn(WARN_ALLstring, WARNsize) ; + } + } else mask = newSVsv(old_warnings); PUSHs(sv_2mortal(mask)); @@ -1939,6 +1961,7 @@ PP(pp_return) } PL_stack_sp = newsp; + LEAVE; /* Stack values are safe: */ if (popsub2) { POPSUB(cx,sv); /* release CV and @_ ... */ @@ -1947,7 +1970,6 @@ PP(pp_return) sv = Nullsv; PL_curpm = newpm; /* ... and pop $1 et al */ - LEAVE; LEAVESUB(sv); if (clear_errsv) sv_setpv(ERRSV,""); @@ -2023,6 +2045,7 @@ PP(pp_last) SP = newsp; PUTBACK; + LEAVE; /* Stack values are safe: */ switch (pop2) { case CXt_LOOP: @@ -2035,7 +2058,6 @@ PP(pp_last) } PL_curpm = newpm; /* ... and pop $1 et al */ - LEAVE; LEAVESUB(sv); return nextop; } @@ -2193,6 +2215,7 @@ PP(pp_goto) } /* First do some returnish stuff. */ + SvREFCNT_inc(cv); /* avoid premature free during unwind */ FREETMPS; cxix = dopoptosub(cxstack_ix); if (cxix < 0) @@ -2222,6 +2245,8 @@ PP(pp_goto) 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; @@ -2240,6 +2265,7 @@ PP(pp_goto) /* Now do some callish stuff. */ SAVETMPS; + SAVEFREESV(cv); /* later, undo the 'avoid premature free' hack */ if (CvXSUB(cv)) { #ifdef PERL_XSUB_OLDSTYLE if (CvOLDSTYLE(cv)) { @@ -2376,7 +2402,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); @@ -2872,7 +2898,13 @@ S_doeval(pTHX_ int gimme, OP** startop, CV* outside, U32 seq) *startop = PL_eval_root; } else SAVEFREEOP(PL_eval_root); - if (gimme & G_VOID) + 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. + */ scalarvoid(PL_eval_root); else if (gimme & G_ARRAY) list(PL_eval_root); @@ -2904,8 +2936,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; @@ -2933,6 +2966,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) @@ -3031,7 +3067,7 @@ PP(pp_require) 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) { @@ -3040,7 +3076,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 @@ -3195,7 +3231,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; @@ -3541,11 +3577,20 @@ S_doparseform(pTHX_ SV *sv) U16 *linepc = 0; register I32 arg; bool ischop; + int maxops = 2; /* FF_LINEMARK + FF_END) */ 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, U16); fpc = fops; if (s < send) { @@ -3708,6 +3753,7 @@ 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;