X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=pp_ctl.c;h=f818869d59bdfe57f4bb4c67c74838a4c354b45c;hb=25ff0154ccf606eb5512a8cde622caf50e20fba3;hp=7a8da0d5ce8fb5c6120c167f40b4187f64215a01;hpb=a3b58a99a41a86ac422b863ee2844e354b2915f3;p=p5sagit%2Fp5-mst-13.2.git diff --git a/pp_ctl.c b/pp_ctl.c index 7a8da0d..f818869 100644 --- a/pp_ctl.c +++ b/pp_ctl.c @@ -1,7 +1,7 @@ /* pp_ctl.c * * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, - * 2000, 2001, 2002, 2003, 2004, 2005, 2006, by Larry Wall and others + * 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007 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. @@ -177,7 +177,7 @@ PP(pp_regcomp) if (!PM_GETRE(pm)->prelen && PL_curpm) pm = PL_curpm; - else if (strEQ("\\s+", PM_GETRE(pm)->precomp)) + else if (PM_GETRE(pm)->extflags & RXf_WHITE) pm->op_pmflags |= PMf_WHITE; else pm->op_pmflags &= ~PMf_WHITE; @@ -291,11 +291,10 @@ PP(pp_substcont) SV * const sv = cx->sb_targ; MAGIC *mg; I32 i; - if (SvTYPE(sv) < SVt_PVMG) - SvUPGRADE(sv, SVt_PVMG); + SvUPGRADE(sv, SVt_PVMG); if (!(mg = mg_find(sv, PERL_MAGIC_regex_global))) { #ifdef PERL_OLD_COPY_ON_WRITE - if (SvIsCOW(lsv)) + if (SvIsCOW(sv)) sv_force_normal_flags(sv, 0); #endif mg = sv_magicext(sv, NULL, PERL_MAGIC_regex_global, &PL_vtbl_mglob, @@ -1466,7 +1465,7 @@ Perl_qerror(pTHX_ SV *err) else if (PL_errors) sv_catsv(PL_errors, err); else - Perl_warn(aTHX_ "%"SVf, (void*)err); + Perl_warn(aTHX_ "%"SVf, SVfARG(err)); ++PL_error_count; } @@ -2028,7 +2027,7 @@ PP(pp_return) /* Unassume the success we assumed earlier. */ SV * const nsv = cx->blk_eval.old_namesv; (void)hv_delete(GvHVn(PL_incgv), SvPVX_const(nsv), SvCUR(nsv), G_DISCARD); - DIE(aTHX_ "%"SVf" did not return a true value", (void*)nsv); + DIE(aTHX_ "%"SVf" did not return a true value", SVfARG(nsv)); } break; case CXt_FORMAT: @@ -2336,7 +2335,7 @@ PP(pp_goto) goto retry; tmpstr = sv_newmortal(); gv_efullname3(tmpstr, gv, NULL); - DIE(aTHX_ "Goto undefined subroutine &%"SVf"",(void*)tmpstr); + DIE(aTHX_ "Goto undefined subroutine &%"SVf"", SVfARG(tmpstr)); } DIE(aTHX_ "Goto undefined subroutine"); } @@ -2450,13 +2449,13 @@ PP(pp_goto) SV **ary = AvALLOC(av); if (AvARRAY(av) != ary) { AvMAX(av) += AvARRAY(av) - AvALLOC(av); - SvPV_set(av, (char*)ary); + AvARRAY(av) = ary; } if (items >= AvMAX(av) + 1) { AvMAX(av) = items - 1; Renew(ary,items+1,SV*); AvALLOC(av) = ary; - SvPV_set(av, (char*)ary); + AvARRAY(av) = ary; } } ++mark; @@ -2475,21 +2474,7 @@ PP(pp_goto) } } if (PERLDB_SUB) { /* Checking curstash breaks DProf. */ - /* - * We do not care about using sv to call CV; - * it's for informational purposes only. - */ - SV * const sv = GvSV(PL_DBsub); - save_item(sv); - if (PERLDB_SUB_NN) { - const int type = SvTYPE(sv); - if (type < SVt_PVIV && type != SVt_IV) - sv_upgrade(sv, SVt_PVIV); - (void)SvIOK_on(sv); - SvIV_set(sv, PTR2IV(cv)); /* Do it the quickest way */ - } else { - gv_efullname3(sv, CvGV(cv), NULL); - } + Perl_get_db_sub(aTHX_ NULL, cv); if (PERLDB_GOTO) { CV * const gotocv = get_cv("DB::goto", FALSE); if (gotocv) { @@ -2672,9 +2657,8 @@ S_save_lines(pTHX_ AV *array, SV *sv) while (s && s < send) { const char *t; - SV * const tmpstr = newSV(0); + SV * const tmpstr = newSV_type(SVt_PVMG); - sv_upgrade(tmpstr, SVt_PVMG); t = strchr(s, '\n'); if (t) t++; @@ -2888,7 +2872,6 @@ Perl_find_runcv(pTHX_ U32 *db_seqp) * outside is the lexically enclosing CV (if any) that invoked us. */ -/* With USE_5005THREADS, eval_owner must be held on entry to doeval */ STATIC OP * S_doeval(pTHX_ int gimme, OP** startop, CV* outside, U32 seq) { @@ -2902,8 +2885,7 @@ S_doeval(pTHX_ int gimme, OP** startop, CV* outside, U32 seq) PUSHMARK(SP); SAVESPTR(PL_compcv); - PL_compcv = (CV*)newSV(0); - sv_upgrade((SV *)PL_compcv, SVt_PVCV); + PL_compcv = (CV*)newSV_type(SVt_PVCV); CvEVAL_on(PL_compcv); assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL); cxstack[cxstack_ix].blk_eval.cv = PL_compcv; @@ -2985,7 +2967,7 @@ S_doeval(pTHX_ int gimme, OP** startop, CV* outside, U32 seq) } else { if (!*msg) { - sv_setpv(ERRSV, "Compilation error"); + sv_setpvs(ERRSV, "Compilation error"); } } PERL_UNUSED_VAR(newsp); @@ -3111,15 +3093,26 @@ PP(pp_require) if (cUNOP->op_first->op_type == OP_CONST && cUNOP->op_first->op_private & OPpCONST_NOVER) { if ( vcmp(sv,PL_patchlevel) <= 0 ) DIE(aTHX_ "Perls since %"SVf" too modern--this is %"SVf", stopped", - (void*)vnormal(sv), (void*)vnormal(PL_patchlevel)); + SVfARG(vnormal(sv)), SVfARG(vnormal(PL_patchlevel))); } else { if ( vcmp(sv,PL_patchlevel) > 0 ) DIE(aTHX_ "Perl %"SVf" required--this is only %"SVf", stopped", - (void*)vnormal(sv), (void*)vnormal(PL_patchlevel)); + SVfARG(vnormal(sv)), SVfARG(vnormal(PL_patchlevel))); } - RETPUSHYES; + /* If we request a version >= 5.9.5, load feature.pm with the + * feature bundle that corresponds to the required version. + * We do this only with use, not require. */ + if (PL_compcv && vcmp(sv, sv_2mortal(upg_version(newSVnv(5.009005)))) >= 0) { + SV *const importsv = vnormal(sv); + *SvPVX_mutable(importsv) = ':'; + ENTER; + Perl_load_module(aTHX_ 0, newSVpvs("feature"), NULL, importsv, NULL); + LEAVE; + } + + RETPUSHYES; } name = SvPV_const(sv, len); if (!(name && len > 0 && *name)) @@ -3164,6 +3157,8 @@ PP(pp_require) for (i = 0; i <= AvFILL(ar); i++) { SV * const dirsv = *av_fetch(ar, i, TRUE); + if (SvTIED_mg((SV*)ar, PERL_MAGIC_tied)) + mg_get(dirsv); if (SvROK(dirsv)) { int count; SV **svp; @@ -3389,7 +3384,7 @@ PP(pp_require) ENTER; SAVETMPS; - lex_start(sv_2mortal(newSVpvs(""))); + lex_start(NULL); SAVEGENERICSV(PL_rsfp_filters); PL_rsfp_filters = NULL; @@ -3401,10 +3396,6 @@ PP(pp_require) PL_compiling.cop_warnings = pWARN_ALL ; else if (PL_dowarn & G_WARN_ALL_OFF) PL_compiling.cop_warnings = pWARN_NONE ; - else if (PL_taint_warn) { - PL_compiling.cop_warnings - = Perl_new_warnings_bitfield(aTHX_ NULL, WARN_TAINTstring, WARNsize); - } else PL_compiling.cop_warnings = pWARN_STD ; @@ -3461,6 +3452,7 @@ PP(pp_entereval) } sv = POPs; + TAINT_IF(SvTAINTED(sv)); TAINT_PROPER("eval"); ENTER; @@ -3586,7 +3578,7 @@ PP(pp_leaveeval) /* Unassume the success we assumed earlier. */ SV * const nsv = cx->blk_eval.old_namesv; (void)hv_delete(GvHVn(PL_incgv), SvPVX_const(nsv), SvCUR(nsv), G_DISCARD); - retop = Perl_die(aTHX_ "%"SVf" did not return a true value", (void*)nsv); + retop = Perl_die(aTHX_ "%"SVf" did not return a true value", SVfARG(nsv)); /* die_where() did LEAVE, or we won't be here */ } else { @@ -3631,7 +3623,6 @@ Perl_create_eval_scope(pTHX_ U32 flags) PUSHBLOCK(cx, (CXt_EVAL|CXp_TRYBLOCK), PL_stack_sp); PUSHEVAL(cx, 0, 0); - PL_eval_root = PL_op; /* Only needed so that goto works right. */ PL_in_eval = EVAL_INEVAL; if (flags & G_KEEPERR)