X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=op.c;h=748888704c93069a5a85ef91e76a8fe457b63ad3;hb=e42df61ffa4b532a113a57b2965d347ce4da44b3;hp=ef8fc1a3c7fc3728114ae44ea551dd748ae2b67e;hpb=edbe35ea95baf286c38bf4d7db7d18b82ecce254;p=p5sagit%2Fp5-mst-13.2.git diff --git a/op.c b/op.c index ef8fc1a..7488887 100644 --- a/op.c +++ b/op.c @@ -1,7 +1,7 @@ /* op.c * - * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, - * 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, by Larry Wall and others + * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000, + * 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008 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. @@ -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 @@ -397,14 +399,6 @@ Perl_allocmy(pTHX_ const char *const name) /* check for duplicate declaration */ pad_check_dup(name, is_our, (PL_curstash ? PL_curstash : PL_defstash)); - if (PL_parser->in_my_stash && *name != '$') { - yyerror(Perl_form(aTHX_ - "Can't declare class for non-scalar %s in \"%s\"", - name, - is_our ? "our" - : PL_parser->in_my == KEY_state ? "state" : "my")); - } - /* allocate a spare slot and store the name in that slot */ off = pad_add_name(name, @@ -635,7 +629,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 +689,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 +777,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 +809,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 +1197,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 +1285,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 +1758,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 +2023,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 +2069,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 +2144,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 +2330,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 +2417,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 +2548,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 +2558,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 +2764,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 +2955,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 +2972,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 +3110,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 +3333,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 +3346,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 +3434,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 +4258,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 +4306,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; @@ -4331,7 +4325,7 @@ Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right) ((LISTOP*)right)->op_last->op_type == OP_CONST) { SV *sv = ((SVOP*)((LISTOP*)right)->op_last)->op_sv; - if (SvIVX(sv) == 0) + if (SvIOK(sv) && SvIVX(sv) == 0) sv_setiv(sv, PL_modcount+1); } } @@ -4353,6 +4347,7 @@ Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right) PL_eval_start = 0; else { if (!PL_madskills) { /* assignment to $[ is ignored when making a mad dump */ + deprecate("assignment to $["); op_free(o); o = newSVOP(OP_CONST, 0, newSViv(CopARYBASE_get(&PL_compiling))); o->op_private |= OPpCONST_ARYBASE; @@ -4422,7 +4417,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); @@ -4450,17 +4446,64 @@ Perl_newLOGOP(pTHX_ I32 type, I32 flags, OP *first, OP *other) } STATIC OP * +S_search_const(pTHX_ OP *o) +{ + PERL_ARGS_ASSERT_SEARCH_CONST; + + switch (o->op_type) { + case OP_CONST: + return o; + case OP_NULL: + if (o->op_flags & OPf_KIDS) + return search_const(cUNOPo->op_first); + break; + case OP_LEAVE: + case OP_SCOPE: + case OP_LINESEQ: + { + OP *kid; + if (!(o->op_flags & OPf_KIDS)) + return NULL; + kid = cLISTOPo->op_first; + do { + switch (kid->op_type) { + case OP_ENTER: + case OP_NULL: + case OP_NEXTSTATE: + kid = kid->op_sibling; + break; + default: + if (kid != cLISTOPo->op_last) + return NULL; + goto last; + } + } while (kid); + if (!kid) + kid = cLISTOPo->op_last; +last: + return search_const(kid); + } + } + + return NULL; +} + +STATIC OP * S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp) { dVAR; LOGOP *logop; OP *o; - OP *first = *firstp; - OP *other = *otherp; + OP *first; + OP *other; + OP *cstop = NULL; int prepend_not = 0; PERL_ARGS_ASSERT_NEW_LOGOP; + first = *firstp; + other = *otherp; + if (type == OP_XOR) /* Not short circuit, but here by precedence. */ return newBINOP(type, flags, scalar(first), scalar(other)); @@ -4476,31 +4519,22 @@ S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp) type = OP_OR; else type = OP_AND; - o = first; - first = *firstp = cUNOPo->op_first; - if (o->op_next) - first->op_next = o->op_next; - cUNOPo->op_first = NULL; - op_free(o); + op_null(first); if (other->op_type == OP_NOT) { /* !a AND|OR !b => !(a OR|AND b) */ - o = other; - other = *otherp = cUNOPo->op_first; - if (o->op_next) - other->op_next = o->op_next; - cUNOPo->op_first = NULL; - op_free(o); + op_null(other); prepend_not = 1; /* prepend a NOT op later */ } } } - if (first->op_type == OP_CONST) { - if (first->op_private & OPpCONST_STRICT) - no_bareword_allowed(first); - else if ((first->op_private & OPpCONST_BARE) && ckWARN(WARN_BAREWORD)) + /* search for a constant op that could let us fold the test */ + if ((cstop = search_const(first))) { + if (cstop->op_private & OPpCONST_STRICT) + no_bareword_allowed(cstop); + else if ((cstop->op_private & OPpCONST_BARE) && ckWARN(WARN_BAREWORD)) Perl_warner(aTHX_ packWARN(WARN_BAREWORD), "Bareword found in conditional"); - if ((type == OP_AND && SvTRUE(((SVOP*)first)->op_sv)) || - (type == OP_OR && !SvTRUE(((SVOP*)first)->op_sv)) || - (type == OP_DOR && !SvOK(((SVOP*)first)->op_sv))) { + if ((type == OP_AND && SvTRUE(((SVOP*)cstop)->op_sv)) || + (type == OP_OR && !SvTRUE(((SVOP*)cstop)->op_sv)) || + (type == OP_DOR && !SvOK(((SVOP*)cstop)->op_sv))) { *firstp = NULL; if (other->op_type == OP_CONST) other->op_private |= OPpCONST_SHORTCIRCUIT; @@ -4620,6 +4654,7 @@ Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop) LOGOP *logop; OP *start; OP *o; + OP *cstop; PERL_ARGS_ASSERT_NEWCONDOP; @@ -4629,14 +4664,14 @@ Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop) return newLOGOP(OP_OR, 0, first, falseop); scalarboolean(first); - if (first->op_type == OP_CONST) { + if ((cstop = search_const(first))) { /* Left or right arm of the conditional? */ - const bool left = SvTRUE(((SVOP*)first)->op_sv); + const bool left = SvTRUE(((SVOP*)cstop)->op_sv); OP *live = left ? trueop : falseop; OP *const dead = left ? falseop : trueop; - if (first->op_private & OPpCONST_BARE && - first->op_private & OPpCONST_STRICT) { - no_bareword_allowed(first); + if (cstop->op_private & OPpCONST_BARE && + cstop->op_private & OPpCONST_STRICT) { + no_bareword_allowed(cstop); } if (PL_madskills) { /* This is all dead code when PERL_MAD is not defined. */ @@ -5141,6 +5176,7 @@ S_looks_like_bool(pTHX_ const OP *o) switch(o->op_type) { case OP_OR: + case OP_DOR: return looks_like_bool(cLOGOPo->op_first); case OP_AND: @@ -5156,7 +5192,6 @@ S_looks_like_bool(pTHX_ const OP *o) case OP_ENTERSUB: case OP_NOT: case OP_XOR: - /* Note that OP_DOR is not here */ case OP_EQ: case OP_NE: case OP_LT: case OP_GT: case OP_LE: case OP_GE: @@ -5181,6 +5216,8 @@ S_looks_like_bool(pTHX_ const OP *o) case OP_DEFINED: case OP_EXISTS: case OP_MATCH: case OP_EOF: + case OP_FLOP: + return TRUE; case OP_CONST: @@ -5189,7 +5226,9 @@ S_looks_like_bool(pTHX_ const OP *o) || cSVOPo->op_sv == &PL_sv_no) return TRUE; - + else + return FALSE; + /* FALL THROUGH */ default: return FALSE; @@ -5274,7 +5313,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); @@ -5286,7 +5325,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)) { @@ -5346,14 +5385,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. @@ -5525,17 +5564,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; @@ -5544,12 +5584,6 @@ Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block) cv = (!name || GvCVGEN(gv)) ? NULL : GvCV(gv); -#ifdef GV_UNIQUE_CHECK - if (cv && GvUNIQUE(gv) && SvREADONLY(cv)) { - Perl_croak(aTHX_ "Can't define subroutine %s (GV is unique)", name); - } -#endif - if (!block || !ps || *ps || attrs || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS) #ifdef PERL_MAD @@ -5563,12 +5597,6 @@ Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block) if (cv) { const bool exists = CvROOT(cv) || CvXSUB(cv); -#ifdef GV_UNIQUE_CHECK - if (exists && GvUNIQUE(gv)) { - Perl_croak(aTHX_ "Can't redefine unique subroutine %s", name); - } -#endif - /* if the subroutine doesn't exist and wasn't pre-declared * with a prototype, assume it will be AUTOLOADed, * skipping the prototype check @@ -5622,7 +5650,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); @@ -5658,7 +5686,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))) @@ -5670,7 +5698,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 @@ -5716,7 +5744,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); } } @@ -5729,7 +5757,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); @@ -5754,6 +5782,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)); @@ -5812,7 +5846,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); } } } @@ -5845,7 +5879,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); @@ -5859,13 +5893,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; @@ -5874,7 +5908,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; @@ -5883,7 +5917,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; @@ -5900,6 +5934,11 @@ S_process_special_blocks(pTHX_ const char *const fullname, GV *const gv, Creates a constant sub equivalent to Perl C which is eligible for inlining at compile-time. +Passing NULL for SV creates a constant sub equivalent to C, +which won't be called if used as a destructor, but will suppress the overhead +of a call to C. (This form, however, isn't eligible for inlining at +compile time.) + =cut */ @@ -5909,14 +5948,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; @@ -5944,10 +5980,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) @@ -5989,7 +6025,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 @@ -6000,7 +6036,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; } @@ -6064,7 +6100,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; @@ -6103,20 +6139,19 @@ Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block) ? gv_fetchsv(cSVOPo->op_sv, GV_ADD, SVt_PVFM) : gv_fetchpvs("STDOUT", GV_ADD|GV_NOTQUAL, SVt_PVFM); -#ifdef GV_UNIQUE_CHECK - if (GvUNIQUE(gv)) { - Perl_croak(aTHX_ "Bad symbol for form (GV is unique)"); - } -#endif GvMULTI_on(gv); if ((cv = GvFORM(gv))) { if (ckWARN(WARN_REDEFINE)) { const line_t oldline = CopLINE(PL_curcop); if (PL_parser && PL_parser->copline != NOLINE) CopLINE_set(PL_curcop, PL_parser->copline); - Perl_warner(aTHX_ packWARN(WARN_REDEFINE), - o ? "Format %"SVf" redefined" - : "Format STDOUT redefined", SVfARG(cSVOPo->op_sv)); + if (o) { + Perl_warner(aTHX_ packWARN(WARN_REDEFINE), + "Format %"SVf" redefined", SVfARG(cSVOPo->op_sv)); + } else { + Perl_warner(aTHX_ packWARN(WARN_REDEFINE), + "Format STDOUT redefined"); + } CopLINE_set(PL_curcop, oldline); } SvREFCNT_dec(cv); @@ -6171,7 +6206,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 * @@ -6494,6 +6529,8 @@ Perl_ck_eval(pTHX_ OP *o) /* establish postfix order */ enter->op_next = (OP*)enter; + CHECKOP(OP_ENTERTRY, enter); + o = prepend_elem(OP_LINESEQ, (OP*)enter, (OP*)kid); o->op_type = OP_LEAVETRY; o->op_ppaddr = PL_ppaddr[OP_LEAVETRY]; @@ -6519,7 +6556,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; } @@ -6695,7 +6732,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 @@ -6975,7 +7012,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); } } @@ -7058,7 +7095,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; } @@ -7586,14 +7623,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; } @@ -7876,7 +7928,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\"", @@ -7922,7 +7974,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; } } @@ -8044,7 +8096,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); @@ -8500,7 +8552,7 @@ Perl_peep(pTHX_ register OP *o) /* Make the CONST have a shared SV */ svp = cSVOPx_svp(((BINOP*)o)->op_last); - if ((!SvFAKE(sv = *svp) || !SvREADONLY(sv)) && !IS_PADCONST(sv)) { + if (!SvFAKE(sv = *svp) || !SvREADONLY(sv)) { key = SvPV_const(sv, keylen); lexname = newSVpvn_share(key, SvUTF8(sv) ? -(I32)keylen : (I32)keylen, @@ -8905,6 +8957,7 @@ const_sv_xsub(pTHX_ CV* cv) { dVAR; dXSARGS; + SV *const sv = MUTABLE_SV(XSANY.any_ptr); if (items != 0) { NOOP; #if 0 @@ -8912,8 +8965,11 @@ const_sv_xsub(pTHX_ CV* cv) HvNAME_get(GvSTASH(CvGV(cv))), GvNAME(CvGV(cv))); #endif } + if (!sv) { + XSRETURN(0); + } EXTEND(sp, 1); - ST(0) = (SV*)XSANY.any_ptr; + ST(0) = sv; XSRETURN(1); }