X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=op.c;h=5103efb21537ee635765ff1c44e5785d9f8e753f;hb=08d0d8ab11be611f4baf746cfb6ff7791962f494;hp=3048a854b24013fa8b181b61dc57e3b4a7ed9630;hpb=1129b882ced9d5881a47214405219a2e6e332a92;p=p5sagit%2Fp5-mst-13.2.git diff --git a/op.c b/op.c index 3048a85..5103efb 100644 --- a/op.c +++ b/op.c @@ -9,11 +9,13 @@ */ /* - * "You see: Mr. Drogo, he married poor Miss Primula Brandybuck. She was - * our Mr. Bilbo's first cousin on the mother's side (her mother being the - * youngest of the Old Took's daughters); and Mr. Drogo was his second - * cousin. So Mr. Frodo is his first *and* second cousin, once removed - * either way, as the saying is, if you follow me." --the Gaffer + * 'You see: Mr. Drogo, he married poor Miss Primula Brandybuck. She was + * our Mr. Bilbo's first cousin on the mother's side (her mother being the + * youngest of the Old Took's daughters); and Mr. Drogo was his second + * cousin. So Mr. Frodo is his first *and* second cousin, once removed + * either way, as the saying is, if you follow me.' --the Gaffer + * + * [p.23 of _The Lord of the Rings_, I/i: "A Long-Expected Party"] */ /* This file contains the functions that create, manipulate and optimize @@ -635,7 +637,7 @@ Perl_op_clear(pTHX_ OP *o) pad_swipe(cPMOPo->op_pmreplrootu.op_pmtargetoff, TRUE); } #else - SvREFCNT_dec((SV*)cPMOPo->op_pmreplrootu.op_pmtargetgv); + SvREFCNT_dec(MUTABLE_SV(cPMOPo->op_pmreplrootu.op_pmtargetgv)); #endif /* FALL THROUGH */ case OP_MATCH: @@ -695,7 +697,7 @@ S_forget_pmop(pTHX_ PMOP *const o PERL_ARGS_ASSERT_FORGET_PMOP; if (pmstash && !SvIS_FREED(pmstash)) { - MAGIC * const mg = mg_find((SV*)pmstash, PERL_MAGIC_symtab); + MAGIC * const mg = mg_find((const SV *)pmstash, PERL_MAGIC_symtab); if (mg) { PMOP **const array = (PMOP**) mg->mg_ptr; U32 count = mg->mg_len / sizeof(PMOP**); @@ -783,8 +785,8 @@ Perl_op_refcnt_unlock(pTHX) #define LINKLIST(o) ((o)->op_next ? (o)->op_next : linklist((OP*)o)) -OP * -Perl_linklist(pTHX_ OP *o) +static OP * +S_linklist(pTHX_ OP *o) { OP *first; @@ -815,8 +817,8 @@ Perl_linklist(pTHX_ OP *o) return o->op_next; } -OP * -Perl_scalarkids(pTHX_ OP *o) +static OP * +S_scalarkids(pTHX_ OP *o) { if (o && o->op_flags & OPf_KIDS) { OP *kid; @@ -1203,8 +1205,8 @@ Perl_scalarvoid(pTHX_ OP *o) return o; } -OP * -Perl_listkids(pTHX_ OP *o) +static OP * +S_listkids(pTHX_ OP *o) { if (o && o->op_flags & OPf_KIDS) { OP *kid; @@ -1291,8 +1293,8 @@ Perl_list(pTHX_ OP *o) return o; } -OP * -Perl_scalarseq(pTHX_ OP *o) +static OP * +S_scalarseq(pTHX_ OP *o) { dVAR; if (o) { @@ -1764,8 +1766,8 @@ S_is_handle_constructor(const OP *o, I32 numargs) } } -OP * -Perl_refkids(pTHX_ OP *o, I32 type) +static OP * +S_refkids(pTHX_ OP *o, I32 type) { if (o && o->op_flags & OPf_KIDS) { OP *kid; @@ -2029,7 +2031,7 @@ Perl_apply_attrs_string(pTHX_ const char *stashpv, CV *cv, newSVOP(OP_CONST, 0, newSVpv(stashpv,0)), prepend_elem(OP_LIST, newSVOP(OP_CONST, 0, - newRV((SV*)cv)), + newRV(MUTABLE_SV(cv))), attrs))); } @@ -2075,8 +2077,8 @@ S_my_kid(pTHX_ OP *o, OP *attrs, OP **imopsp) PL_parser->in_my_stash = NULL; apply_attrs(GvSTASH(gv), (type == OP_RV2SV ? GvSV(gv) : - type == OP_RV2AV ? (SV*)GvAV(gv) : - type == OP_RV2HV ? (SV*)GvHV(gv) : (SV*)gv), + type == OP_RV2AV ? MUTABLE_SV(GvAV(gv)) : + type == OP_RV2HV ? MUTABLE_SV(GvHV(gv)) : MUTABLE_SV(gv)), attrs, FALSE); } o->op_private |= OPpOUR_INTRO; @@ -2150,14 +2152,6 @@ Perl_my_attrs(pTHX_ OP *o, OP *attrs) } OP * -Perl_my(pTHX_ OP *o) -{ - PERL_ARGS_ASSERT_MY; - - return my_attrs(o, NULL); -} - -OP * Perl_sawparens(pTHX_ OP *o) { PERL_UNUSED_CONTEXT; @@ -2344,14 +2338,13 @@ Perl_newPROG(pTHX_ OP *o) /* Register with debugger */ if (PERLDB_INTER) { - CV * const cv - = Perl_get_cvn_flags(aTHX_ STR_WITH_LEN("DB::postponed"), 0); + CV * const cv = get_cvs("DB::postponed", 0); if (cv) { dSP; PUSHMARK(SP); - XPUSHs((SV*)CopFILEGV(&PL_compiling)); + XPUSHs(MUTABLE_SV(CopFILEGV(&PL_compiling))); PUTBACK; - call_sv((SV*)cv, G_DISCARD); + call_sv(MUTABLE_SV(cv), G_DISCARD); } } } @@ -2432,8 +2425,8 @@ Perl_jmaybe(pTHX_ OP *o) return o; } -OP * -Perl_fold_constants(pTHX_ register OP *o) +static OP * +S_fold_constants(pTHX_ register OP *o) { dVAR; register OP * VOL curop; @@ -2563,9 +2556,9 @@ Perl_fold_constants(pTHX_ register OP *o) #endif assert(sv); if (type == OP_RV2GV) - newop = newGVOP(OP_GV, 0, (GV*)sv); + newop = newGVOP(OP_GV, 0, MUTABLE_GV(sv)); else - newop = newSVOP(OP_CONST, 0, (SV*)sv); + newop = newSVOP(OP_CONST, 0, MUTABLE_SV(sv)); op_getmad(o,newop,'f'); return newop; @@ -2573,8 +2566,8 @@ Perl_fold_constants(pTHX_ register OP *o) return o; } -OP * -Perl_gen_constant_list(pTHX_ register OP *o) +static OP * +S_gen_constant_list(pTHX_ register OP *o) { dVAR; register OP *curop; @@ -2779,7 +2772,7 @@ Perl_token_getmad(pTHX_ TOKEN* tk, OP* o, char slot) /* faked up qw list? */ if (slot == '(' && tm->mad_type == MAD_SV && - SvPVX((SV*)tm->mad_val)[0] == 'q') + SvPVX((const SV *)tm->mad_val)[0] == 'q') slot = 'x'; if (o) { @@ -2970,7 +2963,7 @@ Perl_mad_free(pTHX_ MADPROP* mp) op_free((OP*)mp->mad_val); break; case MAD_SV: - sv_free((SV*)mp->mad_val); + sv_free(MUTABLE_SV(mp->mad_val)); break; default: PerlIO_printf(PerlIO_stderr(), "Unrecognized mad\n"); @@ -2987,8 +2980,8 @@ Perl_newNULLLIST(pTHX) return newOP(OP_STUB, 0); } -OP * -Perl_force_list(pTHX_ OP *o) +static OP * +S_force_list(pTHX_ OP *o) { if (!o || o->op_type != OP_LIST) o = newLISTOP(OP_LIST, 0, o, NULL); @@ -3125,8 +3118,8 @@ static int uvcompare(const void *a, const void *b) return 0; } -OP * -Perl_pmtrans(pTHX_ OP *o, OP *expr, OP *repl) +static OP * +S_pmtrans(pTHX_ OP *o, OP *expr, OP *repl) { dVAR; SV * const tstr = ((SVOP*)expr)->op_sv; @@ -3348,7 +3341,7 @@ Perl_pmtrans(pTHX_ OP *o, OP *expr, OP *repl) PerlMemShared_free(cPVOPo->op_pv); cPVOPo->op_pv = NULL; - swash = (SV*)swash_init("utf8", "", listsv, bits, none); + swash = MUTABLE_SV(swash_init("utf8", "", listsv, bits, none)); #ifdef USE_ITHREADS cPADOPo->op_padix = pad_alloc(OP_TRANS, SVs_PADTMP); SvREFCNT_dec(PAD_SVl(cPADOPo->op_padix)); @@ -3361,7 +3354,7 @@ Perl_pmtrans(pTHX_ OP *o, OP *expr, OP *repl) SvREFCNT_dec(transv); if (!del && havefinal && rlen) - (void)hv_store((HV*)SvRV(swash), "FINAL", 5, + (void)hv_store(MUTABLE_HV(SvRV(swash)), "FINAL", 5, newSVuv((UV)final), 0); if (grows) @@ -3449,6 +3442,15 @@ Perl_pmtrans(pTHX_ OP *o, OP *expr, OP *repl) } } } + + if(ckWARN(WARN_MISC)) { + if(del && rlen == tlen) { + Perl_warner(aTHX_ packWARN(WARN_MISC), "Useless use of /d modifier in transliteration operator"); + } else if(rlen > tlen) { + Perl_warner(aTHX_ packWARN(WARN_MISC), "Replacement list is longer than search list"); + } + } + if (grows) o->op_private |= OPpTRANS_GROWS; #ifdef PERL_MAD @@ -4264,7 +4266,7 @@ Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right) else if (curop->op_type == OP_PUSHRE) { #ifdef USE_ITHREADS if (((PMOP*)curop)->op_pmreplrootu.op_pmtargetoff) { - GV *const gv = (GV*)PAD_SVl(((PMOP*)curop)->op_pmreplrootu.op_pmtargetoff); + GV *const gv = MUTABLE_GV(PAD_SVl(((PMOP*)curop)->op_pmreplrootu.op_pmtargetoff)); if (gv == PL_defgv || (int)GvASSIGN_GENERATION(gv) == PL_generation) break; @@ -4312,7 +4314,7 @@ Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right) cPADOPx(tmpop)->op_padix = 0; /* steal it */ #else pm->op_pmreplrootu.op_pmtargetgv - = (GV*)cSVOPx(tmpop)->op_sv; + = MUTABLE_GV(cSVOPx(tmpop)->op_sv); cSVOPx(tmpop)->op_sv = NULL; /* steal it */ #endif pm->op_pmflags |= PMf_ONCE; @@ -4422,7 +4424,8 @@ Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o) #endif CopSTASH_set(cop, PL_curstash); - if (PERLDB_LINE && PL_curstash != PL_debstash) { + if ((PERLDB_LINE || PERLDB_SAVESRC) && PL_curstash != PL_debstash) { + /* this line can have a breakpoint - store the cop in IV */ AV *av = CopFILEAVx(PL_curcop); if (av) { SV * const * const svp = av_fetch(av, (I32)CopLINE(cop), FALSE); @@ -5313,7 +5316,7 @@ Perl_cv_undef(pTHX_ CV *cv) CvSTART(cv) = NULL; LEAVE; } - SvPOK_off((SV*)cv); /* forget prototype */ + SvPOK_off(MUTABLE_SV(cv)); /* forget prototype */ CvGV(cv) = NULL; pad_undef(cv); @@ -5325,7 +5328,7 @@ Perl_cv_undef(pTHX_ CV *cv) CvOUTSIDE(cv) = NULL; } if (CvCONST(cv)) { - SvREFCNT_dec((SV*)CvXSUBANY(cv).any_ptr); + SvREFCNT_dec(MUTABLE_SV(CvXSUBANY(cv).any_ptr)); CvCONST_off(cv); } if (CvISXSUB(cv) && CvXSUB(cv)) { @@ -5385,14 +5388,14 @@ L. =cut */ SV * -Perl_cv_const_sv(pTHX_ CV *cv) +Perl_cv_const_sv(pTHX_ const CV *const cv) { PERL_UNUSED_CONTEXT; if (!cv) return NULL; if (!(SvTYPE(cv) == SVt_PVCV || SvTYPE(cv) == SVt_PVFM)) return NULL; - return CvCONST(cv) ? (SV*)CvXSUBANY(cv).any_ptr : NULL; + return CvCONST(cv) ? MUTABLE_SV(CvXSUBANY(cv).any_ptr) : NULL; } /* op_const_sv: examine an optree to determine whether it's in-lineable. @@ -5564,17 +5567,18 @@ Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block) if (SvTYPE(gv) != SVt_PVGV) { /* Maybe prototype now, and had at maximum a prototype before. */ if (SvTYPE(gv) > SVt_NULL) { - if (!SvPOK((SV*)gv) && !(SvIOK((SV*)gv) && SvIVX((SV*)gv) == -1) + if (!SvPOK((const SV *)gv) + && !(SvIOK((const SV *)gv) && SvIVX((const SV *)gv) == -1) && ckWARN_d(WARN_PROTOTYPE)) { Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "Runaway prototype"); } - cv_ckproto_len((CV*)gv, NULL, ps, ps_len); + cv_ckproto_len((const CV *)gv, NULL, ps, ps_len); } if (ps) - sv_setpvn((SV*)gv, ps, ps_len); + sv_setpvn(MUTABLE_SV(gv), ps, ps_len); else - sv_setiv((SV*)gv, -1); + sv_setiv(MUTABLE_SV(gv), -1); SvREFCNT_dec(PL_compcv); cv = PL_compcv = NULL; @@ -5661,7 +5665,7 @@ Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block) SvREFCNT_inc_simple_void_NN(const_sv); if (cv) { assert(!CvROOT(cv) && !CvCONST(cv)); - sv_setpvn((SV*)cv, "", 0); /* prototype is "" */ + sv_setpvs(MUTABLE_SV(cv), ""); /* prototype is "" */ CvXSUBANY(cv).any_ptr = const_sv; CvXSUB(cv) = const_sv_xsub; CvCONST_on(cv); @@ -5697,7 +5701,7 @@ Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block) || block->op_type == OP_NULL #endif )) { - rcv = (SV*)cv; + rcv = MUTABLE_SV(cv); /* Might have had built-in attributes applied -- propagate them. */ CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS); if (CvGV(cv) && GvSTASH(CvGV(cv))) @@ -5709,7 +5713,7 @@ Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block) } else { /* possibly about to re-define existing subr -- ignore old cv */ - rcv = (SV*)PL_compcv; + rcv = MUTABLE_SV(PL_compcv); if (name && GvSTASH(gv)) stash = GvSTASH(gv); else @@ -5755,7 +5759,7 @@ Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block) GvCV(gv) = cv; if (PL_madskills) { if (strEQ(name, "import")) { - PL_formfeed = (SV*)cv; + PL_formfeed = MUTABLE_SV(cv); Perl_warner(aTHX_ packWARN(WARN_VOID), "%lx\n", (long)cv); } } @@ -5768,7 +5772,7 @@ Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block) CvSTASH(cv) = PL_curstash; if (ps) - sv_setpvn((SV*)cv, ps, ps_len); + sv_setpvn(MUTABLE_SV(cv), ps, ps_len); if (PL_parser && PL_parser->error_count) { op_free(block); @@ -5793,6 +5797,12 @@ Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block) if (!block) goto done; + /* If we assign an optree to a PVCV, then we've defined a subroutine that + the debugger could be able to set a breakpoint in, so signal to + pp_entereval that it should not throw away any saved lines at scope + exit. */ + + PL_breakable_sub_gen++; if (CvLVALUE(cv)) { CvROOT(cv) = newUNOP(OP_LEAVESUBLV, 0, mod(scalarseq(block), OP_LEAVESUBLV)); @@ -5851,7 +5861,7 @@ Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block) PUSHMARK(SP); XPUSHs(tmpstr); PUTBACK; - call_sv((SV*)pcv, G_DISCARD); + call_sv(MUTABLE_SV(pcv), G_DISCARD); } } } @@ -5884,7 +5894,7 @@ S_process_special_blocks(pTHX_ const char *const fullname, GV *const gv, SAVECOPLINE(&PL_compiling); DEBUG_x( dump_sub(gv) ); - Perl_av_create_and_push(aTHX_ &PL_beginav, (SV*)cv); + Perl_av_create_and_push(aTHX_ &PL_beginav, MUTABLE_SV(cv)); GvCV(gv) = 0; /* cv has been hijacked */ call_list(oldscope, PL_beginav); @@ -5898,13 +5908,13 @@ S_process_special_blocks(pTHX_ const char *const fullname, GV *const gv, if (*name == 'E') { if strEQ(name, "END") { DEBUG_x( dump_sub(gv) ); - Perl_av_create_and_unshift_one(aTHX_ &PL_endav, (SV*)cv); + Perl_av_create_and_unshift_one(aTHX_ &PL_endav, MUTABLE_SV(cv)); } else return; } else if (*name == 'U') { if (strEQ(name, "UNITCHECK")) { /* It's never too late to run a unitcheck block */ - Perl_av_create_and_unshift_one(aTHX_ &PL_unitcheckav, (SV*)cv); + Perl_av_create_and_unshift_one(aTHX_ &PL_unitcheckav, MUTABLE_SV(cv)); } else return; @@ -5913,7 +5923,7 @@ S_process_special_blocks(pTHX_ const char *const fullname, GV *const gv, if (PL_main_start && ckWARN(WARN_VOID)) Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run CHECK block"); - Perl_av_create_and_unshift_one(aTHX_ &PL_checkav, (SV*)cv); + Perl_av_create_and_unshift_one(aTHX_ &PL_checkav, MUTABLE_SV(cv)); } else return; @@ -5922,7 +5932,7 @@ S_process_special_blocks(pTHX_ const char *const fullname, GV *const gv, if (PL_main_start && ckWARN(WARN_VOID)) Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run INIT block"); - Perl_av_create_and_push(aTHX_ &PL_initav, (SV*)cv); + Perl_av_create_and_push(aTHX_ &PL_initav, MUTABLE_SV(cv)); } else return; @@ -5948,14 +5958,11 @@ Perl_newCONSTSUB(pTHX_ HV *stash, const char *name, SV *sv) dVAR; CV* cv; #ifdef USE_ITHREADS - const char *const temp_p = CopFILE(PL_curcop); - const STRLEN len = temp_p ? strlen(temp_p) : 0; + const char *const file = CopFILE(PL_curcop); #else SV *const temp_sv = CopFILESV(PL_curcop); - STRLEN len; - const char *const temp_p = temp_sv ? SvPV_const(temp_sv, len) : NULL; + const char *const file = temp_sv ? SvPV_nolen_const(temp_sv) : NULL; #endif - char *const file = savepvn(temp_p, temp_p ? len : 0); ENTER; @@ -5983,10 +5990,10 @@ Perl_newCONSTSUB(pTHX_ HV *stash, const char *name, SV *sv) and so doesn't get free()d. (It's expected to be from the C pre- processor __FILE__ directive). But we need a dynamically allocated one, and we need it to get freed. */ - cv = newXS_flags(name, const_sv_xsub, file, "", XS_DYNAMIC_FILENAME); + cv = newXS_flags(name, const_sv_xsub, file ? file : "", "", + XS_DYNAMIC_FILENAME); CvXSUBANY(cv).any_ptr = sv; CvCONST_on(cv); - Safefree(file); #ifdef USE_ITHREADS if (stash) @@ -6028,7 +6035,7 @@ Perl_newXS_flags(pTHX_ const char *name, XSUBADDR_t subaddr, } /* This gets free()d. :-) */ - sv_usepvn_flags((SV*)cv, proto_and_file, proto_and_file_len, + sv_usepvn_flags(MUTABLE_SV(cv), proto_and_file, proto_and_file_len, SV_HAS_TRAILING_NUL); if (proto) { /* This gives us the correct prototype, rather than one with the @@ -6039,7 +6046,7 @@ Perl_newXS_flags(pTHX_ const char *name, XSUBADDR_t subaddr, } CvFILE(cv) = proto_and_file + proto_len; } else { - sv_setpv((SV *)cv, proto); + sv_setpv(MUTABLE_SV(cv), proto); } return cv; } @@ -6103,7 +6110,7 @@ Perl_newXS(pTHX_ const char *name, XSUBADDR_t subaddr, const char *filename) if (cv) /* must reuse cv if autoloaded */ cv_undef(cv); else { - cv = (CV*)newSV_type(SVt_PVCV); + cv = MUTABLE_CV(newSV_type(SVt_PVCV)); if (name) { GvCV(gv) = cv; GvCVGEN(gv) = 0; @@ -6210,7 +6217,7 @@ Perl_newANONATTRSUB(pTHX_ I32 floor, OP *proto, OP *attrs, OP *block) { return newUNOP(OP_REFGEN, 0, newSVOP(OP_ANONCODE, 0, - (SV*)newATTRSUB(floor, 0, proto, attrs, block))); + MUTABLE_SV(newATTRSUB(floor, 0, proto, attrs, block)))); } OP * @@ -6558,7 +6565,7 @@ Perl_ck_eval(pTHX_ OP *o) if ((PL_hints & HINT_LOCALIZE_HH) != 0 && GvHV(PL_hintgv)) { /* Store a copy of %^H that pp_entereval can pick up. */ OP *hhop = newSVOP(OP_HINTSEVAL, 0, - (SV*)Perl_hv_copy_hints_hv(aTHX_ GvHV(PL_hintgv))); + MUTABLE_SV(Perl_hv_copy_hints_hv(aTHX_ GvHV(PL_hintgv)))); cUNOPo->op_first->op_sibling = hhop; o->op_private |= OPpEVAL_HAS_HH; } @@ -6734,7 +6741,7 @@ Perl_ck_rvconst(pTHX_ register OP *o) kPADOP->op_padix = pad_alloc(OP_GV, SVs_PADTMP); SvREFCNT_dec(PAD_SVl(kPADOP->op_padix)); GvIN_PAD_on(gv); - PAD_SETSV(kPADOP->op_padix, (SV*) SvREFCNT_inc_simple_NN(gv)); + PAD_SETSV(kPADOP->op_padix, MUTABLE_SV(SvREFCNT_inc_simple_NN(gv))); #else kid->op_sv = SvREFCNT_inc_simple_NN(gv); #endif @@ -7014,7 +7021,7 @@ Perl_ck_fun(pTHX_ OP *o) namesv = PAD_SVl(targ); SvUPGRADE(namesv, SVt_PV); if (*name != '$') - sv_setpvn(namesv, "$", 1); + sv_setpvs(namesv, "$"); sv_catpvn(namesv, name, len); } } @@ -7097,7 +7104,7 @@ Perl_ck_glob(pTHX_ OP *o) gv = gv_fetchpvs("CORE::GLOBAL::glob", 0, SVt_PVCV); glob_gv = gv_fetchpvs("File::Glob::csh_glob", 0, SVt_PVCV); GvCV(gv) = GvCV(glob_gv); - SvREFCNT_inc_void((SV*)GvCV(gv)); + SvREFCNT_inc_void(MUTABLE_SV(GvCV(gv))); GvIMPORTED_CV_on(gv); LEAVE; } @@ -7625,14 +7632,29 @@ OP * Perl_ck_return(pTHX_ OP *o) { dVAR; + OP *kid; PERL_ARGS_ASSERT_CK_RETURN; + kid = cLISTOPo->op_first->op_sibling; if (CvLVALUE(PL_compcv)) { - OP *kid; - for (kid = cLISTOPo->op_first->op_sibling; kid; kid = kid->op_sibling) + for (; kid; kid = kid->op_sibling) mod(kid, OP_LEAVESUBLV); + } else { + for (; kid; kid = kid->op_sibling) + if ((kid->op_type == OP_NULL) + && ((kid->op_flags & (OPf_SPECIAL|OPf_KIDS)) == (OPf_SPECIAL|OPf_KIDS))) { + /* This is a do block */ + OP *op = kUNOP->op_first; + if (op->op_type == OP_LEAVE && op->op_flags & OPf_KIDS) { + op = cUNOPx(op)->op_first; + assert(op->op_type == OP_ENTER && !(op->op_flags & OPf_SPECIAL)); + /* Force the use of the caller's context */ + op->op_flags |= OPf_SPECIAL; + } + } } + return o; } @@ -7915,7 +7937,7 @@ Perl_ck_join(pTHX_ OP *o) if (kid && kid->op_type == OP_MATCH) { if (ckWARN(WARN_SYNTAX)) { const REGEXP *re = PM_GETRE(kPMOP); - const char *pmstr = re ? RX_PRECOMP(re) : "STRING"; + const char *pmstr = re ? RX_PRECOMP_const(re) : "STRING"; const STRLEN len = re ? RX_PRELEN(re) : 6; Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "/%.*s/ should probably be written as \"%.*s\"", @@ -7961,7 +7983,7 @@ Perl_ck_subr(pTHX_ OP *o) if (SvPOK(cv)) { STRLEN len; namegv = CvANON(cv) ? gv : CvGV(cv); - proto = SvPV((SV*)cv, len); + proto = SvPV(MUTABLE_SV(cv), len); proto_end = proto + len; } } @@ -8083,7 +8105,7 @@ Perl_ck_subr(pTHX_ OP *o) const char *p = proto; const char *const end = proto; contextclass = 0; - while (*--p != '['); + while (*--p != '[') {} bad_type(arg, Perl_form(aTHX_ "one of %.*s", (int)(end - p), p), gv_ename(namegv), o3); @@ -8952,7 +8974,7 @@ const_sv_xsub(pTHX_ CV* cv) #endif } EXTEND(sp, 1); - ST(0) = (SV*)XSANY.any_ptr; + ST(0) = MUTABLE_SV(XSANY.any_ptr); XSRETURN(1); }