X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/f73ef291429b5bbca51e74d1a29b172b5d7304ea..5675696b3881ef5bfde3012a829ca51ab1d42333:/pp_ctl.c diff --git a/pp_ctl.c b/pp_ctl.c index 43cf175..364a1d5 100644 --- a/pp_ctl.c +++ b/pp_ctl.c @@ -284,8 +284,12 @@ PP(pp_substcont) if (SvTYPE(sv) < SVt_PVMG) SvUPGRADE(sv, SVt_PVMG); if (!(mg = mg_find(sv, PERL_MAGIC_regex_global))) { - sv_magic(sv, NULL, PERL_MAGIC_regex_global, NULL, 0); - mg = mg_find(sv, PERL_MAGIC_regex_global); +#ifdef PERL_OLD_COPY_ON_WRITE + if (SvIsCOW(lsv)) + sv_force_normal_flags(sv, 0); +#endif + mg = sv_magicext(sv, NULL, PERL_MAGIC_regex_global, &PL_vtbl_mglob, + NULL, 0); } i = m - orig; if (DO_UTF8(sv)) @@ -304,6 +308,7 @@ Perl_rxres_save(pTHX_ void **rsp, REGEXP *rx) { UV *p = (UV*)*rsp; U32 i; + PERL_UNUSED_CONTEXT; if (!p || p[1] < rx->nparens) { #ifdef PERL_OLD_COPY_ON_WRITE @@ -341,6 +346,7 @@ Perl_rxres_restore(pTHX_ void **rsp, REGEXP *rx) { UV *p = (UV*)*rsp; U32 i; + PERL_UNUSED_CONTEXT; RX_MATCH_COPY_FREE(rx); RX_MATCH_COPIED_set(rx, *p); @@ -367,13 +373,14 @@ void Perl_rxres_free(pTHX_ void **rsp) { UV * const p = (UV*)*rsp; + PERL_UNUSED_CONTEXT; if (p) { #ifdef PERL_POISON void *tmp = INT2PTR(char*,*p); Safefree(tmp); if (*p) - Poison(*p, 1, sizeof(*p)); + PoisonFree(*p, 1, sizeof(*p)); #else Safefree(INT2PTR(char*,*p)); #endif @@ -1613,7 +1620,7 @@ PP(pp_caller) RETURN; } - EXTEND(SP, 10); + EXTEND(SP, 11); if (!stashname) PUSHs(&PL_sv_undef); @@ -1688,11 +1695,10 @@ PP(pp_caller) /* XXX only hints propagated via op_private are currently * visible (others are not easily accessible, since they * use the global PL_hints) */ - PUSHs(sv_2mortal(newSViv((I32)cx->blk_oldcop->op_private & - HINT_PRIVATE_MASK))); + PUSHs(sv_2mortal(newSViv(CopHINTS_get(cx->blk_oldcop)))); { SV * mask ; - SV * const old_warnings = cx->blk_oldcop->cop_warnings ; + STRLEN * const old_warnings = cx->blk_oldcop->cop_warnings ; if (old_warnings == pWARN_NONE || (old_warnings == pWARN_STD && (PL_dowarn & G_WARN_ON) == 0)) @@ -1711,9 +1717,15 @@ PP(pp_caller) } } else - mask = newSVsv(old_warnings); + mask = newSVpvn((char *) (old_warnings + 1), old_warnings[0]); PUSHs(sv_2mortal(mask)); } + + PUSHs(cx->blk_oldcop->cop_hints ? + sv_2mortal(newRV_noinc( + (SV*)Perl_refcounted_he_chain_2hv(aTHX_ + cx->blk_oldcop->cop_hints))) + : &PL_sv_undef); RETURN; } @@ -2314,7 +2326,7 @@ PP(pp_goto) } /* First do some returnish stuff. */ - (void)SvREFCNT_inc(cv); /* avoid premature free during unwind */ + SvREFCNT_inc_simple_void(cv); /* avoid premature free during unwind */ FREETMPS; cxix = dopoptosub(cxstack_ix); if (cxix < 0) @@ -2370,7 +2382,7 @@ PP(pp_goto) SAVETMPS; SAVEFREESV(cv); /* later, undo the 'avoid premature free' hack */ if (CvISXSUB(cv)) { - OP* retop = cx->blk_sub.retop; + OP* const retop = cx->blk_sub.retop; SV **newsp; I32 gimme; if (reified) { @@ -2379,20 +2391,17 @@ PP(pp_goto) sv_2mortal(SP[-index]); } - /* XS subs don't have a CxSUB, so pop it */ - POPBLOCK(cx, PL_curpm); - /* Push a mark for the start of arglist */ - PUSHMARK(mark); - PUTBACK; - (void)(*CvXSUB(cv))(aTHX_ cv); - /* Put these at the bottom since the vars are set but not used */ - PERL_UNUSED_VAR(newsp); - PERL_UNUSED_VAR(gimme); + /* XS subs don't have a CxSUB, so pop it */ + POPBLOCK(cx, PL_curpm); + /* Push a mark for the start of arglist */ + PUSHMARK(mark); + PUTBACK; + (void)(*CvXSUB(cv))(aTHX_ cv); LEAVE; return retop; } else { - AV* padlist = CvPADLIST(cv); + AV* const padlist = CvPADLIST(cv); if (CxTYPE(cx) == CXt_EVAL) { PL_in_eval = cx->blk_eval.old_in_eval; PL_eval_root = cx->blk_eval.old_eval_root; @@ -2404,7 +2413,7 @@ PP(pp_goto) CvDEPTH(cv)++; if (CvDEPTH(cv) < 2) - (void)SvREFCNT_inc(cv); + SvREFCNT_inc_void_NN(cv); else { if (CvDEPTH(cv) == 100 && ckWARN(WARN_RECURSION)) sub_crush_depth(cv); @@ -2414,16 +2423,15 @@ PP(pp_goto) PAD_SET_CUR_NOSAVE(padlist, CvDEPTH(cv)); if (cx->blk_sub.hasargs) { - AV* av = (AV*)PAD_SVl(0); - SV** ary; + AV* const av = (AV*)PAD_SVl(0); cx->blk_sub.savearray = GvAV(PL_defgv); - GvAV(PL_defgv) = (AV*)SvREFCNT_inc(av); + GvAV(PL_defgv) = (AV*)SvREFCNT_inc_simple(av); CX_CURPAD_SAVE(cx->blk_sub); cx->blk_sub.argarray = av; if (items >= AvMAX(av) + 1) { - ary = AvALLOC(av); + SV **ary = AvALLOC(av); if (AvARRAY(av) != ary) { AvMAX(av) += AvARRAY(av) - AvALLOC(av); SvPV_set(av, (char*)ary); @@ -2456,8 +2464,6 @@ PP(pp_goto) * it's for informational purposes only. */ SV * const sv = GvSV(PL_DBsub); - CV *gotocv; - save_item(sv); if (PERLDB_SUB_NN) { const int type = SvTYPE(sv); @@ -2468,11 +2474,13 @@ PP(pp_goto) } else { gv_efullname3(sv, CvGV(cv), NULL); } - if ( PERLDB_GOTO - && (gotocv = get_cv("DB::goto", FALSE)) ) { - PUSHMARK( PL_stack_sp ); - call_sv((SV*)gotocv, G_SCALAR | G_NODEBUG); - PL_stack_sp--; + if (PERLDB_GOTO) { + CV * const gotocv = get_cv("DB::goto", FALSE); + if (gotocv) { + PUSHMARK( PL_stack_sp ); + call_sv((SV*)gotocv, G_SCALAR | G_NODEBUG); + PL_stack_sp--; + } } } RETURNOP(CvSTART(cv)); @@ -2499,7 +2507,7 @@ PP(pp_goto) /* find label */ - PL_lastgotoprobe = 0; + PL_lastgotoprobe = NULL; *enterops = 0; for (ix = cxstack_ix; ix >= 0; ix--) { cx = &cxstack[ix]; @@ -2626,7 +2634,13 @@ PP(pp_exit) #endif } PL_exit_flags |= PERL_EXIT_EXPECTED; +#ifdef PERL_MAD + /* KLUDGE: disable exit 0 in BEGIN blocks when we're just compiling */ + if (anum || !(PL_minus_c && PL_madskills)) + my_exit(anum); +#else my_exit(anum); +#endif PUSHs(&PL_sv_undef); RETURN; } @@ -2797,10 +2811,10 @@ Perl_sv_compile_2op(pTHX_ SV *sv, OP** startop, const char *code, PAD** padp) (*startop)->op_ppaddr = PL_ppaddr[OP_NULL]; lex_end(); /* XXX DAPM do this properly one year */ - *padp = (AV*)SvREFCNT_inc(PL_comppad); + *padp = (AV*)SvREFCNT_inc_simple(PL_comppad); LEAVE; if (IN_PERL_COMPILETIME) - PL_compiling.op_private = (U8)(PL_hints & HINT_PRIVATE_MASK); + CopHINTS_set(&PL_compiling, PL_hints); #ifdef OP_IN_REGISTER op = PL_opsave; #endif @@ -2879,14 +2893,15 @@ S_doeval(pTHX_ int gimme, OP** startop, CV* outside, U32 seq) cxstack[cxstack_ix].blk_eval.cv = PL_compcv; CvOUTSIDE_SEQ(PL_compcv) = seq; - CvOUTSIDE(PL_compcv) = (CV*)SvREFCNT_inc(outside); + CvOUTSIDE(PL_compcv) = (CV*)SvREFCNT_inc_simple(outside); /* set up a scratch pad */ CvPADLIST(PL_compcv) = pad_new(padnew_SAVE); - SAVEMORTALIZESV(PL_compcv); /* must remain until end of current statement */ + if (!PL_madskills) + SAVEMORTALIZESV(PL_compcv); /* must remain until end of current statement */ /* make sure we compile in the right package */ @@ -2899,12 +2914,17 @@ S_doeval(pTHX_ int gimme, OP** startop, CV* outside, U32 seq) SAVEFREESV(PL_beginav); SAVEI32(PL_error_count); +#ifdef PERL_MAD + SAVEI32(PL_madskills); + PL_madskills = 0; +#endif + /* try to compile it */ PL_eval_root = NULL; PL_error_count = 0; PL_curcop = &PL_compiling; - PL_curcop->cop_arybase = 0; + CopARYBASE_set(PL_curcop, 0); if (saveop && (saveop->op_type != OP_REQUIRE) && (saveop->op_flags & OPf_SPECIAL)) PL_in_eval |= EVAL_KEEPERR; else @@ -3000,14 +3020,10 @@ S_check_type_and_open(pTHX_ const char *name, const char *mode) { Stat_t st; const int st_rc = PerlLIO_stat(name, &st); - if (st_rc < 0) { + if (st_rc < 0 || S_ISDIR(st.st_mode) || S_ISBLK(st.st_mode)) { return NULL; } - if(S_ISDIR(st.st_mode) || S_ISBLK(st.st_mode)) { - Perl_die(aTHX_ "%s %s not allowed in require", - S_ISDIR(st.st_mode) ? "Directory" : "Block device", name); - } return PerlIO_open(name, mode); } @@ -3026,15 +3042,7 @@ S_doopen_pm(pTHX_ const char *name, const char *mode) fp = check_type_and_open(name, mode); } else { - Stat_t pmstat; - if (PerlLIO_stat(name, &pmstat) < 0 || - pmstat.st_mtime < pmcstat.st_mtime) - { - fp = check_type_and_open(pmc, mode); - } - else { - fp = check_type_and_open(name, mode); - } + fp = check_type_and_open(pmc, mode); } SvREFCNT_dec(pmcsv); } @@ -3186,7 +3194,7 @@ PP(pp_require) 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); + SvREFCNT_inc_simple_void(filter_child_proc); } else { if (IoOFP(io) && IoOFP(io) != IoIFP(io)) { @@ -3204,15 +3212,16 @@ PP(pp_require) if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVCV) { filter_sub = arg; - (void)SvREFCNT_inc(filter_sub); + SvREFCNT_inc_void_NN(filter_sub); if (i < count) { filter_state = SP[i]; - (void)SvREFCNT_inc(filter_state); + SvREFCNT_inc_simple_void(filter_state); } if (!tryrsfp) { - tryrsfp = PerlIO_open("/dev/null", PERL_SCRIPT_MODE); + tryrsfp = PerlIO_open(BIT_BUCKET, + PERL_SCRIPT_MODE); } } SP--; @@ -3343,7 +3352,7 @@ PP(pp_require) } else { SV** const svp = hv_fetch(GvHVn(PL_incgv), name, len, 0); if (!svp) - (void)hv_store(GvHVn(PL_incgv), name, len, SvREFCNT_inc(hook_sv), 0 ); + (void)hv_store(GvHVn(PL_incgv), name, len, SvREFCNT_inc_simple(hook_sv), 0 ); } ENTER; @@ -3355,13 +3364,15 @@ PP(pp_require) PL_rsfp = tryrsfp; SAVEHINTS(); PL_hints = 0; - SAVESPTR(PL_compiling.cop_warnings); + SAVECOMPILEWARNINGS(); if (PL_dowarn & G_WARN_ALL_ON) 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 = newSVpvn(WARN_TAINTstring, WARNsize); + 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 ; SAVESPTR(PL_compiling.cop_io); @@ -3453,13 +3464,8 @@ PP(pp_entereval) PL_hints = PL_op->op_targ; if (saved_hh) GvHV(PL_hintgv) = saved_hh; - 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); - } + SAVECOMPILEWARNINGS(); + PL_compiling.cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings); SAVESPTR(PL_compiling.cop_io); if (specialCopIO(PL_curcop->cop_io)) PL_compiling.cop_io = PL_curcop->cop_io; @@ -3467,6 +3473,15 @@ PP(pp_entereval) PL_compiling.cop_io = newSVsv(PL_curcop->cop_io); SAVEFREESV(PL_compiling.cop_io); } + if (PL_compiling.cop_hints) { + Perl_refcounted_he_free(aTHX_ PL_compiling.cop_hints); + } + PL_compiling.cop_hints = PL_curcop->cop_hints; + if (PL_compiling.cop_hints) { + HINTS_REFCNT_LOCK; + PL_compiling.cop_hints->refcounted_he_refcnt++; + HINTS_REFCNT_UNLOCK; + } /* special case: an eval '' executed within the DB package gets lexically * placed in the first non-DB CV rather than the current CV - this * allows the debugger to execute code, find lexicals etc, in the @@ -3559,22 +3574,57 @@ PP(pp_leaveeval) RETURNOP(retop); } -PP(pp_entertry) +/* Common code for Perl_call_sv and Perl_fold_constants, put here to keep it + close to the related Perl_create_eval_scope. */ +void +Perl_delete_eval_scope(pTHX) { - dVAR; dSP; + SV **newsp; + PMOP *newpm; + I32 gimme; register PERL_CONTEXT *cx; - const I32 gimme = GIMME_V; + I32 optype; + + POPBLOCK(cx,newpm); + POPEVAL(cx); + PL_curpm = newpm; + LEAVE; + PERL_UNUSED_VAR(newsp); + PERL_UNUSED_VAR(gimme); + PERL_UNUSED_VAR(optype); +} +/* Common-ish code salvaged from Perl_call_sv and pp_entertry, because it was + also needed by Perl_fold_constants. */ +PERL_CONTEXT * +Perl_create_eval_scope(pTHX_ U32 flags) +{ + PERL_CONTEXT *cx; + const I32 gimme = GIMME_V; + ENTER; SAVETMPS; - PUSHBLOCK(cx, (CXt_EVAL|CXp_TRYBLOCK), SP); + PUSHBLOCK(cx, (CXt_EVAL|CXp_TRYBLOCK), PL_stack_sp); PUSHEVAL(cx, 0, 0); - cx->blk_eval.retop = cLOGOP->op_other->op_next; + PL_eval_root = PL_op; /* Only needed so that goto works right. */ PL_in_eval = EVAL_INEVAL; - sv_setpvn(ERRSV,"",0); - PUTBACK; + if (flags & G_KEEPERR) + PL_in_eval |= EVAL_KEEPERR; + else + sv_setpvn(ERRSV,"",0); + if (flags & G_FAKINGEVAL) { + PL_eval_root = PL_op; /* Only needed so that goto works right. */ + } + return cx; +} + +PP(pp_entertry) +{ + dVAR; + PERL_CONTEXT *cx = create_eval_scope(0); + cx->blk_eval.retop = cLOGOP->op_other->op_next; return DOCATCH(PL_op->op_next); } @@ -3656,11 +3706,10 @@ PP(pp_leavegiven) I32 gimme; SV **newsp; PMOP *newpm; - SV **mark; + PERL_UNUSED_CONTEXT; POPBLOCK(cx,newpm); assert(CxTYPE(cx) == CXt_GIVEN); - mark = newsp; SP = newsp; PUTBACK; @@ -4025,7 +4074,7 @@ S_do_smartmatch(pTHX_ HV *seen_this, HV *seen_other) PUSHs(other); PUSHs(*svp); PUTBACK; - if ((PL_curcop->op_private & HINT_INTEGER) == HINT_INTEGER) + if (CopHINTS_get(PL_curcop) & HINT_INTEGER) (void) pp_i_eq(); else (void) pp_eq(); @@ -4119,7 +4168,7 @@ S_do_smartmatch(pTHX_ HV *seen_this, HV *seen_other) /* Otherwise, numeric comparison */ PUSHs(d); PUSHs(e); PUTBACK; - if ((PL_curcop->op_private & HINT_INTEGER) == HINT_INTEGER) + if (CopHINTS_get(PL_curcop) & HINT_INTEGER) (void) pp_i_eq(); else (void) pp_eq(); @@ -4489,14 +4538,23 @@ S_run_user_filter(pTHX_ int idx, SV *buf_sv, int maxlen) SV * const filter_state = (SV *)IoTOP_GV(datasv); SV * const filter_sub = (SV *)IoBOTTOM_GV(datasv); int len = 0; - + /* Filter API says that the filter appends to the contents of the buffer. + Usually the buffer is "", so the details don't matter. But if it's not, + then clearly what it contains is already filtered by this filter, so we + don't want to pass it in a second time. + I'm going to use a mortal in case the upstream filter croaks. */ + SV *const upstream + = ((SvOK(buf_sv) && sv_len(buf_sv)) || SvGMAGICAL(buf_sv)) + ? sv_newmortal() : buf_sv; + + SvUPGRADE(upstream, SVt_PV); /* 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); + len = FILTER_READ(idx+1, upstream, maxlen); } if (filter_sub && len >= 0) { @@ -4508,7 +4566,7 @@ S_run_user_filter(pTHX_ int idx, SV *buf_sv, int maxlen) SAVETMPS; EXTEND(SP, 2); - DEFSV = buf_sv; + DEFSV = upstream; PUSHMARK(SP); PUSHs(sv_2mortal(newSViv(maxlen))); if (filter_state) { @@ -4547,6 +4605,9 @@ S_run_user_filter(pTHX_ int idx, SV *buf_sv, int maxlen) filter_del(S_run_user_filter); } + if (upstream != buf_sv) { + sv_catsv(buf_sv, upstream); + } return len; }