X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=op.c;h=c541fd1c2742ae824bca9eca71d2501c7fdb92c4;hb=aec46f14fac1bc74bf8ad4054a6f9674b324f8d2;hp=82642326b2201fcebf9ba10e0677745ab2c5a507;hpb=4d4948808560f73c9be361930114c89552276998;p=p5sagit%2Fp5-mst-13.2.git diff --git a/op.c b/op.c index 8264232..c541fd1 100644 --- a/op.c +++ b/op.c @@ -128,8 +128,8 @@ Perl_Slab_Alloc(pTHX_ int m, size_t sz) void Perl_Slab_Free(pTHX_ void *op) { - I32 **ptr = (I32 **) op; - I32 *slab = ptr[-1]; + I32 ** const ptr = (I32 **) op; + I32 * const slab = ptr[-1]; assert( ptr-1 > (I32 **) slab ); assert( ptr < ( (I32 **) slab + PERL_SLAB_SIZE) ); assert( *slab > 0 ); @@ -158,13 +158,12 @@ Perl_Slab_Free(pTHX_ void *op) #define RETURN_UNLIMITED_NUMBER (PERL_INT_MAX / 2) -STATIC char* +STATIC const char* S_gv_ename(pTHX_ GV *gv) { - STRLEN n_a; - SV* tmpsv = sv_newmortal(); + SV* const tmpsv = sv_newmortal(); gv_efullname3(tmpsv, gv, Nullch); - return SvPV(tmpsv,n_a); + return SvPV_nolen_const(tmpsv); } STATIC OP * @@ -270,6 +269,7 @@ Perl_allocmy(pTHX_ char *name) void Perl_op_free(pTHX_ OP *o) { + dVAR; OPCODE type; PADOFFSET refcnt; @@ -323,6 +323,7 @@ void Perl_op_clear(pTHX_ OP *o) { + dVAR; switch (o->op_type) { case OP_NULL: /* Was holding old type, if any. */ case OP_ENTEREVAL: /* Was holding hints. */ @@ -405,18 +406,21 @@ clear_pmop: { HV *pmstash = PmopSTASH(cPMOPo); if (pmstash && SvREFCNT(pmstash)) { - PMOP *pmop = HvPMROOT(pmstash); - PMOP *lastpmop = NULL; - while (pmop) { - if (cPMOPo == pmop) { - if (lastpmop) - lastpmop->op_pmnext = pmop->op_pmnext; - else - HvPMROOT(pmstash) = pmop->op_pmnext; - break; + MAGIC *mg = mg_find((SV*)pmstash, PERL_MAGIC_symtab); + if (mg) { + PMOP *pmop = (PMOP*) mg->mg_obj; + PMOP *lastpmop = NULL; + while (pmop) { + if (cPMOPo == pmop) { + if (lastpmop) + lastpmop->op_pmnext = pmop->op_pmnext; + else + mg->mg_obj = (SV*) pmop->op_pmnext; + break; + } + lastpmop = pmop; + pmop = pmop->op_pmnext; } - lastpmop = pmop; - pmop = pmop->op_pmnext; } } PmopSTASH_free(cPMOPo); @@ -471,6 +475,7 @@ S_cop_free(pTHX_ COP* cop) void Perl_op_null(pTHX_ OP *o) { + dVAR; if (o->op_type == OP_NULL) return; op_clear(o); @@ -482,12 +487,14 @@ Perl_op_null(pTHX_ OP *o) void Perl_op_refcnt_lock(pTHX) { + dVAR; OP_REFCNT_LOCK; } void Perl_op_refcnt_unlock(pTHX) { + dVAR; OP_REFCNT_UNLOCK; } @@ -549,6 +556,7 @@ S_scalarboolean(pTHX_ OP *o) OP * Perl_scalar(pTHX_ OP *o) { + dVAR; OP *kid; /* assumes no premature commitment */ @@ -619,6 +627,7 @@ Perl_scalar(pTHX_ OP *o) OP * Perl_scalarvoid(pTHX_ OP *o) { + dVAR; OP *kid; const char* useless = 0; SV* sv; @@ -775,9 +784,9 @@ Perl_scalarvoid(pTHX_ OP *o) built upon these three nroff macros being used in void context. The pink camel has the details in the script wrapman near page 319. */ - if (strnEQ(SvPVX(sv), "di", 2) || - strnEQ(SvPVX(sv), "ds", 2) || - strnEQ(SvPVX(sv), "ig", 2)) + if (strnEQ(SvPVX_const(sv), "di", 2) || + strnEQ(SvPVX_const(sv), "ds", 2) || + strnEQ(SvPVX_const(sv), "ig", 2)) useless = 0; } } @@ -858,6 +867,7 @@ Perl_listkids(pTHX_ OP *o) OP * Perl_list(pTHX_ OP *o) { + dVAR; OP *kid; /* assumes no premature commitment */ @@ -981,6 +991,7 @@ S_modkids(pTHX_ OP *o, I32 type) OP * Perl_mod(pTHX_ OP *o, I32 type) { + dVAR; OP *kid; /* -1 = error on localize, 0 = ignore localize, 1 = ok to localize */ int localize = -1; @@ -1367,12 +1378,12 @@ S_scalar_mod_type(pTHX_ const OP *o, I32 type) } STATIC bool -S_is_handle_constructor(pTHX_ const OP *o, I32 argnum) +S_is_handle_constructor(pTHX_ const OP *o, I32 numargs) { switch (o->op_type) { case OP_PIPE_OP: case OP_SOCKPAIR: - if (argnum == 2) + if (numargs == 2) return TRUE; /* FALL THROUGH */ case OP_SYSOPEN: @@ -1381,7 +1392,7 @@ S_is_handle_constructor(pTHX_ const OP *o, I32 argnum) case OP_SOCKET: case OP_OPEN_DIR: case OP_ACCEPT: - if (argnum == 1) + if (numargs == 1) return TRUE; /* FALL THROUGH */ default: @@ -1403,6 +1414,7 @@ Perl_refkids(pTHX_ OP *o, I32 type) OP * Perl_ref(pTHX_ OP *o, I32 type) { + dVAR; OP *kid; if (!o || PL_error_count) @@ -1515,23 +1527,20 @@ S_dup_attrlist(pTHX_ OP *o) STATIC void S_apply_attrs(pTHX_ HV *stash, SV *target, OP *attrs, bool for_my) { + dVAR; SV *stashsv; /* fake up C */ ENTER; /* need to protect against side-effects of 'use' */ SAVEINT(PL_expect); - if (stash) - stashsv = newSVpv(HvNAME(stash), 0); - else - stashsv = &PL_sv_no; + stashsv = stash ? newSVhek(HvNAME_HEK(stash)) : &PL_sv_no; #define ATTRSMODULE "attributes" #define ATTRSMODULE_PM "attributes.pm" if (for_my) { - SV **svp; /* Don't force the C if we don't need it. */ - svp = hv_fetch(GvHVn(PL_incgv), ATTRSMODULE_PM, + SV **svp = hv_fetch(GvHVn(PL_incgv), ATTRSMODULE_PM, sizeof(ATTRSMODULE_PM)-1, 0); if (svp && *svp != &PL_sv_undef) ; /* already in %INC */ @@ -1574,10 +1583,8 @@ S_apply_attrs_my(pTHX_ HV *stash, OP *target, OP *attrs, OP **imopsp) pack = newSVOP(OP_CONST, 0, newSVpvn(ATTRSMODULE, sizeof(ATTRSMODULE)-1)); /* Build up the real arg-list. */ - if (stash) - stashsv = newSVpv(HvNAME(stash), 0); - else - stashsv = &PL_sv_no; + stashsv = stash ? newSVhek(HvNAME_HEK(stash)) : &PL_sv_no; + arg = newOP(OP_PADSV, 0); arg->op_targ = target->op_targ; arg = prepend_elem(OP_LIST, @@ -1588,14 +1595,7 @@ S_apply_attrs_my(pTHX_ HV *stash, OP *target, OP *attrs, OP **imopsp) dup_attrlist(attrs))); /* Fake up a method call to import */ - meth = newSVpvn("import", 6); - (void)SvUPGRADE(meth, SVt_PVIV); - (void)SvIOK_on(meth); - { - U32 hash; - PERL_HASH(hash, SvPVX(meth), SvCUR(meth)); - SvUV_set(meth, hash); - } + meth = newSVpvn_share("import", 6, 0); imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL|OPf_WANT_VOID, append_elem(OP_LIST, prepend_elem(OP_LIST, pack, list(arg)), @@ -1636,7 +1636,7 @@ Perl_apply_attrs_string(pTHX_ const char *stashpv, CV *cv, while (len) { for (; isSPACE(*attrstr) && len; --len, ++attrstr) ; if (len) { - const char *sstr = attrstr; + const char * const sstr = attrstr; for (; !isSPACE(*attrstr) && len; --len, ++attrstr) ; attrs = append_elem(OP_LIST, attrs, newSVOP(OP_CONST, 0, @@ -1767,11 +1767,12 @@ Perl_bind_match(pTHX_ I32 type, OP *left, OP *right) OP *o; bool ismatchop = 0; - if (ckWARN(WARN_MISC) && - (left->op_type == OP_RV2AV || + if ( (left->op_type == OP_RV2AV || left->op_type == OP_RV2HV || left->op_type == OP_PADAV || - left->op_type == OP_PADHV)) { + left->op_type == OP_PADHV) + && ckWARN(WARN_MISC)) + { const char *desc = PL_op_desc[(right->op_type == OP_SUBST || right->op_type == OP_TRANS) ? right->op_type : OP_MATCH]; @@ -1828,6 +1829,7 @@ Perl_invert(pTHX_ OP *o) OP * Perl_scope(pTHX_ OP *o) { + dVAR; if (o) { if (o->op_flags & OPf_PARENS || PERLDB_NOOPT || PL_tainting) { o = prepend_elem(OP_LINESEQ, newOP(OP_ENTER, 0), o); @@ -1959,8 +1961,8 @@ Perl_localize(pTHX_ OP *o, I32 lex) ; #endif else { - if (ckWARN(WARN_PARENTHESIS) - && PL_bufptr > PL_oldbufptr && PL_bufptr[-1] == ',') + if ( PL_bufptr > PL_oldbufptr && PL_bufptr[-1] == ',' + && ckWARN(WARN_PARENTHESIS)) { char *s = PL_bufptr; bool sigil = FALSE; @@ -2013,6 +2015,7 @@ Perl_jmaybe(pTHX_ OP *o) OP * Perl_fold_constants(pTHX_ register OP *o) { + dVAR; register OP *curop; I32 type = o->op_type; SV *sv; @@ -2092,6 +2095,7 @@ Perl_fold_constants(pTHX_ register OP *o) OP * Perl_gen_constant_list(pTHX_ register OP *o) { + dVAR; register OP *curop; const I32 oldtmps_floor = PL_tmps_floor; @@ -2123,6 +2127,7 @@ Perl_gen_constant_list(pTHX_ register OP *o) OP * Perl_convert(pTHX_ I32 type, I32 flags, OP *o) { + dVAR; if (!o || o->op_type != OP_LIST) o = newLISTOP(OP_LIST, 0, o, Nullop); else @@ -2244,6 +2249,7 @@ Perl_force_list(pTHX_ OP *o) OP * Perl_newLISTOP(pTHX_ I32 type, I32 flags, OP *first, OP *last) { + dVAR; LISTOP *listop; NewOp(1101, listop, 1, LISTOP); @@ -2278,6 +2284,7 @@ Perl_newLISTOP(pTHX_ I32 type, I32 flags, OP *first, OP *last) OP * Perl_newOP(pTHX_ I32 type, I32 flags) { + dVAR; OP *o; NewOp(1101, o, 1, OP); o->op_type = (OPCODE)type; @@ -2296,6 +2303,7 @@ Perl_newOP(pTHX_ I32 type, I32 flags) OP * Perl_newUNOP(pTHX_ I32 type, I32 flags, OP *first) { + dVAR; UNOP *unop; if (!first) @@ -2319,6 +2327,7 @@ Perl_newUNOP(pTHX_ I32 type, I32 flags, OP *first) OP * Perl_newBINOP(pTHX_ I32 type, I32 flags, OP *first, OP *last) { + dVAR; BINOP *binop; NewOp(1101, binop, 1, BINOP); @@ -2347,8 +2356,8 @@ Perl_newBINOP(pTHX_ I32 type, I32 flags, OP *first, OP *last) return fold_constants((OP *)binop); } -static int -uvcompare(const void *a, const void *b) +static int uvcompare(const void *a, const void *b) __attribute__nonnull__(1) __attribute__nonnull__(2) __attribute__pure__; +static int uvcompare(const void *a, const void *b) { if (*((const UV *)a) < (*(const UV *)b)) return -1; @@ -2368,8 +2377,8 @@ Perl_pmtrans(pTHX_ OP *o, OP *expr, OP *repl) SV *rstr = ((SVOP*)repl)->op_sv; STRLEN tlen; STRLEN rlen; - U8 *t = (U8*)SvPV(tstr, tlen); - U8 *r = (U8*)SvPV(rstr, rlen); + const U8 *t = (U8*)SvPV_const(tstr, tlen); + const U8 *r = (U8*)SvPV_const(rstr, rlen); register I32 i; register I32 j; I32 del; @@ -2392,8 +2401,8 @@ Perl_pmtrans(pTHX_ OP *o, OP *expr, OP *repl) if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) { SV* listsv = newSVpvn("# comment\n",10); SV* transv = 0; - U8* tend = t + tlen; - U8* rend = r + rlen; + const U8* tend = t + tlen; + const U8* rend = r + rlen; STRLEN ulen; UV tfirst = 1; UV tlast = 0; @@ -2414,12 +2423,12 @@ Perl_pmtrans(pTHX_ OP *o, OP *expr, OP *repl) if (!from_utf) { STRLEN len = tlen; - tsave = t = bytes_to_utf8(t, &len); + t = tsave = bytes_to_utf8(t, &len); tend = t + len; } if (!to_utf && rlen) { STRLEN len = rlen; - rsave = r = bytes_to_utf8(r, &len); + r = rsave = bytes_to_utf8(r, &len); rend = r + len; } @@ -2433,7 +2442,7 @@ Perl_pmtrans(pTHX_ OP *o, OP *expr, OP *repl) U8 tmpbuf[UTF8_MAXBYTES+1]; UV *cp; UV nextmin = 0; - New(1109, cp, 2*tlen, UV); + Newx(cp, 2*tlen, UV); i = 0; transv = newSVpvn("",0); while (t < tend) { @@ -2476,7 +2485,7 @@ Perl_pmtrans(pTHX_ OP *o, OP *expr, OP *repl) t = uvuni_to_utf8_flags(tmpbuf, 0x7fffffff, UNICODE_ALLOW_SUPER); sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf); - t = (U8*)SvPVX(transv); + t = (const U8*)SvPVX_const(transv); tlen = SvCUR(transv); tend = t + tlen; Safefree(cp); @@ -2671,6 +2680,7 @@ Perl_pmtrans(pTHX_ OP *o, OP *expr, OP *repl) OP * Perl_newPMOP(pTHX_ I32 type, I32 flags) { + dVAR; PMOP *pmop; NewOp(1101, pmop, 1, PMOP); @@ -2704,8 +2714,13 @@ Perl_newPMOP(pTHX_ I32 type, I32 flags) /* link into pm list */ if (type != OP_TRANS && PL_curstash) { - pmop->op_pmnext = HvPMROOT(PL_curstash); - HvPMROOT(PL_curstash) = pmop; + MAGIC *mg = mg_find((SV*)PL_curstash, PERL_MAGIC_symtab); + + if (!mg) { + mg = sv_magicext((SV*)PL_curstash, 0, PERL_MAGIC_symtab, 0, 0, 0); + } + pmop->op_pmnext = (PMOP*)mg->mg_obj; + mg->mg_obj = (SV*)pmop; PmopSTASH_set(pmop,PL_curstash); } @@ -2727,6 +2742,7 @@ Perl_newPMOP(pTHX_ I32 type, I32 flags) OP * Perl_pmruntime(pTHX_ OP *o, OP *expr, bool isreg) { + dVAR; PMOP *pm; LOGOP *rcop; I32 repl_has_vars = 0; @@ -2769,15 +2785,31 @@ Perl_pmruntime(pTHX_ OP *o, OP *expr, bool isreg) if (expr->op_type == OP_CONST) { STRLEN plen; SV *pat = ((SVOP*)expr)->op_sv; - char *p = SvPV(pat, plen); + const char *p = SvPV_const(pat, plen); if ((o->op_flags & OPf_SPECIAL) && (*p == ' ' && p[1] == '\0')) { + U32 was_readonly = SvREADONLY(pat); + + if (was_readonly) { + if (SvFAKE(pat)) { + sv_force_normal_flags(pat, 0); + assert(!SvREADONLY(pat)); + was_readonly = 0; + } else { + SvREADONLY_off(pat); + } + } + sv_setpvn(pat, "\\s+", 3); - p = SvPV(pat, plen); + + SvFLAGS(pat) |= was_readonly; + + p = SvPV_const(pat, plen); pm->op_pmflags |= PMf_SKIPWHITE; } if (DO_UTF8(pat)) pm->op_pmdynflags |= PMdf_UTF8; - PM_SETRE(pm, CALLREGCOMP(aTHX_ p, p + plen, pm)); + /* FIXME - can we make this function take const char * args? */ + PM_SETRE(pm, CALLREGCOMP(aTHX_ (char*)p, (char*)p + plen, pm)); if (strEQ("\\s+", PM_GETRE(pm)->precomp)) pm->op_pmflags |= PMf_WHITE; op_free(expr); @@ -2896,6 +2928,7 @@ Perl_pmruntime(pTHX_ OP *o, OP *expr, bool isreg) OP * Perl_newSVOP(pTHX_ I32 type, I32 flags, SV *sv) { + dVAR; SVOP *svop; NewOp(1101, svop, 1, SVOP); svop->op_type = (OPCODE)type; @@ -2913,6 +2946,7 @@ Perl_newSVOP(pTHX_ I32 type, I32 flags, SV *sv) OP * Perl_newPADOP(pTHX_ I32 type, I32 flags, SV *sv) { + dVAR; PADOP *padop; NewOp(1101, padop, 1, PADOP); padop->op_type = (OPCODE)type; @@ -2934,6 +2968,7 @@ Perl_newPADOP(pTHX_ I32 type, I32 flags, SV *sv) OP * Perl_newGVOP(pTHX_ I32 type, I32 flags, GV *gv) { + dVAR; #ifdef USE_ITHREADS if (gv) GvIN_PAD_on(gv); @@ -2946,6 +2981,7 @@ Perl_newGVOP(pTHX_ I32 type, I32 flags, GV *gv) OP * Perl_newPVOP(pTHX_ I32 type, I32 flags, char *pv) { + dVAR; PVOP *pvop; NewOp(1101, pvop, 1, PVOP); pvop->op_type = (OPCODE)type; @@ -2969,7 +3005,7 @@ Perl_package(pTHX_ OP *o) save_hptr(&PL_curstash); save_item(PL_curstname); - name = SvPV(cSVOPo->op_sv, len); + name = SvPV_const(cSVOPo->op_sv, len); PL_curstash = gv_stashpvn(name, len, TRUE); sv_setpvn(PL_curstname, name, len); op_free(o); @@ -2991,10 +3027,10 @@ Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *idop, OP *arg) veop = Nullop; - if (version != Nullop) { + if (version) { SV *vesv = ((SVOP*)version)->op_sv; - if (arg == Nullop && !SvNIOKp(vesv)) { + if (!arg && !SvNIOKp(vesv)) { arg = version; } else { @@ -3008,14 +3044,7 @@ Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *idop, OP *arg) pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv)); /* Fake up a method call to VERSION */ - meth = newSVpvn("VERSION",7); - sv_upgrade(meth, SVt_PVIV); - (void)SvIOK_on(meth); - { - U32 hash; - PERL_HASH(hash, SvPVX(meth), SvCUR(meth)); - SvUV_set(meth, hash); - } + meth = newSVpvn_share("VERSION", 7, 0); veop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL, append_elem(OP_LIST, prepend_elem(OP_LIST, pack, list(version)), @@ -3036,14 +3065,8 @@ Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *idop, OP *arg) pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv)); /* Fake up a method call to import/unimport */ - meth = aver ? newSVpvn("import",6) : newSVpvn("unimport", 8); - (void)SvUPGRADE(meth, SVt_PVIV); - (void)SvIOK_on(meth); - { - U32 hash; - PERL_HASH(hash, SvPVX(meth), SvCUR(meth)); - SvUV_set(meth, hash); - } + meth = aver + ? newSVpvn_share("import",6, 0) : newSVpvn_share("unimport", 8, 0); imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL, append_elem(OP_LIST, prepend_elem(OP_LIST, pack, list(arg)), @@ -3052,7 +3075,7 @@ Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *idop, OP *arg) /* Fake up the BEGIN {}, which does its thing immediately. */ newATTRSUB(floor, - newSVOP(OP_CONST, 0, newSVpvn("BEGIN", 5)), + newSVOP(OP_CONST, 0, newSVpvn_share("BEGIN", 5, 0)), Nullop, Nullop, append_elem(OP_LINESEQ, @@ -3193,7 +3216,7 @@ Perl_newSLICEOP(pTHX_ I32 flags, OP *subscript, OP *listval) } STATIC I32 -S_list_assignment(pTHX_ register const OP *o) +S_is_list_assignment(pTHX_ register const OP *o) { if (!o) return TRUE; @@ -3202,8 +3225,8 @@ S_list_assignment(pTHX_ register const OP *o) o = cUNOPo->op_first; if (o->op_type == OP_COND_EXPR) { - const I32 t = list_assignment(cLOGOPo->op_first->op_sibling); - const I32 f = list_assignment(cLOGOPo->op_first->op_sibling->op_sibling); + const I32 t = is_list_assignment(cLOGOPo->op_first->op_sibling); + const I32 f = is_list_assignment(cLOGOPo->op_first->op_sibling->op_sibling); if (t && f) return TRUE; @@ -3248,18 +3271,19 @@ Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right) } } - if (list_assignment(left)) { + if (is_list_assignment(left)) { OP *curop; PL_modcount = 0; - PL_eval_start = right; /* Grandfathering $[ assignment here. Bletch.*/ + /* Grandfathering $[ assignment here. Bletch.*/ + /* Only simple assignments like C<< ($[) = 1 >> are allowed */ + PL_eval_start = (left->op_type == OP_CONST) ? right : 0; left = mod(left, OP_AASSIGN); if (PL_eval_start) PL_eval_start = 0; - else { - op_free(left); - op_free(right); - return Nullop; + else if (left->op_type == OP_CONST) { + /* Result of assignment is always 1 (or we'd be dead already) */ + return newSVOP(OP_CONST, 0, newSViv(1)); } /* optimise C to C, and likewise for hashes */ if ((left->op_type == OP_PADAV || left->op_type == OP_PADHV) @@ -3396,8 +3420,7 @@ Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right) if (PL_eval_start) PL_eval_start = 0; else { - op_free(o); - return Nullop; + o = newSVOP(OP_CONST, 0, newSViv(PL_compiling.cop_arybase)); } } return o; @@ -3406,6 +3429,7 @@ Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right) OP * Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o) { + dVAR; const U32 seq = intro_my(); register COP *cop; @@ -3470,12 +3494,14 @@ Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o) OP * Perl_newLOGOP(pTHX_ I32 type, I32 flags, OP *first, OP *other) { + dVAR; return new_logop(type, flags, &first, &other); } STATIC OP * S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp) { + dVAR; LOGOP *logop; OP *o; OP *first = *firstp; @@ -3503,7 +3529,7 @@ S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp) if (first->op_type == OP_CONST) { if (first->op_private & OPpCONST_STRICT) no_bareword_allowed(first); - else if (ckWARN(WARN_BAREWORD) && (first->op_private & OPpCONST_BARE)) + else if ((first->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)) || @@ -3539,8 +3565,8 @@ S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp) return first; } } - else if (ckWARN(WARN_MISC) && (first->op_flags & OPf_KIDS) && - type != OP_DOR) /* [#24076] Don't warn for err FOO. */ + else if ((first->op_flags & OPf_KIDS) && type != OP_DOR + && ckWARN(WARN_MISC)) /* [#24076] Don't warn for err FOO. */ { const OP *k1 = ((UNOP*)first)->op_first; const OP *k2 = k1->op_sibling; @@ -3610,6 +3636,7 @@ S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp) OP * Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop) { + dVAR; LOGOP *logop; OP *start; OP *o; @@ -3665,6 +3692,7 @@ Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop) OP * Perl_newRANGE(pTHX_ I32 flags, OP *left, OP *right) { + dVAR; LOGOP *range; OP *flip; OP *flop; @@ -3715,7 +3743,8 @@ Perl_newLOOPOP(pTHX_ I32 flags, I32 debuggable, OP *expr, OP *block) OP* o; const bool once = block && block->op_flags & OPf_SPECIAL && (block->op_type == OP_ENTERSUB || block->op_type == OP_NULL); - (void)debuggable; + + PERL_UNUSED_ARG(debuggable); if (expr) { if (once && expr->op_type == OP_CONST && !SvTRUE(((SVOP*)expr)->op_sv)) @@ -3725,8 +3754,8 @@ Perl_newLOOPOP(pTHX_ I32 flags, I32 debuggable, OP *expr, OP *block) expr = newUNOP(OP_DEFINED, 0, newASSIGNOP(0, newDEFSVOP(), 0, expr) ); } else if (expr->op_flags & OPf_KIDS) { - const OP *k1 = ((UNOP*)expr)->op_first; - const OP *k2 = (k1) ? k1->op_sibling : NULL; + const OP * const k1 = ((UNOP*)expr)->op_first; + const OP * const k2 = k1 ? k1->op_sibling : NULL; switch (expr->op_type) { case OP_NULL: if (k2 && k2->op_type == OP_READLINE @@ -3769,22 +3798,25 @@ Perl_newLOOPOP(pTHX_ I32 flags, I32 debuggable, OP *expr, OP *block) } OP * -Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop, I32 whileline, OP *expr, OP *block, OP *cont) +Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop, I32 +whileline, OP *expr, OP *block, OP *cont, I32 has_my) { + dVAR; OP *redo; OP *next = 0; OP *listop; OP *o; U8 loopflags = 0; - (void)debuggable; + + PERL_UNUSED_ARG(debuggable); if (expr && (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB))) { expr = newUNOP(OP_DEFINED, 0, newASSIGNOP(0, newDEFSVOP(), 0, expr) ); } else if (expr && (expr->op_flags & OPf_KIDS)) { - const OP *k1 = ((UNOP*)expr)->op_first; - const OP *k2 = (k1) ? k1->op_sibling : NULL; + const OP * const k1 = ((UNOP*)expr)->op_first; + const OP * const k2 = (k1) ? k1->op_sibling : NULL; switch (expr->op_type) { case OP_NULL: if (k2 && k2->op_type == OP_READLINE @@ -3805,7 +3837,7 @@ Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop, I32 whileline, OP * if (!block) block = newOP(OP_NULL, 0); - else if (cont) { + else if (cont || has_my) { block = scope(block); } @@ -3863,8 +3895,9 @@ Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop, I32 whileline, OP * } OP * -Perl_newFOROP(pTHX_ I32 flags,char *label,line_t forline,OP *sv,OP *expr,OP *block,OP *cont) +Perl_newFOROP(pTHX_ I32 flags, char *label, line_t forline, OP *sv, OP *expr, OP *block, OP *cont) { + dVAR; LOOP *loop; OP *wop; PADOFFSET padoff = 0; @@ -3917,8 +3950,8 @@ Perl_newFOROP(pTHX_ I32 flags,char *label,line_t forline,OP *sv,OP *expr,OP *blo */ UNOP* flip = (UNOP*)((UNOP*)((BINOP*)expr)->op_first)->op_first; LOGOP* range = (LOGOP*) flip->op_first; - OP* left = range->op_first; - OP* right = left->op_sibling; + OP* const left = range->op_first; + OP* const right = left->op_sibling; LISTOP* listop; range->op_flags &= ~OPf_KIDS; @@ -3957,7 +3990,7 @@ Perl_newFOROP(pTHX_ I32 flags,char *label,line_t forline,OP *sv,OP *expr,OP *blo Renew(loop, 1, LOOP); #endif loop->op_targ = padoff; - wop = newWHILEOP(flags, 1, loop, forline, newOP(OP_ITER, 0), block, cont); + wop = newWHILEOP(flags, 1, loop, forline, newOP(OP_ITER, 0), block, cont, 0); PL_copline = forline; return newSTATEOP(0, label, wop); } @@ -3966,7 +3999,6 @@ OP* Perl_newLOOPEX(pTHX_ I32 type, OP *label) { OP *o; - STRLEN n_a; if (type != OP_GOTO || label->op_type == OP_CONST) { /* "last()" means "last" */ @@ -3974,7 +4006,7 @@ Perl_newLOOPEX(pTHX_ I32 type, OP *label) o = newOP(type, OPf_SPECIAL); else { o = newPVOP(type, 0, savepv(label->op_type == OP_CONST - ? SvPVx(((SVOP*)label)->op_sv, n_a) + ? SvPVx_nolen_const(((SVOP*)label)->op_sv) : "")); } op_free(label); @@ -4004,6 +4036,7 @@ children can still follow the full lexical scope chain. void Perl_cv_undef(pTHX_ CV *cv) { + dVAR; #ifdef USE_ITHREADS if (CvFILE(cv) && !CvXSUB(cv)) { /* for XSUBs CvFILE point directly to static memory; __FILE__ */ @@ -4021,6 +4054,7 @@ Perl_cv_undef(pTHX_ CV *cv) op_free(CvROOT(cv)); CvROOT(cv) = Nullop; + CvSTART(cv) = Nullop; LEAVE; } SvPOK_off((SV*)cv); /* forget prototype */ @@ -4048,7 +4082,7 @@ Perl_cv_undef(pTHX_ CV *cv) void Perl_cv_ckproto(pTHX_ const CV *cv, const GV *gv, const char *p) { - if (((!p != !SvPOK(cv)) || (p && strNE(p, SvPVX(cv)))) && ckWARN_d(WARN_PROTOTYPE)) { + if (((!p != !SvPOK(cv)) || (p && strNE(p, SvPVX_const(cv)))) && ckWARN_d(WARN_PROTOTYPE)) { SV* msg = sv_newmortal(); SV* name = Nullsv; @@ -4126,7 +4160,7 @@ Perl_op_const_sv(pTHX_ const OP *o, CV *cv) o = cLISTOPo->op_first->op_sibling; for (; o; o = o->op_next) { - OPCODE type = o->op_type; + const OPCODE type = o->op_type; if (sv && o->op_next == o) return sv; @@ -4173,7 +4207,8 @@ Perl_op_const_sv(pTHX_ const OP *o, CV *cv) void Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block) { - (void)floor; + PERL_UNUSED_ARG(floor); + if (o) SAVEFREEOP(o); if (proto) @@ -4194,39 +4229,40 @@ Perl_newSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *block) CV * Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block) { - STRLEN n_a; - const char *name; + dVAR; const char *aname; GV *gv; - char *ps; + const char *ps; + STRLEN ps_len; register CV *cv=0; SV *const_sv; + I32 gv_fetch_flags; - name = o ? SvPVx(cSVOPo->op_sv, n_a) : Nullch; + const char * const name = o ? SvPVx_nolen_const(cSVOPo->op_sv) : Nullch; if (proto) { assert(proto->op_type == OP_CONST); - ps = SvPVx(((SVOP*)proto)->op_sv, n_a); + ps = SvPVx_const(((SVOP*)proto)->op_sv, ps_len); } else ps = Nullch; if (!name && PERLDB_NAMEANON && CopLINE(PL_curcop)) { - SV *sv = sv_newmortal(); + SV * const sv = sv_newmortal(); Perl_sv_setpvf(aTHX_ sv, "%s[%s:%"IVdf"]", PL_curstash ? "__ANON__" : "__ANON__::__ANON__", CopFILE(PL_curcop), (IV)CopLINE(PL_curcop)); - aname = SvPVX(sv); + aname = SvPVX_const(sv); } else aname = Nullch; - gv = name ? gv_fetchsv(cSVOPo->op_sv, - GV_ADDMULTI | ((block || attrs) ? 0 : GV_NOINIT), - SVt_PVCV) + + gv_fetch_flags = (block || attrs || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS)) + ? GV_ADDMULTI : GV_ADDMULTI | GV_NOINIT; + gv = name ? gv_fetchsv(cSVOPo->op_sv, gv_fetch_flags, SVt_PVCV) : gv_fetchpv(aname ? aname : (PL_curstash ? "__ANON__" : "__ANON__::__ANON__"), - GV_ADDMULTI | ((block || attrs) ? 0 : GV_NOINIT), - SVt_PVCV); + gv_fetch_flags, SVt_PVCV); if (o) SAVEFREEOP(o); @@ -4246,7 +4282,7 @@ Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block) cv_ckproto((CV*)gv, NULL, ps); } if (ps) - sv_setpv((SV*)gv, ps); + sv_setpvn((SV*)gv, ps, ps_len); else sv_setiv((SV*)gv, -1); SvREFCNT_dec(PL_compcv); @@ -4263,7 +4299,7 @@ Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block) } #endif - if (!block || !ps || *ps || attrs) + if (!block || !ps || *ps || attrs || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS)) const_sv = Nullsv; else const_sv = op_const_sv(block, Nullcv); @@ -4319,7 +4355,7 @@ Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block) (void)SvREFCNT_inc(const_sv); if (cv) { assert(!CvROOT(cv) && !CvCONST(cv)); - sv_setpv((SV*)cv, ""); /* prototype is "" */ + sv_setpvn((SV*)cv, "", 0); /* prototype is "" */ CvXSUBANY(cv).any_ptr = const_sv; CvXSUB(cv) = const_sv_xsub; CvCONST_on(cv); @@ -4399,7 +4435,7 @@ Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block) CvSTASH(cv) = PL_curstash; if (ps) - sv_setpv((SV*)cv, ps); + sv_setpvn((SV*)cv, ps, ps_len); if (PL_error_count) { op_free(block); @@ -4466,9 +4502,9 @@ Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block) CopFILE(PL_curcop), (long)PL_subline, (long)CopLINE(PL_curcop)); gv_efullname3(tmpstr, gv, Nullch); - hv_store(GvHV(PL_DBsub), SvPVX(tmpstr), SvCUR(tmpstr), sv, 0); + hv_store(GvHV(PL_DBsub), SvPVX_const(tmpstr), SvCUR(tmpstr), sv, 0); hv = GvHVn(db_postponed); - if (HvFILL(hv) > 0 && hv_exists(hv, SvPVX(tmpstr), SvCUR(tmpstr)) + if (HvFILL(hv) > 0 && hv_exists(hv, SvPVX_const(tmpstr), SvCUR(tmpstr)) && (pcv = GvCV(db_postponed))) { dSP; @@ -4552,6 +4588,7 @@ eligible for inlining at compile-time. CV * Perl_newCONSTSUB(pTHX_ HV *stash, const char *name, SV *sv) { + dVAR; CV* cv; ENTER; @@ -4572,7 +4609,7 @@ Perl_newCONSTSUB(pTHX_ HV *stash, const char *name, SV *sv) cv = newXS(name, const_sv_xsub, savepv(CopFILE(PL_curcop))); CvXSUBANY(cv).any_ptr = sv; CvCONST_on(cv); - sv_setpv((SV*)cv, ""); /* prototype is "" */ + sv_setpvn((SV*)cv, "", 0); /* prototype is "" */ if (stash) CopSTASH_free(PL_curcop); @@ -4605,23 +4642,32 @@ Perl_newXS(pTHX_ const char *name, XSUBADDR_t subaddr, const char *filename) if (GvCVGEN(gv)) { /* just a cached method */ SvREFCNT_dec(cv); - cv = 0; + cv = Nullcv; } else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) { /* already defined (or promised) */ - if (ckWARN(WARN_REDEFINE) && !(CvGV(cv) && GvSTASH(CvGV(cv)) - && strEQ(HvNAME(GvSTASH(CvGV(cv))), "autouse"))) { - const line_t oldline = CopLINE(PL_curcop); - if (PL_copline != NOLINE) - CopLINE_set(PL_curcop, PL_copline); - Perl_warner(aTHX_ packWARN(WARN_REDEFINE), - CvCONST(cv) ? "Constant subroutine %s redefined" - : "Subroutine %s redefined" - ,name); - CopLINE_set(PL_curcop, oldline); + /* XXX It's possible for this HvNAME_get to return null, and get passed into strEQ */ + if (ckWARN(WARN_REDEFINE)) { + GV * const gvcv = CvGV(cv); + if (gvcv) { + HV * const stash = GvSTASH(gvcv); + if (stash) { + const char *name = HvNAME_get(stash); + if ( strEQ(name,"autouse") ) { + const line_t oldline = CopLINE(PL_curcop); + if (PL_copline != NOLINE) + CopLINE_set(PL_curcop, PL_copline); + Perl_warner(aTHX_ packWARN(WARN_REDEFINE), + CvCONST(cv) ? "Constant subroutine %s redefined" + : "Subroutine %s redefined" + ,name); + CopLINE_set(PL_curcop, oldline); + } + } + } } SvREFCNT_dec(cv); - cv = 0; + cv = Nullcv; } } @@ -4768,6 +4814,7 @@ Perl_newANONATTRSUB(pTHX_ I32 floor, OP *proto, OP *attrs, OP *block) OP * Perl_oopsAV(pTHX_ OP *o) { + dVAR; switch (o->op_type) { case OP_PADSV: o->op_type = OP_PADAV; @@ -4791,6 +4838,7 @@ Perl_oopsAV(pTHX_ OP *o) OP * Perl_oopsHV(pTHX_ OP *o) { + dVAR; switch (o->op_type) { case OP_PADSV: case OP_PADAV: @@ -4816,6 +4864,7 @@ Perl_oopsHV(pTHX_ OP *o) OP * Perl_newAVREF(pTHX_ OP *o) { + dVAR; if (o->op_type == OP_PADANY) { o->op_type = OP_PADAV; o->op_ppaddr = PL_ppaddr[OP_PADAV]; @@ -4840,6 +4889,7 @@ Perl_newGVREF(pTHX_ I32 type, OP *o) OP * Perl_newHVREF(pTHX_ OP *o) { + dVAR; if (o->op_type == OP_PADANY) { o->op_type = OP_PADHV; o->op_ppaddr = PL_ppaddr[OP_PADHV]; @@ -4858,12 +4908,8 @@ Perl_oopsCV(pTHX_ OP *o) { Perl_croak(aTHX_ "NOT IMPL LINE %d",__LINE__); /* STUB */ - (void)o; -#ifndef HASATTRIBUTE - /* No __attribute__, so the compiler doesn't know that croak never returns - */ - return 0; -#endif + PERL_UNUSED_ARG(o); + NORETURN_FUNCTION_END; } OP * @@ -4875,6 +4921,7 @@ Perl_newCVREF(pTHX_ I32 flags, OP *o) OP * Perl_newSVREF(pTHX_ OP *o) { + dVAR; if (o->op_type == OP_PADANY) { o->op_type = OP_PADSV; o->op_ppaddr = PL_ppaddr[OP_PADSV]; @@ -4915,8 +4962,8 @@ Perl_ck_bitop(pTHX_ OP *o) || o->op_type == OP_BIT_AND || o->op_type == OP_BIT_XOR)) { - const OP * left = cBINOPo->op_first; - const OP * right = left->op_sibling; + const OP * const left = cBINOPo->op_first; + const OP * const right = left->op_sibling; if ((OP_IS_NUMCOMPARE(left->op_type) && (left->op_flags & OPf_PARENS) == 0) || (OP_IS_NUMCOMPARE(right->op_type) && @@ -4944,6 +4991,7 @@ Perl_ck_concat(pTHX_ OP *o) OP * Perl_ck_spair(pTHX_ OP *o) { + dVAR; if (o->op_flags & OPf_KIDS) { OP* newop; OP* kid; @@ -5021,9 +5069,10 @@ Perl_ck_eof(pTHX_ OP *o) OP * Perl_ck_eval(pTHX_ OP *o) { + dVAR; PL_hints |= HINT_BLOCK_SCOPE; if (o->op_flags & OPf_KIDS) { - SVOP *kid = (SVOP*)cUNOPo->op_first; + SVOP * const kid = (SVOP*)cUNOPo->op_first; if (!kid) { o->op_flags &= ~OPf_KIDS; @@ -5097,7 +5146,7 @@ Perl_ck_exists(pTHX_ OP *o) { o = ck_fun(o); if (o->op_flags & OPf_KIDS) { - OP *kid = cUNOPo->op_first; + OP * const kid = cUNOPo->op_first; if (kid->op_type == OP_ENTERSUB) { (void) ref(kid, o->op_type); if (kid->op_type != OP_RV2CV && !PL_error_count) @@ -5115,32 +5164,22 @@ Perl_ck_exists(pTHX_ OP *o) return o; } -#if 0 -OP * -Perl_ck_gvconst(pTHX_ register OP *o) -{ - o = fold_constants(o); - if (o->op_type == OP_CONST) - o->op_type = OP_GV; - return o; -} -#endif - OP * Perl_ck_rvconst(pTHX_ register OP *o) { + dVAR; SVOP *kid = (SVOP*)cUNOPo->op_first; o->op_private |= (PL_hints & HINT_STRICT_REFS); if (kid->op_type == OP_CONST) { int iscv; GV *gv; - SV *kidsv = kid->op_sv; + SV * const kidsv = kid->op_sv; /* Is it a constant from cv_const_sv()? */ if (SvROK(kidsv) && SvREADONLY(kidsv)) { SV *rsv = SvRV(kidsv); - int svtype = SvTYPE(rsv); + const int svtype = SvTYPE(rsv); const char *badtype = Nullch; switch (o->op_type) { @@ -5227,6 +5266,7 @@ Perl_ck_rvconst(pTHX_ register OP *o) OP * Perl_ck_ftst(pTHX_ OP *o) { + dVAR; const I32 type = o->op_type; if (o->op_flags & OPf_REF) { @@ -5452,7 +5492,7 @@ Perl_ck_fun(pTHX_ OP *o) } if (tmpstr) { - name = SvPV(tmpstr, len); + name = SvPV_const(tmpstr, len); sv_2mortal(tmpstr); } } @@ -5466,7 +5506,7 @@ Perl_ck_fun(pTHX_ OP *o) SV *namesv; targ = pad_alloc(OP_RV2GV, SVs_PADTMP); namesv = PAD_SVl(targ); - (void)SvUPGRADE(namesv, SVt_PV); + SvUPGRADE(namesv, SVt_PV); if (*name != '$') sv_setpvn(namesv, "$", 1); sv_catpvn(namesv, name, len); @@ -5512,6 +5552,7 @@ Perl_ck_fun(pTHX_ OP *o) OP * Perl_ck_glob(pTHX_ OP *o) { + dVAR; GV *gv; o = ck_fun(o); @@ -5566,6 +5607,7 @@ Perl_ck_glob(pTHX_ OP *o) OP * Perl_ck_grep(pTHX_ OP *o) { + dVAR; LOGOP *gwop; OP *kid; const OPCODE type = o->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE; @@ -5790,10 +5832,10 @@ Perl_ck_method(pTHX_ OP *o) OP *kid = cUNOPo->op_first; if (kid->op_type == OP_CONST) { SV* sv = kSVOP->op_sv; - if (!(strchr(SvPVX(sv), ':') || strchr(SvPVX(sv), '\''))) { + if (!(strchr(SvPVX_const(sv), ':') || strchr(SvPVX_const(sv), '\''))) { OP *cmop; if (!SvREADONLY(sv) || !SvFAKE(sv)) { - sv = newSVpvn_share(SvPVX(sv), SvCUR(sv), 0); + sv = newSVpvn_share(SvPVX_const(sv), SvCUR(sv), 0); } else { kSVOP->op_sv = Nullsv; @@ -5845,7 +5887,7 @@ Perl_ck_open(pTHX_ OP *o) OP *first = cLISTOPx(o)->op_first; /* The pushmark. */ OP *last = cLISTOPx(o)->op_last; /* The bareword. */ OP *oa; - char *mode; + const char *mode; if ((last->op_type == OP_CONST) && /* The bareword. */ (last->op_private & OPpCONST_BARE) && @@ -5853,7 +5895,7 @@ Perl_ck_open(pTHX_ OP *o) (oa = first->op_sibling) && /* The fh. */ (oa = oa->op_sibling) && /* The mode. */ SvPOK(((SVOP*)oa)->op_sv) && - (mode = SvPVX(((SVOP*)oa)->op_sv)) && + (mode = SvPVX_const(((SVOP*)oa)->op_sv)) && mode[0] == '>' && mode[1] == '&' && /* A dup open. */ (last == oa->op_sibling)) /* The bareword. */ last->op_private &= ~OPpCONST_STRICT; @@ -5882,21 +5924,29 @@ Perl_ck_require(pTHX_ OP *o) SVOP *kid = (SVOP*)cUNOPo->op_first; if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) { + SV *sv = kid->op_sv; + U32 was_readonly = SvREADONLY(sv); char *s; - for (s = SvPVX(kid->op_sv); *s; s++) { + + if (was_readonly) { + if (SvFAKE(sv)) { + sv_force_normal_flags(sv, 0); + assert(!SvREADONLY(sv)); + was_readonly = 0; + } else { + SvREADONLY_off(sv); + } + } + + for (s = SvPVX(sv); *s; s++) { if (*s == ':' && s[1] == ':') { *s = '/'; Move(s+2, s+1, strlen(s+2)+1, char); - SvCUR_set(kid->op_sv, SvCUR(kid->op_sv) - 1); + SvCUR_set(sv, SvCUR(sv) - 1); } } - if (SvREADONLY(kid->op_sv)) { - SvREADONLY_off(kid->op_sv); - sv_catpvn(kid->op_sv, ".pm", 3); - SvREADONLY_on(kid->op_sv); - } - else - sv_catpvn(kid->op_sv, ".pm", 3); + sv_catpvn(sv, ".pm", 3); + SvFLAGS(sv) |= was_readonly; } } @@ -5943,6 +5993,7 @@ Perl_ck_retarget(pTHX_ OP *o) OP * Perl_ck_select(pTHX_ OP *o) { + dVAR; OP* kid; if (o->op_flags & OPf_KIDS) { kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */ @@ -6111,6 +6162,7 @@ S_simplify_sort(pTHX_ OP *o) OP * Perl_ck_split(pTHX_ OP *o) { + dVAR; register OP *kid; if (o->op_flags & OPf_STACKED) @@ -6140,7 +6192,7 @@ Perl_ck_split(pTHX_ OP *o) kid->op_type = OP_PUSHRE; kid->op_ppaddr = PL_ppaddr[OP_PUSHRE]; scalar(kid); - if (ckWARN(WARN_REGEXP) && ((PMOP *)kid)->op_pmflags & PMf_GLOBAL) { + if (((PMOP *)kid)->op_pmflags & PMf_GLOBAL && ckWARN(WARN_REGEXP)) { Perl_warner(aTHX_ packWARN(WARN_REGEXP), "Use of /g modifier is meaningless in split"); } @@ -6166,9 +6218,9 @@ Perl_ck_split(pTHX_ OP *o) OP * Perl_ck_join(pTHX_ OP *o) { - if (ckWARN(WARN_SYNTAX)) { - const OP *kid = cLISTOPo->op_first->op_sibling; - if (kid && kid->op_type == OP_MATCH) { + const OP *kid = cLISTOPo->op_first->op_sibling; + if (kid && kid->op_type == OP_MATCH) { + if (ckWARN(WARN_SYNTAX)) { const REGEXP *re = PM_GETRE(kPMOP); const char *pmstr = re ? re->precomp : "STRING"; Perl_warner(aTHX_ packWARN(WARN_SYNTAX), @@ -6193,7 +6245,6 @@ Perl_ck_subr(pTHX_ OP *o) I32 arg = 0; I32 contextclass = 0; char *e = 0; - STRLEN n_a; bool delete_op = 0; o->op_private |= OPpENTERSUB_HASTARG; @@ -6211,7 +6262,7 @@ Perl_ck_subr(pTHX_ OP *o) else { if (SvPOK(cv)) { namegv = CvANON(cv) ? gv : CvGV(cv); - proto = SvPV((SV*)cv, n_a); + proto = SvPV_nolen((SV*)cv); } if (CvASSERTION(cv)) { if (PL_hints & HINT_ASSERTING) { @@ -6220,7 +6271,7 @@ Perl_ck_subr(pTHX_ OP *o) } else { delete_op = 1; - if (ckWARN(WARN_ASSERTIONS) && !(PL_hints & HINT_ASSERTIONSSEEN)) { + if (!(PL_hints & HINT_ASSERTIONSSEEN) && ckWARN(WARN_ASSERTIONS)) { Perl_warner(aTHX_ packWARN(WARN_ASSERTIONS), "Impossible to activate assertion call"); } @@ -6474,6 +6525,7 @@ Perl_ck_substr(pTHX_ OP *o) void Perl_peep(pTHX_ register OP *o) { + dVAR; register OP* oldop = 0; if (!o || o->op_opt) @@ -6625,7 +6677,7 @@ Perl_peep(pTHX_ register OP *o) } else if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) { GV *gv = cGVOPo_gv; - if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX(GvCV(gv))) { + if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX_const(GvCV(gv))) { /* XXX could check prototype here instead of just carping */ SV *sv = sv_newmortal(); gv_efullname3(sv, gv, Nullch); @@ -6691,8 +6743,9 @@ Perl_peep(pTHX_ register OP *o) case OP_EXEC: o->op_opt = 1; - if (ckWARN(WARN_SYNTAX) && o->op_next - && o->op_next->op_type == OP_NEXTSTATE) { + if (o->op_next && o->op_next->op_type == OP_NEXTSTATE + && ckWARN(WARN_SYNTAX)) + { if (o->op_next->op_sibling && o->op_next->op_sibling->op_type != OP_EXIT && o->op_next->op_sibling->op_type != OP_WARN && @@ -6714,7 +6767,7 @@ Perl_peep(pTHX_ register OP *o) SV *lexname; GV **fields; SV **svp, *sv; - char *key = NULL; + const char *key = NULL; STRLEN keylen; o->op_opt = 1; @@ -6725,7 +6778,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)) { - key = SvPV(sv, keylen); + key = SvPV_const(sv, keylen); lexname = newSVpvn_share(key, SvUTF8(sv) ? -(I32)keylen : keylen, 0); @@ -6745,13 +6798,13 @@ Perl_peep(pTHX_ register OP *o) fields = (GV**)hv_fetch(SvSTASH(lexname), "FIELDS", 6, FALSE); if (!fields || !GvHV(*fields)) break; - key = SvPV(*svp, keylen); + key = SvPV_const(*svp, keylen); if (!hv_fetch(GvHV(*fields), key, SvUTF8(*svp) ? -(I32)keylen : keylen, FALSE)) { Perl_croak(aTHX_ "No such class field \"%s\" " "in variable %s of type %s", - key, SvPV_nolen(lexname), HvNAME(SvSTASH(lexname))); + key, SvPV_nolen_const(lexname), HvNAME_get(SvSTASH(lexname))); } break; @@ -6762,7 +6815,7 @@ Perl_peep(pTHX_ register OP *o) SV *lexname; GV **fields; SV **svp; - char *key; + const char *key; STRLEN keylen; SVOP *first_key_op, *key_op; @@ -6802,13 +6855,13 @@ Perl_peep(pTHX_ register OP *o) if (key_op->op_type != OP_CONST) continue; svp = cSVOPx_svp(key_op); - key = SvPV(*svp, keylen); + key = SvPV_const(*svp, keylen); if (!hv_fetch(GvHV(*fields), key, SvUTF8(*svp) ? -(I32)keylen : keylen, FALSE)) { Perl_croak(aTHX_ "No such class field \"%s\" " "in variable %s of type %s", - key, SvPV_nolen(lexname), HvNAME(SvSTASH(lexname))); + key, SvPV_nolen(lexname), HvNAME_get(SvSTASH(lexname))); } } break; @@ -7040,13 +7093,13 @@ Perl_custom_op_name(pTHX_ const OP* o) HE* he; if (!PL_custom_op_names) /* This probably shouldn't happen */ - return PL_op_name[OP_CUSTOM]; + return (char *)PL_op_name[OP_CUSTOM]; keysv = sv_2mortal(newSViv(index)); he = hv_fetch_ent(PL_custom_op_names, keysv, 0, 0); if (!he) - return PL_op_name[OP_CUSTOM]; /* Don't know who you are */ + return (char *)PL_op_name[OP_CUSTOM]; /* Don't know who you are */ return SvPV_nolen(HeVAL(he)); } @@ -7059,13 +7112,13 @@ Perl_custom_op_desc(pTHX_ const OP* o) HE* he; if (!PL_custom_op_descs) - return PL_op_desc[OP_CUSTOM]; + return (char *)PL_op_desc[OP_CUSTOM]; keysv = sv_2mortal(newSViv(index)); he = hv_fetch_ent(PL_custom_op_descs, keysv, 0, 0); if (!he) - return PL_op_desc[OP_CUSTOM]; + return (char *)PL_op_desc[OP_CUSTOM]; return SvPV_nolen(HeVAL(he)); } @@ -7080,7 +7133,7 @@ const_sv_xsub(pTHX_ CV* cv) if (items != 0) { #if 0 Perl_croak(aTHX_ "usage: %s::%s()", - HvNAME(GvSTASH(CvGV(cv))), GvNAME(CvGV(cv))); + HvNAME_get(GvSTASH(CvGV(cv))), GvNAME(CvGV(cv))); #endif } EXTEND(sp, 1); @@ -7095,5 +7148,5 @@ const_sv_xsub(pTHX_ CV* cv) * indent-tabs-mode: t * End: * - * vim: shiftwidth=4: -*/ + * ex: set ts=8 sts=4 sw=4 noet: + */