X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/305b86516461e93877909338ac3642c6ac09b651..afc80078650f4c5361caace3f0ae6c934135d0ec:/op.c diff --git a/op.c b/op.c index e988517..be6f936 100644 --- a/op.c +++ b/op.c @@ -496,17 +496,6 @@ Perl_op_refcnt_dec(pTHX_ OP *o) o->op_ppaddr = PL_ppaddr[type]; \ } STMT_END -STATIC SV* -S_gv_ename(pTHX_ GV *gv) -{ - SV* const tmpsv = sv_newmortal(); - - PERL_ARGS_ASSERT_GV_ENAME; - - gv_efullname3(tmpsv, gv, NULL); - return tmpsv; -} - STATIC OP * S_no_fh_allowed(pTHX_ OP *o) { @@ -518,15 +507,6 @@ S_no_fh_allowed(pTHX_ OP *o) } STATIC OP * -S_too_few_arguments_sv(pTHX_ OP *o, SV *namesv, U32 flags) -{ - PERL_ARGS_ASSERT_TOO_FEW_ARGUMENTS_SV; - yyerror_pv(Perl_form(aTHX_ "Not enough arguments for %"SVf, SVfARG(namesv)), - SvUTF8(namesv) | flags); - return o; -} - -STATIC OP * S_too_few_arguments_pv(pTHX_ OP *o, const char* name, U32 flags) { PERL_ARGS_ASSERT_TOO_FEW_ARGUMENTS_PV; @@ -543,16 +523,6 @@ S_too_many_arguments_pv(pTHX_ OP *o, const char *name, U32 flags) return o; } -STATIC OP * -S_too_many_arguments_sv(pTHX_ OP *o, SV *namesv, U32 flags) -{ - PERL_ARGS_ASSERT_TOO_MANY_ARGUMENTS_SV; - - yyerror_pv(Perl_form(aTHX_ "Too many arguments for %"SVf, SVfARG(namesv)), - SvUTF8(namesv) | flags); - return o; -} - STATIC void S_bad_type_pv(pTHX_ I32 n, const char *t, const char *name, U32 flags, const OP *kid) { @@ -565,7 +535,7 @@ S_bad_type_pv(pTHX_ I32 n, const char *t, const char *name, U32 flags, const OP STATIC void S_bad_type_gv(pTHX_ I32 n, const char *t, GV *gv, U32 flags, const OP *kid) { - SV * const namesv = gv_ename(gv); + SV * const namesv = cv_name((CV *)gv, NULL, 0); PERL_ARGS_ASSERT_BAD_TYPE_GV; yyerror_pv(Perl_form(aTHX_ "Type of arg %d to %"SVf" must be %s (not %s)", @@ -597,10 +567,6 @@ Perl_allocmy(pTHX_ const char *const name, const STRLEN len, const U32 flags) Perl_croak(aTHX_ "panic: allocmy illegal flag bits 0x%" UVxf, (UV)flags); - /* Until we're using the length for real, cross check that we're being - told the truth. */ - assert(strlen(name) == len); - /* complain about "my $" etc etc */ if (len && !(is_our || @@ -608,7 +574,6 @@ Perl_allocmy(pTHX_ const char *const name, const STRLEN len, const U32 flags) ((flags & SVf_UTF8) && isIDFIRST_utf8((U8 *)name+1)) || (name[1] == '_' && (*name == '$' || len > 2)))) { - /* name[2] is true if strlen(name) > 2 */ if (!(flags & SVf_UTF8 && UTF8_IS_START(name[1])) && (!isPRINT(name[1]) || strchr("\t\n\r\f", name[1]))) { yyerror(Perl_form(aTHX_ "Can't use global %c^%c%.*s in \"%s\"", @@ -636,7 +601,9 @@ Perl_allocmy(pTHX_ const char *const name, const STRLEN len, const U32 flags) PL_parser->in_my_stash, (is_our /* $_ is always in main::, even with our */ - ? (PL_curstash && !strEQ(name,"$_") ? PL_curstash : PL_defstash) + ? (PL_curstash && !memEQs(name,len,"$_") + ? PL_curstash + : PL_defstash) : NULL ) ); @@ -725,6 +692,11 @@ Perl_op_free(pTHX_ OP *o) return; type = o->op_type; + + /* an op should only ever acquire op_private flags that we know about. + * If this fails, you may need to fix something in regen/op_private */ + assert(!(o->op_private & ~PL_op_private_valid[type])); + if (o->op_private & OPpREFCOUNTED) { switch (type) { case OP_LEAVESUB: @@ -832,8 +804,6 @@ Perl_op_clear(pTHX_ OP *o) SvREFCNT_inc_simple_void(gv); #ifdef USE_ITHREADS if (cPADOPo->op_padix > 0) { - /* No GvIN_PAD_off(cGVOPo_gv) here, because other references - * may still exist on the pad */ pad_swipe(cPADOPo->op_padix, TRUE); cPADOPo->op_padix = 0; } @@ -850,6 +820,15 @@ Perl_op_clear(pTHX_ OP *o) } break; case OP_METHOD_NAMED: + SvREFCNT_dec(cMETHOPx(o)->op_u.op_meth_sv); + cMETHOPx(o)->op_u.op_meth_sv = NULL; +#ifdef USE_ITHREADS + if (o->op_targ) { + pad_swipe(o->op_targ, 1); + o->op_targ = 0; + } +#endif + break; case OP_CONST: case OP_HINTSEVAL: SvREFCNT_dec(cSVOPo->op_sv); @@ -900,8 +879,6 @@ Perl_op_clear(pTHX_ OP *o) case OP_PUSHRE: #ifdef USE_ITHREADS if (cPMOPo->op_pmreplrootu.op_pmtargetoff) { - /* No GvIN_PAD_off here, because other references may still - * exist on the pad */ pad_swipe(cPMOPo->op_pmreplrootu.op_pmtargetoff, TRUE); } #else @@ -1063,25 +1040,25 @@ Perl_op_refcnt_unlock(pTHX) =for apidoc op_sibling_splice A general function for editing the structure of an existing chain of -op_sibling nodes. By analogy with the perl-level splice() function, allows +op_sibling nodes. By analogy with the perl-level splice() function, allows you to delete zero or more sequential nodes, replacing them with zero or more different nodes. Performs the necessary op_first/op_last housekeeping on the parent node and op_sibling manipulation on the -children. The last deleted node will be marked as as the last node by +children. The last deleted node will be marked as as the last node by updating the op_sibling or op_lastsib field as appropriate. Note that op_next is not manipulated, and nodes are not freed; that is the -responsibility of the caller. It also won't create a new list op for an +responsibility of the caller. It also won't create a new list op for an empty list etc; use higher-level functions like op_append_elem() for that. parent is the parent node of the sibling chain. -start is the node preceding the first node to be spliced. Node(s) -following it will be deleted, and ops will be inserted after it. If it is +start is the node preceding the first node to be spliced. Node(s) +following it will be deleted, and ops will be inserted after it. If it is NULL, the first node onwards is deleted, and nodes are inserted at the beginning. -del_count is the number of nodes to delete. If zero, no nodes are deleted. +del_count is the number of nodes to delete. If zero, no nodes are deleted. If -1 or greater than or equal to the number of remaining kids, all remaining kids are deleted. @@ -1185,7 +1162,7 @@ Perl_op_sibling_splice(OP *parent, OP *start, int del_count, OP* insert) /* =for apidoc op_parent -returns the parent OP of o, if it has a parent. Returns NULL otherwise. +returns the parent OP of o, if it has a parent. Returns NULL otherwise. (Currently perl must be built with C<-DPERL_OP_PARENT> for this feature to work. @@ -1759,6 +1736,7 @@ Perl_scalarvoid(pTHX_ OP *o) no_bareword_allowed(o); else { if (ckWARN(WARN_VOID)) { + NV nv; /* don't warn on optimised away booleans, eg * use constant Foo, 5; Foo || print; */ if (cSVOPo->op_private & OPpCONST_SHORTCIRCUIT) @@ -1766,7 +1744,7 @@ Perl_scalarvoid(pTHX_ OP *o) /* the constants 0 and 1 are permitted as they are conventionally used as dummies in constructs like 1 while some_condition_with_side_effects; */ - else if (SvNIOK(sv) && (SvNV(sv) == 0.0 || SvNV(sv) == 1.0)) + else if (SvNIOK(sv) && ((nv = SvNV(sv)) == 0.0 || nv == 1.0)) useless = NULL; else if (SvPOK(sv)) { SV * const dsv = newSVpvs(""); @@ -1824,7 +1802,8 @@ Perl_scalarvoid(pTHX_ OP *o) refgen = (UNOP *)((BINOP *)o)->op_first; - if (!refgen || refgen->op_type != OP_REFGEN) + if (!refgen || (refgen->op_type != OP_REFGEN + && refgen->op_type != OP_SREFGEN)) break; exlist = (LISTOP *)refgen->op_first; @@ -1832,7 +1811,8 @@ Perl_scalarvoid(pTHX_ OP *o) || exlist->op_targ != OP_LIST) break; - if (exlist->op_first->op_type != OP_PUSHMARK) + if (exlist->op_first->op_type != OP_PUSHMARK + && exlist->op_first != exlist->op_last) break; rv2cv = (UNOP*)exlist->op_last; @@ -2064,6 +2044,27 @@ Perl_finalize_optree(pTHX_ OP* o) LEAVE; } +#ifdef USE_ITHREADS +/* Relocate sv to the pad for thread safety. + * Despite being a "constant", the SV is written to, + * for reference counts, sv_upgrade() etc. */ +PERL_STATIC_INLINE void +S_op_relocate_sv(pTHX_ SV** svp, PADOFFSET* targp) +{ + PADOFFSET ix; + PERL_ARGS_ASSERT_OP_RELOCATE_SV; + if (!*svp) return; + ix = pad_alloc(OP_CONST, SVf_READONLY); + SvREFCNT_dec(PAD_SVl(ix)); + PAD_SETSV(ix, *svp); + /* XXX I don't know how this isn't readonly already. */ + if (!SvIsCOW(PAD_SVl(ix))) SvREADONLY_on(PAD_SVl(ix)); + *svp = NULL; + *targp = ix; +} +#endif + + STATIC void S_finalize_op(pTHX_ OP* o) { @@ -2116,21 +2117,16 @@ S_finalize_op(pTHX_ OP* o) /* FALLTHROUGH */ #ifdef USE_ITHREADS case OP_HINTSEVAL: + op_relocate_sv(&cSVOPo->op_sv, &o->op_targ); +#endif + break; + +#ifdef USE_ITHREADS + /* Relocate all the METHOP's SVs to the pad for thread safety. */ case OP_METHOD_NAMED: - /* Relocate sv to the pad for thread safety. - * Despite being a "constant", the SV is written to, - * for reference counts, sv_upgrade() etc. */ - if (cSVOPo->op_sv) { - const PADOFFSET ix = pad_alloc(OP_CONST, SVf_READONLY); - SvREFCNT_dec(PAD_SVl(ix)); - PAD_SETSV(ix, cSVOPo->op_sv); - /* XXX I don't know how this isn't readonly already. */ - if (!SvIsCOW(PAD_SVl(ix))) SvREADONLY_on(PAD_SVl(ix)); - cSVOPo->op_sv = NULL; - o->op_targ = ix; - } + op_relocate_sv(&cMETHOPx(o)->op_u.op_meth_sv, &o->op_targ); + break; #endif - break; case OP_HELEM: { UNOP *rop; @@ -2266,6 +2262,7 @@ S_finalize_op(pTHX_ OP* o) || family == OA_BASEOP_OR_UNOP || family == OA_FILESTATOP || family == OA_LOOPEXOP + || family == OA_METHOP /* I don't know why SASSIGN is tagged as OA_BASEOP - DAPM */ || type == OP_SASSIGN || type == OP_CUSTOM @@ -2338,6 +2335,130 @@ S_vivifies(const OPCODE type) return 0; } +static void +S_lvref(pTHX_ OP *o, I32 type) +{ + OP *kid; + switch (o->op_type) { + case OP_COND_EXPR: + for (kid = OP_SIBLING(cUNOPo->op_first); kid; + kid = OP_SIBLING(kid)) + S_lvref(aTHX_ kid, type); + /* FALLTHROUGH */ + case OP_PUSHMARK: + return; + case OP_RV2AV: + if (cUNOPo->op_first->op_type != OP_GV) goto badref; + o->op_flags |= OPf_STACKED; + if (o->op_flags & OPf_PARENS) { + if (o->op_private & OPpLVAL_INTRO) { + /* diag_listed_as: Can't modify %s in %s */ + yyerror(Perl_form(aTHX_ "Can't modify reference to " + "localized parenthesized array in list assignment")); + return; + } + slurpy: + o->op_type = OP_LVAVREF; + o->op_ppaddr = PL_ppaddr[OP_LVAVREF]; + o->op_private &= OPpLVAL_INTRO|OPpPAD_STATE; + o->op_flags |= OPf_MOD|OPf_REF; + return; + } + o->op_private |= OPpLVREF_AV; + goto checkgv; + case OP_RV2CV: + kid = cUNOPo->op_first; + if (kid->op_type == OP_NULL) + kid = cUNOPx(kUNOP->op_first->op_sibling) + ->op_first; + o->op_private = OPpLVREF_CV; + if (kid->op_type == OP_GV) + o->op_flags |= OPf_STACKED; + else if (kid->op_type == OP_PADCV) { + o->op_targ = kid->op_targ; + kid->op_targ = 0; + op_free(cUNOPo->op_first); + cUNOPo->op_first = NULL; + o->op_flags &=~ OPf_KIDS; + } + else goto badref; + break; + case OP_RV2HV: + if (o->op_flags & OPf_PARENS) { + parenhash: + /* diag_listed_as: Can't modify %s in %s */ + yyerror(Perl_form(aTHX_ "Can't modify reference to " + "parenthesized hash in list assignment")); + return; + } + o->op_private |= OPpLVREF_HV; + /* FALLTHROUGH */ + case OP_RV2SV: + checkgv: + if (cUNOPo->op_first->op_type != OP_GV) goto badref; + o->op_flags |= OPf_STACKED; + break; + case OP_PADHV: + if (o->op_flags & OPf_PARENS) goto parenhash; + o->op_private |= OPpLVREF_HV; + /* FALLTHROUGH */ + case OP_PADSV: + PAD_COMPNAME_GEN_set(o->op_targ, PERL_INT_MAX); + break; + case OP_PADAV: + PAD_COMPNAME_GEN_set(o->op_targ, PERL_INT_MAX); + if (o->op_flags & OPf_PARENS) goto slurpy; + o->op_private |= OPpLVREF_AV; + break; + case OP_AELEM: + case OP_HELEM: + o->op_private |= OPpLVREF_ELEM; + o->op_flags |= OPf_STACKED; + break; + case OP_ASLICE: + case OP_HSLICE: + o->op_type = OP_LVREFSLICE; + o->op_ppaddr = PL_ppaddr[OP_LVREFSLICE]; + o->op_private &= OPpLVAL_INTRO|OPpLVREF_ELEM; + return; + case OP_NULL: + if (o->op_flags & OPf_SPECIAL) /* do BLOCK */ + goto badref; + else if (!(o->op_flags & OPf_KIDS)) + return; + if (o->op_targ != OP_LIST) { + S_lvref(aTHX_ cBINOPo->op_first, type); + return; + } + /* FALLTHROUGH */ + case OP_LIST: + for (kid = cLISTOPo->op_first; kid; kid = OP_SIBLING(kid)) { + assert((kid->op_flags & OPf_WANT) != OPf_WANT_VOID); + S_lvref(aTHX_ kid, type); + } + return; + case OP_STUB: + if (o->op_flags & OPf_PARENS) + return; + /* FALLTHROUGH */ + default: + badref: + /* diag_listed_as: Can't modify %s in %s */ + yyerror(Perl_form(aTHX_ "Can't modify reference to %s in %s", + o->op_type == OP_NULL && o->op_flags & OPf_SPECIAL + ? "do block" + : OP_DESC(o), + PL_op_desc[type])); + return; + } + o->op_type = OP_LVREF; + o->op_ppaddr = PL_ppaddr[OP_LVREF]; + o->op_private &= + OPpLVAL_INTRO|OPpLVREF_ELEM|OPpLVREF_TYPE|OPpPAD_STATE; + if (type == OP_ENTERLOOP) + o->op_private |= OPpLVREF_ITER; +} + OP * Perl_op_lvalue_flags(pTHX_ OP *o, I32 type, U32 flags) { @@ -2371,19 +2492,16 @@ Perl_op_lvalue_flags(pTHX_ OP *o, I32 type, U32 flags) if ((type == OP_UNDEF || type == OP_REFGEN || type == OP_LOCK) && !(o->op_flags & OPf_STACKED)) { o->op_type = OP_RV2CV; /* entersub => rv2cv */ - /* Both ENTERSUB and RV2CV use this bit, but for different pur- - poses, so we need it clear. */ - o->op_private &= ~1; o->op_ppaddr = PL_ppaddr[OP_RV2CV]; assert(cUNOPo->op_first->op_type == OP_NULL); op_null(((LISTOP*)cUNOPo->op_first)->op_first);/* disable pushmark */ break; } else { /* lvalue subroutine call */ - o->op_private |= OPpLVAL_INTRO - |(OPpENTERSUB_INARGS * (type == OP_LEAVESUBLV)); + o->op_private |= OPpLVAL_INTRO; PL_modcount = RETURN_UNLIMITED_NUMBER; - if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN) { + if (type == OP_GREPSTART || type == OP_ENTERSUB + || type == OP_REFGEN || type == OP_LEAVESUBLV) { /* Potential lvalue context: */ o->op_private |= OPpENTERSUB_INARGS; break; @@ -2391,6 +2509,7 @@ Perl_op_lvalue_flags(pTHX_ OP *o, I32 type, U32 flags) else { /* Compile-time error message: */ OP *kid = cUNOPo->op_first; CV *cv; + GV *gv; if (kid->op_type != OP_PUSHMARK) { if (kid->op_type != OP_NULL || kid->op_targ != OP_LIST) @@ -2418,7 +2537,12 @@ Perl_op_lvalue_flags(pTHX_ OP *o, I32 type, U32 flags) break; } - cv = GvCV(kGVOP_gv); + gv = kGVOP_gv; + cv = isGV(gv) + ? GvCV(gv) + : SvROK(gv) && SvTYPE(SvRV(gv)) == SVt_PVCV + ? MUTABLE_CV(SvRV(gv)) + : NULL; if (!cv) break; if (CvLVALUE(cv)) @@ -2616,11 +2740,6 @@ Perl_op_lvalue_flags(pTHX_ OP *o, I32 type, U32 flags) op_lvalue(kid, type); break; - case OP_RETURN: - if (type != OP_LEAVESUBLV) - goto nomod; - break; /* op_lvalue()ing was handled by ck_return() */ - case OP_COREARGS: return o; @@ -2633,6 +2752,35 @@ Perl_op_lvalue_flags(pTHX_ OP *o, I32 type, U32 flags) || !S_vivifies(OP_SIBLING(cLOGOPo->op_first)->op_type)) op_lvalue(OP_SIBLING(cLOGOPo->op_first), type); goto nomod; + + case OP_SREFGEN: + if (type != OP_AASSIGN && type != OP_SASSIGN + && type != OP_ENTERLOOP) + goto nomod; + /* Don’t bother applying lvalue context to the ex-list. */ + kid = cUNOPx(cUNOPo->op_first)->op_first; + assert (!OP_HAS_SIBLING(kid)); + goto kid_2lvref; + case OP_REFGEN: + if (type != OP_AASSIGN) goto nomod; + kid = cUNOPo->op_first; + kid_2lvref: + { + const U8 ec = PL_parser ? PL_parser->error_count : 0; + S_lvref(aTHX_ kid, type); + if (!PL_parser || PL_parser->error_count == ec) { + if (!FEATURE_LVREF_IS_ENABLED) + Perl_croak(aTHX_ + "Experimental lvalue references not enabled"); + Perl_ck_warner_d(aTHX_ + packWARN(WARN_EXPERIMENTAL__LVALUE_REFS), + "Lvalue references are experimental"); + } + } + if (o->op_type == OP_REFGEN) + op_null(cUNOPx(cUNOPo->op_first)->op_first); /* pushmark */ + op_null(o); + return o; } /* [20011101.069] File test operators interpret OPf_REF to mean that @@ -2773,7 +2921,6 @@ Perl_doref(pTHX_ OP *o, I32 type, bool set_op_ref) assert(cUNOPo->op_first->op_type == OP_NULL); op_null(((LISTOP*)cUNOPo->op_first)->op_first); /* disable pushmark */ o->op_flags |= OPf_SPECIAL; - o->op_private &= ~1; } else if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV){ o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV @@ -2946,7 +3093,7 @@ S_apply_attrs_my(pTHX_ HV *stash, OP *target, OP *attrs, OP **imopsp) imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL|OPf_WANT_VOID, op_append_elem(OP_LIST, op_prepend_elem(OP_LIST, pack, list(arg)), - newSVOP(OP_METHOD_NAMED, 0, meth))); + newMETHOP_named(OP_METHOD_NAMED, 0, meth))); /* Combine the ops. */ *imopsp = op_append_elem(OP_LIST, *imopsp, imop); @@ -3730,6 +3877,7 @@ S_fold_constants(pTHX_ OP *o) SV * const oldwarnhook = PL_warnhook; SV * const olddiehook = PL_diehook; COP not_compiling; + U8 oldwarn = PL_dowarn; dJMPENV; PERL_ARGS_ASSERT_FOLD_CONSTANTS; @@ -3824,6 +3972,10 @@ S_fold_constants(pTHX_ OP *o) PL_diehook = NULL; JMPENV_PUSH(ret); + /* Effective $^W=1. */ + if ( ! (PL_dowarn & G_WARN_ALL_MASK)) + PL_dowarn |= G_WARN_ON; + switch (ret) { case 0: CALLRUNOPS(aTHX); @@ -3853,6 +4005,7 @@ S_fold_constants(pTHX_ OP *o) Perl_croak(aTHX_ "panic: fold_constants JMPENV_PUSH returned %d", ret); } JMPENV_POP; + PL_dowarn = oldwarn; PL_warnhook = oldwarnhook; PL_diehook = olddiehook; PL_curcop = &PL_compiling; @@ -4295,6 +4448,77 @@ Perl_newUNOP(pTHX_ I32 type, I32 flags, OP *first) } /* +=for apidoc Am|OP *|newMETHOP|I32 type|I32 flags|OP *first + +Constructs, checks, and returns an op of method type with a method name +evaluated at runtime. I is the opcode. I gives the eight +bits of C, except that C will be set automatically, +and, shifted up eight bits, the eight bits of C, except that +the bit with value 1 is automatically set. I supplies an +op which evaluates method name; it is consumed by this function and +become part of the constructed op tree. +Supported optypes: OP_METHOD. + +=cut +*/ + +static OP* +S_newMETHOP_internal(pTHX_ I32 type, I32 flags, OP* dynamic_meth, SV* const_meth) { + dVAR; + METHOP *methop; + + assert((PL_opargs[type] & OA_CLASS_MASK) == OA_METHOP); + + NewOp(1101, methop, 1, METHOP); + if (dynamic_meth) { + if (PL_opargs[type] & OA_MARK) dynamic_meth = force_list(dynamic_meth, 1); + methop->op_flags = (U8)(flags | OPf_KIDS); + methop->op_u.op_first = dynamic_meth; + methop->op_private = (U8)(1 | (flags >> 8)); + } + else { + assert(const_meth); + methop->op_flags = (U8)(flags & ~OPf_KIDS); + methop->op_u.op_meth_sv = const_meth; + methop->op_private = (U8)(0 | (flags >> 8)); + methop->op_next = (OP*)methop; + } + + methop->op_type = (OPCODE)type; + methop->op_ppaddr = PL_ppaddr[type]; + methop = (METHOP*) CHECKOP(type, methop); + + if (methop->op_next) return (OP*)methop; + + return fold_constants(op_integerize(op_std_init((OP *) methop))); +} + +OP * +Perl_newMETHOP (pTHX_ I32 type, I32 flags, OP* dynamic_meth) { + PERL_ARGS_ASSERT_NEWMETHOP; + return newMETHOP_internal(type, flags, dynamic_meth, NULL); +} + +/* +=for apidoc Am|OP *|newMETHOP_named|I32 type|I32 flags|SV *const_meth + +Constructs, checks, and returns an op of method type with a constant +method name. I is the opcode. I gives the eight bits of +C, and, shifted up eight bits, the eight bits of +C. I supplies a constant method name; +it must be a shared COW string. +Supported optypes: OP_METHOD_NAMED. + +=cut +*/ + +OP * +Perl_newMETHOP_named (pTHX_ I32 type, I32 flags, SV* const_meth) { + PERL_ARGS_ASSERT_NEWMETHOP_NAMED; + return newMETHOP_internal(type, flags, NULL, const_meth); +} + +/* =for apidoc Am|OP *|newBINOP|I32 type|I32 flags|OP *first|OP *last Constructs, checks, and returns an op of any binary type. I @@ -4341,16 +4565,16 @@ Perl_newBINOP(pTHX_ I32 type, I32 flags, OP *first, OP *last) last->op_sibling = (OP*)binop; #endif - binop = (BINOP*)CHECKOP(type, binop); - if (binop->op_next || binop->op_type != (OPCODE)type) - return (OP*)binop; - binop->op_last = OP_SIBLING(binop->op_first); #ifdef PERL_OP_PARENT if (binop->op_last) binop->op_last->op_sibling = (OP*)binop; #endif + binop = (BINOP*)CHECKOP(type, binop); + if (binop->op_next || binop->op_type != (OPCODE)type) + return (OP*)binop; + return fold_constants(op_integerize(op_std_init((OP *)binop))); } @@ -4845,7 +5069,15 @@ Perl_pmruntime(pTHX_ OP *o, OP *expr, bool isreg, I32 floor) for (o = cLISTOPx(expr)->op_first; o; o = OP_SIBLING(o)) { if (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)) { has_code = 1; - assert(!o->op_next && OP_HAS_SIBLING(o)); + assert(!o->op_next); + if (UNLIKELY(!OP_HAS_SIBLING(o))) { + assert(PL_parser && PL_parser->error_count); + /* This can happen with qr/ (?{(^{})/. Just fake up + the op we were expecting to see, to avoid crashing + elsewhere. */ + op_sibling_splice(expr, o, 0, + newSVOP(OP_CONST, 0, &PL_sv_no)); + } o->op_next = OP_SIBLING(o); } else if (o->op_type != OP_CONST && o->op_type != OP_PUSHMARK) @@ -5202,7 +5434,8 @@ Perl_newPADOP(pTHX_ I32 type, I32 flags, SV *sv) NewOp(1101, padop, 1, PADOP); padop->op_type = (OPCODE)type; padop->op_ppaddr = PL_ppaddr[type]; - padop->op_padix = pad_alloc(type, SVs_PADTMP); + padop->op_padix = + pad_alloc(type, isGV(sv) ? SVf_READONLY : SVs_PADTMP); SvREFCNT_dec(PAD_SVl(padop->op_padix)); PAD_SETSV(padop->op_padix, sv); assert(sv); @@ -5235,7 +5468,6 @@ Perl_newGVOP(pTHX_ I32 type, I32 flags, GV *gv) PERL_ARGS_ASSERT_NEWGVOP; #ifdef USE_ITHREADS - GvIN_PAD_on(gv); return newPADOP(type, flags, SvREFCNT_inc_simple_NN(gv)); #else return newSVOP(type, flags, SvREFCNT_inc_simple_NN(gv)); @@ -5297,7 +5529,6 @@ Perl_package(pTHX_ OP *o) PL_hints |= HINT_BLOCK_SCOPE; PL_parser->copline = NOLINE; - PL_parser->expect = XSTATE; op_free(o); } @@ -5349,7 +5580,7 @@ Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *idop, OP *arg) veop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL, op_append_elem(OP_LIST, op_prepend_elem(OP_LIST, pack, list(version)), - newSVOP(OP_METHOD_NAMED, 0, meth))); + newMETHOP_named(OP_METHOD_NAMED, 0, meth))); } } @@ -5376,7 +5607,7 @@ Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *idop, OP *arg) imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL, op_append_elem(OP_LIST, op_prepend_elem(OP_LIST, pack, list(arg)), - newSVOP(OP_METHOD_NAMED, 0, meth))); + newMETHOP_named(OP_METHOD_NAMED, 0, meth))); } /* Fake up the BEGIN {}, which does its thing immediately. */ @@ -5436,7 +5667,6 @@ Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *idop, OP *arg) PL_hints |= HINT_BLOCK_SCOPE; PL_parser->copline = NOLINE; - PL_parser->expect = XSTATE; PL_cop_seqmax++; /* Purely for B::*'s benefit */ if (PL_cop_seqmax == PERL_PADSEQ_INTRO) /* not a legal value */ PL_cop_seqmax++; @@ -5586,11 +5816,15 @@ Perl_newSLICEOP(pTHX_ I32 flags, OP *subscript, OP *listval) list(force_list(listval, 1)) ); } +#define ASSIGN_LIST 1 +#define ASSIGN_REF 2 + STATIC I32 -S_is_list_assignment(pTHX_ const OP *o) +S_assignment_type(pTHX_ const OP *o) { unsigned type; U8 flags; + U8 ret; if (!o) return TRUE; @@ -5602,40 +5836,72 @@ S_is_list_assignment(pTHX_ const OP *o) type = o->op_type; if (type == OP_COND_EXPR) { OP * const sib = OP_SIBLING(cLOGOPo->op_first); - const I32 t = is_list_assignment(sib); - const I32 f = is_list_assignment(OP_SIBLING(sib)); + const I32 t = assignment_type(sib); + const I32 f = assignment_type(OP_SIBLING(sib)); - if (t && f) - return TRUE; - if (t || f) + if (t == ASSIGN_LIST && f == ASSIGN_LIST) + return ASSIGN_LIST; + if ((t == ASSIGN_LIST) ^ (f == ASSIGN_LIST)) yyerror("Assignment to both a list and a scalar"); return FALSE; } + if (type == OP_SREFGEN) + { + OP * const kid = cUNOPx(cUNOPo->op_first)->op_first; + type = kid->op_type; + flags |= kid->op_flags; + if (!(flags & OPf_PARENS) + && (kid->op_type == OP_RV2AV || kid->op_type == OP_PADAV || + kid->op_type == OP_RV2HV || kid->op_type == OP_PADHV )) + return ASSIGN_REF; + ret = ASSIGN_REF; + } + else ret = 0; + if (type == OP_LIST && (flags & OPf_WANT) == OPf_WANT_SCALAR && o->op_private & OPpLVAL_INTRO) - return FALSE; + return ret; if (type == OP_LIST || flags & OPf_PARENS || type == OP_RV2AV || type == OP_RV2HV || type == OP_ASLICE || type == OP_HSLICE || - type == OP_KVASLICE || type == OP_KVHSLICE) + type == OP_KVASLICE || type == OP_KVHSLICE || type == OP_REFGEN) return TRUE; if (type == OP_PADAV || type == OP_PADHV) return TRUE; if (type == OP_RV2SV) - return FALSE; + return ret; - return FALSE; + return ret; } /* Helper function for newASSIGNOP to detection commonality between the - lhs and the rhs. Marks all variables with PL_generation. If it + lhs and the rhs. (It is actually called very indirectly. newASSIGNOP + flags the op and the peephole optimizer calls this helper function + if the flag is set.) Marks all variables with PL_generation. If it returns TRUE the assignment must be able to handle common variables. + + PL_generation sorcery: + An assignment like ($a,$b) = ($c,$d) is easier than + ($a,$b) = ($c,$a), since there is no need for temporary vars. + To detect whether there are common vars, the global var + PL_generation is incremented for each assign op we compile. + Then, while compiling the assign op, we run through all the + variables on both sides of the assignment, setting a spare slot + in each of them to PL_generation. If any of them already have + that value, we know we've got commonality. Also, if the + generation number is already set to PERL_INT_MAX, then + the variable is involved in aliasing, so we also have + potential commonality in that case. We could use a + single bit marker, but then we'd have to make 2 passes, first + to clear the flag, then to test and set it. And that + wouldn't help with aliasing, either. To find somewhere + to store these values, evil chicanery is done with SvUVX(). */ PERL_STATIC_INLINE bool S_aassign_common_vars(pTHX_ OP* o) @@ -5643,7 +5909,7 @@ S_aassign_common_vars(pTHX_ OP* o) OP *curop; for (curop = cUNOPo->op_first; curop; curop = OP_SIBLING(curop)) { if (PL_opargs[curop->op_type] & OA_DANGEROUS) { - if (curop->op_type == OP_GV) { + if (curop->op_type == OP_GV || curop->op_type == OP_GVSV) { GV *gv = cGVOPx_gv(curop); if (gv == PL_defgv || (int)GvASSIGN_GENERATION(gv) == PL_generation) @@ -5656,7 +5922,8 @@ S_aassign_common_vars(pTHX_ OP* o) curop->op_type == OP_PADANY) { if (PAD_COMPNAME_GEN(curop->op_targ) - == (STRLEN)PL_generation) + == (STRLEN)PL_generation + || PAD_COMPNAME_GEN(curop->op_targ) == PERL_INT_MAX) return TRUE; PAD_COMPNAME_GEN_set(curop->op_targ, PL_generation); @@ -5686,6 +5953,9 @@ S_aassign_common_vars(pTHX_ OP* o) GvASSIGN_GENERATION_set(gv, PL_generation); } } + else if (curop->op_type == OP_PADRANGE) + /* Ignore padrange; checking its siblings is sufficient. */ + continue; else return TRUE; } @@ -5698,6 +5968,29 @@ S_aassign_common_vars(pTHX_ OP* o) return FALSE; } +/* This variant only handles lexical aliases. It is called when + newASSIGNOP decides that we don’t have any common vars, as lexical ali- + ases trump that decision. */ +PERL_STATIC_INLINE bool +S_aassign_common_vars_aliases_only(pTHX_ OP *o) +{ + OP *curop; + for (curop = cUNOPo->op_first; curop; curop = OP_SIBLING(curop)) { + if ((curop->op_type == OP_PADSV || + curop->op_type == OP_PADAV || + curop->op_type == OP_PADHV || + curop->op_type == OP_PADANY) + && PAD_COMPNAME_GEN(curop->op_targ) == PERL_INT_MAX) + return TRUE; + + if (curop->op_flags & OPf_KIDS) { + if (S_aassign_common_vars_aliases_only(aTHX_ curop)) + return TRUE; + } + } + return FALSE; +} + /* =for apidoc Am|OP *|newASSIGNOP|I32 flags|OP *left|I32 optype|OP *right @@ -5725,6 +6018,7 @@ OP * Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right) { OP *o; + I32 assign_type; if (optype) { if (optype == OP_ANDASSIGN || optype == OP_ORASSIGN || optype == OP_DORASSIGN) { @@ -5738,7 +6032,7 @@ Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right) } } - if (is_list_assignment(left)) { + if ((assign_type = assignment_type(left)) == ASSIGN_LIST) { static const char no_list_state[] = "Initialization of state variables" " in list context currently forbidden"; OP *curop; @@ -5763,7 +6057,10 @@ Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right) lop->op_type == OP_PADHV || lop->op_type == OP_PADANY) { if (!(lop->op_private & OPpLVAL_INTRO)) + { maybe_common_vars = TRUE; + break; + } if (lop->op_private & OPpPAD_STATE) { if (left->op_private & OPpLVAL_INTRO) { @@ -5785,6 +6082,7 @@ Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right) } else { /* Other ops in the list. */ maybe_common_vars = TRUE; + break; } lop = OP_SIBLING(lop); } @@ -5811,42 +6109,26 @@ Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right) } } - /* PL_generation sorcery: - * an assignment like ($a,$b) = ($c,$d) is easier than - * ($a,$b) = ($c,$a), since there is no need for temporary vars. - * To detect whether there are common vars, the global var - * PL_generation is incremented for each assign op we compile. - * Then, while compiling the assign op, we run through all the - * variables on both sides of the assignment, setting a spare slot - * in each of them to PL_generation. If any of them already have - * that value, we know we've got commonality. We could use a - * single bit marker, but then we'd have to make 2 passes, first - * to clear the flag, then to test and set it. To find somewhere - * to store these values, evil chicanery is done with SvUVX(). - */ - if (maybe_common_vars) { - PL_generation++; - if (aassign_common_vars(o)) + /* The peephole optimizer will do the full check and pos- + sibly turn this off. */ o->op_private |= OPpASSIGN_COMMON; - LINKLIST(o); } if (right && right->op_type == OP_SPLIT) { OP* tmpop = ((LISTOP*)right)->op_first; if (tmpop && (tmpop->op_type == OP_PUSHRE)) { PMOP * const pm = (PMOP*)tmpop; - if (left->op_type == OP_RV2AV && - !(left->op_private & OPpLVAL_INTRO) && - !(o->op_private & OPpASSIGN_COMMON) ) - { - tmpop = ((UNOP*)left)->op_first; - if (tmpop->op_type == OP_GV + if ( #ifdef USE_ITHREADS - && !pm->op_pmreplrootu.op_pmtargetoff + !pm->op_pmreplrootu.op_pmtargetoff #else - && !pm->op_pmreplrootu.op_pmtargetgv + !pm->op_pmreplrootu.op_pmtargetgv #endif + ) { + if (left->op_type == OP_RV2AV && + !(left->op_private & OPpLVAL_INTRO) && + (tmpop = ((UNOP*)left)->op_first)->op_type == OP_GV ) { #ifdef USE_ITHREADS pm->op_pmreplrootu.op_pmtargetoff @@ -5862,16 +6144,15 @@ Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right) /* detach rest of siblings from o subtree, * and free subtree */ op_sibling_splice(cUNOPo->op_first, tmpop, -1, NULL); - right->op_next = tmpop->op_next; /* fix starting loc */ + right->op_private |= + left->op_private & OPpOUR_INTRO; op_free(o); /* blow off assign */ right->op_flags &= ~OPf_WANT; /* "I don't know and I don't care." */ return right; } - } - else { - if (PL_modcount < RETURN_UNLIMITED_NUMBER && - ((LISTOP*)right)->op_last->op_type == OP_CONST) + else if (PL_modcount < RETURN_UNLIMITED_NUMBER && + ((LISTOP*)right)->op_last->op_type == OP_CONST) { SV ** const svp = &((SVOP*)((LISTOP*)right)->op_last)->op_sv; @@ -5895,6 +6176,8 @@ Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right) } return o; } + if (assign_type == ASSIGN_REF) + return newBINOP(OP_REFASSIGN, flags, scalar(right), left); if (!right) right = newOP(OP_UNDEF, 0); if (right->op_type == OP_READLINE) { @@ -6385,10 +6668,11 @@ Perl_newRANGE(pTHX_ I32 flags, OP *left, OP *right) left->op_next = flip; right->op_next = flop; - range->op_targ = pad_alloc(OP_RANGE, SVs_PADMY); + range->op_targ = pad_add_name_pvn("$", 1, padadd_NO_DUP_CHECK, 0, 0); sv_upgrade(PAD_SV(range->op_targ), SVt_PVNV); - flip->op_targ = pad_alloc(OP_RANGE, SVs_PADMY); + flip->op_targ = pad_add_name_pvn("$", 1, padadd_NO_DUP_CHECK, 0, 0);; sv_upgrade(PAD_SV(flip->op_targ), SVt_PVNV); + SvPADTMP_on(PAD_SV(flip->op_targ)); flip->op_private = left->op_type == OP_CONST ? OPpFLIP_LINENUM : 0; flop->op_private = right->op_type == OP_CONST ? OPpFLIP_LINENUM : 0; @@ -6687,7 +6971,10 @@ Perl_newFOROP(pTHX_ I32 flags, OP *sv, OP *expr, OP *block, OP *cont) sv->op_targ = 0; op_free(sv); sv = NULL; + PAD_COMPNAME_GEN_set(padoff, PERL_INT_MAX); } + else if (sv->op_type == OP_NULL && sv->op_targ == OP_SREFGEN) + NOOP; else Perl_croak(aTHX_ "Can't use %s for loop variable", PL_op_desc[sv->op_type]); if (padoff) { @@ -7052,12 +7339,19 @@ Perl_newWHENOP(pTHX_ OP *cond, OP *block) return newGIVWHENOP(cond_op, block, OP_ENTERWHEN, OP_LEAVEWHEN, 0); } +/* must not conflict with SVf_UTF8 */ +#define CV_CKPROTO_CURSTASH 0x1 + void Perl_cv_ckproto_len_flags(pTHX_ const CV *cv, const GV *gv, const char *p, const STRLEN len, const U32 flags) { SV *name = NULL, *msg; - const char * cvp = SvROK(cv) ? "" : CvPROTO(cv); + const char * cvp = SvROK(cv) + ? SvTYPE(SvRV_const(cv)) == SVt_PVCV + ? (cv = (const CV *)SvRV_const(cv), CvPROTO(cv)) + : "" + : CvPROTO(cv); STRLEN clen = CvPROTOLEN(cv), plen = len; PERL_ARGS_ASSERT_CV_CKPROTO_LEN_FLAGS; @@ -7094,6 +7388,16 @@ Perl_cv_ckproto_len_flags(pTHX_ const CV *cv, const GV *gv, const char *p, gv_efullname3(name = sv_newmortal(), gv, NULL); else if (SvPOK(gv) && *SvPVX((SV *)gv) == '&') name = newSVpvn_flags(SvPVX((SV *)gv)+1, SvCUR(gv)-1, SvUTF8(gv)|SVs_TEMP); + else if (flags & CV_CKPROTO_CURSTASH || SvROK(gv)) { + name = sv_2mortal(newSVhek(HvNAME_HEK(PL_curstash))); + sv_catpvs(name, "::"); + if (SvROK(gv)) { + assert (SvTYPE(SvRV_const(gv)) == SVt_PVCV); + assert (CvNAMED(SvRV_const(gv))); + sv_cathek(name, CvNAME_HEK(MUTABLE_CV(SvRV_const(gv)))); + } + else sv_catsv(name, (SV *)gv); + } else name = (SV *)gv; } sv_setpvs(msg, "Prototype mismatch:"); @@ -7148,6 +7452,7 @@ Perl_cv_const_sv_or_av(const CV * const cv) { if (!cv) return NULL; + if (SvROK(cv)) return SvRV((SV *)cv); assert (SvTYPE(cv) == SVt_PVCV || SvTYPE(cv) == SVt_PVFM); return CvCONST(cv) ? MUTABLE_SV(CvXSUBANY(cv).any_ptr) : NULL; } @@ -7203,6 +7508,10 @@ Perl_op_const_sv(pTHX_ const OP *o, CV *cv) return NULL; if (type == OP_CONST && cSVOPo->op_sv) sv = cSVOPo->op_sv; + else if (type == OP_UNDEF && !o->op_private) { + sv = newSV(0); + SAVEFREESV(sv); + } else if (cv && type == OP_CONST) { sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ); if (!sv) @@ -7357,12 +7666,16 @@ Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block) if (CvNAMED(*spot)) hek = CvNAME_HEK(*spot); else { + dVAR; + U32 hash; + PERL_HASH(hash, PadnamePV(name)+1, PadnameLEN(name)-1); CvNAME_HEK_set(*spot, hek = share_hek( PadnamePV(name)+1, - PadnameLEN(name)-1 * (PadnameUTF8(name) ? -1 : 1), 0 + PadnameLEN(name)-1 * (PadnameUTF8(name) ? -1 : 1), hash ) ); + CvLEXICAL_on(*spot); } if (mg) { assert(mg->mg_obj); @@ -7409,7 +7722,7 @@ Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block) } if (const_sv) { SvREFCNT_inc_simple_void_NN(const_sv); - SvFLAGS(const_sv) = (SvFLAGS(const_sv) & ~SVs_PADMY) | SVs_PADTMP; + SvFLAGS(const_sv) |= SVs_PADTMP; if (cv) { assert(!CvROOT(cv) && !CvCONST(cv)); cv_forget_slab(cv); @@ -7489,14 +7802,18 @@ Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block) *spot = cv; } setname: + CvLEXICAL_on(cv); if (!CvNAME_HEK(cv)) { - CvNAME_HEK_set(cv, - hek - ? share_hek_hek(hek) - : share_hek(PadnamePV(name)+1, + if (hek) (void)share_hek_hek(hek); + else { + dVAR; + U32 hash; + PERL_HASH(hash, PadnamePV(name)+1, PadnameLEN(name)-1); + hek = share_hek(PadnamePV(name)+1, PadnameLEN(name)-1 * (PadnameUTF8(name) ? -1 : 1), - 0) - ); + hash); + } + CvNAME_HEK_set(cv, hek); } if (const_sv) goto clone; @@ -7597,7 +7914,6 @@ Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block) else *spot = cv_clone(clonee); SvREFCNT_dec_NN(clonee); cv = *spot; - SvPADMY_on(cv); } if (CvDEPTH(outcv) && !reusable && PadnameIsSTATE(name)) { PADOFFSET depth = CvDEPTH(outcv); @@ -7633,7 +7949,7 @@ Perl_newATTRSUB_x(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, /* If the subroutine has no body, no attributes, and no builtin attributes then it's just a sub declaration, and we may be able to get away with storing with a placeholder scalar in the symbol table, rather than a - full GV and CV. If anything is present then it will take a full CV to + full CV. If anything is present then it will take a full CV to store it. */ const I32 gv_fetch_flags = ec ? GV_NOADD_NOINIT : @@ -7646,6 +7962,7 @@ Perl_newATTRSUB_x(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, bool name_is_utf8 = o && !o_is_gv && SvUTF8(cSVOPo->op_sv); #ifdef PERL_DEBUG_READONLY_OPS OPSLAB *slab = NULL; + bool special = FALSE; #endif if (o_is_gv) { @@ -7653,7 +7970,20 @@ Perl_newATTRSUB_x(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, o = NULL; has_name = TRUE; } else if (name) { - gv = gv_fetchsv(cSVOPo->op_sv, gv_fetch_flags, SVt_PVCV); + /* Try to optimise and avoid creating a GV. Instead, the CV’s name + hek and CvSTASH pointer together can imply the GV. If the name + contains a package name, then GvSTASH(CvGV(cv)) may differ from + CvSTASH, so forego the optimisation if we find any. + Also, we may be called from load_module at run time, so + PL_curstash (which sets CvSTASH) may not point to the stash the + sub is stored in. */ + const I32 flags = + ec ? GV_NOADD_NOINIT + : PL_curstash != CopSTASH(PL_curcop) + || memchr(name, ':', namlen) || memchr(name, '\'', namlen) + ? gv_fetch_flags + : GV_ADDMULTI | GV_NOINIT; + gv = gv_fetchsv(cSVOPo->op_sv, flags, SVt_PVCV); has_name = TRUE; } else if (PERLDB_NAMEANON && CopLINE(PL_curcop)) { SV * const sv = sv_newmortal(); @@ -7670,7 +8000,8 @@ Perl_newATTRSUB_x(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, has_name = FALSE; } if (!ec) - move_proto_attr(&proto, &attrs, gv); + move_proto_attr(&proto, &attrs, + isGV(gv) ? gv : (GV *)cSVOPo->op_sv); if (proto) { assert(proto->op_type == OP_CONST); @@ -7709,26 +8040,46 @@ Perl_newATTRSUB_x(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, goto done; } - if (SvTYPE(gv) != SVt_PVGV) { /* Maybe prototype now, and had at - maximum a prototype before. */ + if (!block && SvTYPE(gv) != SVt_PVGV) { + /* If we are not defining a new sub and the existing one is not a + full GV + CV... */ + if (attrs || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS)) { + /* We are applying attributes to an existing sub, so we need it + upgraded if it is a constant. */ + if (SvROK(gv) && SvTYPE(SvRV(gv)) != SVt_PVCV) + gv_init_pvn(gv, PL_curstash, name, namlen, + SVf_UTF8 * name_is_utf8); + } + else { /* Maybe prototype now, and had at maximum + a prototype or const/sub ref before. */ if (SvTYPE(gv) > SVt_NULL) { cv_ckproto_len_flags((const CV *)gv, o ? (const GV *)cSVOPo->op_sv : NULL, ps, ps_len, ps_utf8); } - if (ps) { + if (!SvROK(gv)) { + if (ps) { sv_setpvn(MUTABLE_SV(gv), ps, ps_len); if ( ps_utf8 ) SvUTF8_on(MUTABLE_SV(gv)); - } - else + } + else sv_setiv(MUTABLE_SV(gv), -1); + } SvREFCNT_dec(PL_compcv); cv = PL_compcv = NULL; goto done; + } } - cv = (!name || GvCVGEN(gv)) ? NULL : GvCV(gv); + cv = (!name || (isGV(gv) && GvCVGEN(gv))) + ? NULL + : isGV(gv) + ? GvCV(gv) + : SvROK(gv) && SvTYPE(SvRV(gv)) == SVt_PVCV + ? (CV *)SvRV(gv) + : NULL; + if (!block || !ps || *ps || attrs || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS) @@ -7737,6 +8088,38 @@ Perl_newATTRSUB_x(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, else const_sv = op_const_sv(block, NULL); + if (SvPOK(gv) || (SvROK(gv) && SvTYPE(SvRV(gv)) != SVt_PVCV)) { + assert (block); + cv_ckproto_len_flags((const CV *)gv, + o ? (const GV *)cSVOPo->op_sv : NULL, ps, + ps_len, ps_utf8|CV_CKPROTO_CURSTASH); + if (SvROK(gv)) { + /* All the other code for sub redefinition warnings expects the + clobbered sub to be a CV. Instead of making all those code + paths more complex, just inline the RV version here. */ + const line_t oldline = CopLINE(PL_curcop); + assert(IN_PERL_COMPILETIME); + if (PL_parser && PL_parser->copline != NOLINE) + /* This ensures that warnings are reported at the first + line of a redefinition, not the last. */ + CopLINE_set(PL_curcop, PL_parser->copline); + /* protect against fatal warnings leaking compcv */ + SAVEFREESV(PL_compcv); + + if (ckWARN(WARN_REDEFINE) + || ( ckWARN_d(WARN_REDEFINE) + && ( !const_sv || SvRV(gv) == const_sv + || sv_cmp(SvRV(gv), const_sv) ))) + Perl_warner(aTHX_ packWARN(WARN_REDEFINE), + "Constant subroutine %"SVf" redefined", + SVfARG(cSVOPo->op_sv)); + + SvREFCNT_inc_simple_void_NN(PL_compcv); + CopLINE_set(PL_curcop, oldline); + SvREFCNT_dec(SvRV(gv)); + } + } + if (cv) { const bool exists = CvROOT(cv) || CvXSUB(cv); @@ -7747,7 +8130,7 @@ Perl_newATTRSUB_x(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, if (exists || SvPOK(cv)) cv_ckproto_len_flags(cv, gv, ps, ps_len, ps_utf8); /* already defined (or promised)? */ - if (exists || GvASSUMECV(gv)) { + if (exists || (isGV(gv) && GvASSUMECV(gv))) { if (S_already_defined(aTHX_ cv, block, o, NULL, &const_sv)) cv = NULL; else { @@ -7760,7 +8143,7 @@ Perl_newATTRSUB_x(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, } if (const_sv) { SvREFCNT_inc_simple_void_NN(const_sv); - SvFLAGS(const_sv) = (SvFLAGS(const_sv) & ~SVs_PADMY) | SVs_PADTMP; + SvFLAGS(const_sv) |= SVs_PADTMP; if (cv) { assert(!CvROOT(cv) && !CvCONST(cv)); cv_forget_slab(cv); @@ -7771,11 +8154,22 @@ Perl_newATTRSUB_x(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, CvISXSUB_on(cv); } else { - GvCV_set(gv, NULL); - cv = newCONSTSUB_flags( - NULL, name, namlen, name_is_utf8 ? SVf_UTF8 : 0, - const_sv - ); + if (isGV(gv)) { + if (name) GvCV_set(gv, NULL); + cv = newCONSTSUB_flags( + NULL, name, namlen, name_is_utf8 ? SVf_UTF8 : 0, + const_sv + ); + } + else { + if (!SvROK(gv)) { + SV_CHECK_THINKFIRST_COW_DROP((SV *)gv); + prepare_SV_for_RV((SV *)gv); + SvOK_off((SV *)gv); + SvROK_on(gv); + } + SvRV_set(gv, const_sv); + } } op_free(block); SvREFCNT_dec(PL_compcv); @@ -7793,12 +8187,26 @@ Perl_newATTRSUB_x(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, CvFLAGS(cv) & (CVf_SLABBED|CVf_WEAKOUTSIDE); OP * const cvstart = CvSTART(cv); - CvGV_set(cv,gv); - assert(!CvCVGV_RC(cv)); - assert(CvGV(cv) == gv); + if (isGV(gv)) { + CvGV_set(cv,gv); + assert(!CvCVGV_RC(cv)); + assert(CvGV(cv) == gv); + } + else { + dVAR; + U32 hash; + PERL_HASH(hash, name, namlen); + CvNAME_HEK_set(cv, + share_hek(name, + name_is_utf8 + ? -(SSize_t)namlen + : (SSize_t)namlen, + hash)); + } SvPOK_off(cv); - CvFLAGS(cv) = CvFLAGS(PL_compcv) | existing_builtin_attrs; + CvFLAGS(cv) = CvFLAGS(PL_compcv) | existing_builtin_attrs + | CvNAMED(cv); CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv); CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(PL_compcv); CvPADLIST(cv) = CvPADLIST(PL_compcv); @@ -7830,16 +8238,35 @@ Perl_newATTRSUB_x(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, } else { cv = PL_compcv; - if (name) { + if (name && isGV(gv)) { GvCV_set(gv, cv); GvCVGEN(gv) = 0; if (HvENAME_HEK(GvSTASH(gv))) /* sub Foo::bar { (shift)+1 } */ gv_method_changed(gv); } + else if (name) { + if (!SvROK(gv)) { + SV_CHECK_THINKFIRST_COW_DROP((SV *)gv); + prepare_SV_for_RV((SV *)gv); + SvOK_off((SV *)gv); + SvROK_on(gv); + } + SvRV_set(gv, (SV *)cv); + } } - if (!CvGV(cv)) { - CvGV_set(cv, gv); + if (!CvHASGV(cv)) { + if (isGV(gv)) CvGV_set(cv, gv); + else { + dVAR; + U32 hash; + PERL_HASH(hash, name, namlen); + CvNAME_HEK_set(cv, share_hek(name, + name_is_utf8 + ? -(SSize_t)namlen + : (SSize_t)namlen, + hash)); + } CvFILE_set_from_cop(cv, PL_curcop); CvSTASH_set(cv, PL_curstash); } @@ -7896,7 +8323,9 @@ Perl_newATTRSUB_x(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, attrs: if (attrs) { /* Need to do a C. */ - HV *stash = name && GvSTASH(CvGV(cv)) ? GvSTASH(CvGV(cv)) : PL_curstash; + HV *stash = name && !CvNAMED(cv) && GvSTASH(CvGV(cv)) + ? GvSTASH(CvGV(cv)) + : PL_curstash; if (!name) SAVEFREESV(cv); apply_attrs(stash, MUTABLE_SV(cv), attrs); if (!name) SvREFCNT_inc_simple_void_NN(cv); @@ -7904,7 +8333,7 @@ Perl_newATTRSUB_x(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, if (block && has_name) { if (PERLDB_SUBLINE && PL_curstash != PL_debstash) { - SV * const tmpstr = sv_newmortal(); + SV * const tmpstr = cv_name(cv,NULL,0); GV * const db_postponed = gv_fetchpvs("DB::postponed", GV_ADDMULTI, SVt_PVHV); HV *hv; @@ -7912,7 +8341,6 @@ Perl_newATTRSUB_x(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, CopFILE(PL_curcop), (long)PL_subline, (long)CopLINE(PL_curcop)); - gv_efullname3(tmpstr, gv, NULL); (void)hv_store(GvHV(PL_DBsub), SvPVX_const(tmpstr), SvUTF8(tmpstr) ? -(I32)SvCUR(tmpstr) : (I32)SvCUR(tmpstr), sv, 0); hv = GvHVn(db_postponed); @@ -7932,7 +8360,10 @@ Perl_newATTRSUB_x(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, if (PL_parser && PL_parser->error_count) clear_special_blocks(name, gv, cv); else - process_special_blocks(floor, name, gv, cv); +#ifdef PERL_DEBUG_READONLY_OPS + special = +#endif + process_special_blocks(floor, name, gv, cv); } } @@ -7942,7 +8373,7 @@ Perl_newATTRSUB_x(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, LEAVE_SCOPE(floor); #ifdef PERL_DEBUG_READONLY_OPS /* Watch out for BEGIN blocks */ - if (slab && gv && isGV(gv) && GvCV(gv)) Slab_to_ro(slab); + if (!special) Slab_to_ro(slab); #endif return cv; } @@ -7963,12 +8394,16 @@ S_clear_special_blocks(pTHX_ const char *const fullname, || (*name == 'U' && strEQ(name, "UNITCHECK")) || (*name == 'C' && strEQ(name, "CHECK")) || (*name == 'I' && strEQ(name, "INIT"))) { + if (!isGV(gv)) { + (void)CvGV(cv); + assert(isGV(gv)); + } GvCV_set(gv, NULL); SvREFCNT_dec_NN(MUTABLE_SV(cv)); } } -STATIC void +STATIC bool S_process_special_blocks(pTHX_ I32 floor, const char *const fullname, GV *const gv, CV *const cv) @@ -7982,6 +8417,7 @@ S_process_special_blocks(pTHX_ I32 floor, const char *const fullname, if (strEQ(name, "BEGIN")) { const I32 oldscope = PL_scopestack_ix; dSP; + (void)CvGV(cv); if (floor) LEAVE_SCOPE(floor); ENTER; PUSHSTACKi(PERLSI_REQUIRE); @@ -7996,23 +8432,24 @@ S_process_special_blocks(pTHX_ I32 floor, const char *const fullname, POPSTACK; LEAVE; + return TRUE; } else - return; + return FALSE; } else { if (*name == 'E') { if strEQ(name, "END") { DEBUG_x( dump_sub(gv) ); Perl_av_create_and_unshift_one(aTHX_ &PL_endav, MUTABLE_SV(cv)); } else - return; + return FALSE; } 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, MUTABLE_SV(cv)); } else - return; + return FALSE; } else if (*name == 'C') { if (strEQ(name, "CHECK")) { if (PL_main_start) @@ -8022,7 +8459,7 @@ S_process_special_blocks(pTHX_ I32 floor, const char *const fullname, Perl_av_create_and_unshift_one(aTHX_ &PL_checkav, MUTABLE_SV(cv)); } else - return; + return FALSE; } else if (*name == 'I') { if (strEQ(name, "INIT")) { if (PL_main_start) @@ -8032,11 +8469,13 @@ S_process_special_blocks(pTHX_ I32 floor, const char *const fullname, Perl_av_create_and_push(aTHX_ &PL_initav, MUTABLE_SV(cv)); } else - return; + return FALSE; } else - return; + return FALSE; DEBUG_x( dump_sub(gv) ); + (void)CvGV(cv); GvCV_set(gv,0); /* cv has been hijacked */ + return TRUE; } } @@ -8637,9 +9076,14 @@ Perl_ck_spair(pTHX_ OP *o) newop = OP_SIBLING(kidkid); if (newop) { const OPCODE type = newop->op_type; - if (OP_HAS_SIBLING(newop) || !(PL_opargs[type] & OA_RETSCALAR) || - type == OP_PADAV || type == OP_PADHV || - type == OP_RV2AV || type == OP_RV2HV) + if (OP_HAS_SIBLING(newop)) + return o; + if (o->op_type == OP_REFGEN && !(newop->op_flags & OPf_PARENS) + && (type == OP_RV2AV || type == OP_PADAV + || type == OP_RV2HV || type == OP_PADHV + || type == OP_RV2CV)) + NOOP; /* OK (allow srefgen for \@a and \%h) */ + else if (!(PL_opargs[type] & OA_RETSCALAR)) return o; } /* excise first sibling */ @@ -8826,8 +9270,6 @@ Perl_ck_rvconst(pTHX_ OP *o) PERL_ARGS_ASSERT_CK_RVCONST; o->op_private |= (PL_hints & HINT_STRICT_REFS); - if (o->op_type == OP_RV2CV) - o->op_private &= ~1; if (kid->op_type == OP_CONST) { int iscv; @@ -8835,31 +9277,7 @@ Perl_ck_rvconst(pTHX_ OP *o) SV * const kidsv = kid->op_sv; /* Is it a constant from cv_const_sv()? */ - if (SvROK(kidsv) && SvREADONLY(kidsv)) { - SV * const rsv = SvRV(kidsv); - const svtype type = SvTYPE(rsv); - const char *badtype = NULL; - - switch (o->op_type) { - case OP_RV2SV: - if (type > SVt_PVMG) - badtype = "a SCALAR"; - break; - case OP_RV2AV: - if (type != SVt_PVAV) - badtype = "an ARRAY"; - break; - case OP_RV2HV: - if (type != SVt_PVHV) - badtype = "a HASH"; - break; - case OP_RV2CV: - if (type != SVt_PVCV) - badtype = "a CODE"; - break; - } - if (badtype) - Perl_croak(aTHX_ "Constant is not %s reference", badtype); + if ((SvROK(kidsv) || isGV_with_GP(kidsv)) && SvREADONLY(kidsv)) { return o; } if (SvTYPE(kidsv) == SVt_PVAV) return o; @@ -8892,10 +9310,12 @@ Perl_ck_rvconst(pTHX_ OP *o) * or we get possible typo warnings. OPpCONST_ENTERED says * whether the lexer already added THIS instance of this symbol. */ - iscv = (o->op_type == OP_RV2CV) * 2; - do { - gv = gv_fetchsv(kidsv, - iscv | !(kid->op_private & OPpCONST_ENTERED), + iscv = o->op_type == OP_RV2CV ? GV_NOEXPAND|GV_ADDMULTI : 0; + gv = gv_fetchsv(kidsv, + o->op_type == OP_RV2CV + && o->op_private & OPpMAY_RETURN_CONSTANT + ? GV_NOEXPAND + : iscv | !(kid->op_private & OPpCONST_ENTERED), iscv ? SVt_PVCV : o->op_type == OP_RV2SV @@ -8905,16 +9325,21 @@ Perl_ck_rvconst(pTHX_ OP *o) : o->op_type == OP_RV2HV ? SVt_PVHV : SVt_PVGV); - } while (!gv && !(kid->op_private & OPpCONST_ENTERED) && !iscv++); if (gv) { + if (!isGV(gv)) { + assert(iscv); + assert(SvROK(gv)); + if (!(o->op_private & OPpMAY_RETURN_CONSTANT) + && SvTYPE(SvRV(gv)) != SVt_PVCV) + gv_fetchsv(kidsv, GV_ADDMULTI, SVt_PVCV); + } kid->op_type = OP_GV; SvREFCNT_dec(kid->op_sv); #ifdef USE_ITHREADS /* XXX hack: dependence on sizeof(PADOP) <= sizeof(SVOP) */ assert (sizeof(PADOP) <= sizeof(SVOP)); - kPADOP->op_padix = pad_alloc(OP_GV, SVs_PADTMP); + kPADOP->op_padix = pad_alloc(OP_GV, SVf_READONLY); SvREFCNT_dec(PAD_SVl(kPADOP->op_padix)); - GvIN_PAD_on(gv); PAD_SETSV(kPADOP->op_padix, MUTABLE_SV(SvREFCNT_inc_simple_NN(gv))); #else kid->op_sv = SvREFCNT_inc_simple_NN(gv); @@ -9408,7 +9833,7 @@ Perl_ck_readline(pTHX_ OP *o) } else { OP * const newop - = newUNOP(OP_READLINE, 0, newGVOP(OP_GV, 0, PL_argvgv)); + = newUNOP(OP_READLINE, o->op_flags | OPf_SPECIAL, newGVOP(OP_GV, 0, PL_argvgv)); op_free(o); return newop; } @@ -9548,23 +9973,18 @@ Perl_ck_sassign(pTHX_ OP *o) OP *const first = newOP(OP_NULL, 0); OP *const nullop = newCONDOP(0, first, o, other); OP *const condop = first->op_next; - /* hijacking PADSTALE for uninitialized state variables */ - SvPADSTALE_on(PAD_SVl(target)); condop->op_type = OP_ONCE; condop->op_ppaddr = PL_ppaddr[OP_ONCE]; - condop->op_targ = target; other->op_targ = target; - /* Because we change the type of the op here, we will skip the - assignment binop->op_last = OP_SIBLING(binop->op_first); at the - end of Perl_newBINOP(). So need to do it here. */ - cBINOPo->op_last = OP_SIBLING(cBINOPo->op_first); - cBINOPo->op_first->op_lastsib = 0; - cBINOPo->op_last ->op_lastsib = 1; -#ifdef PERL_OP_PARENT - cBINOPo->op_last->op_sibling = o; -#endif + /* Store the initializedness of state vars in a separate + pad entry. */ + condop->op_targ = + pad_add_name_pvn("$",1,padadd_NO_DUP_CHECK|padadd_STATE,0,0); + /* hijacking PADSTALE for uninitialized state variables */ + SvPADSTALE_on(PAD_SVl(condop->op_targ)); + return nullop; } } @@ -9591,25 +10011,26 @@ Perl_ck_match(pTHX_ OP *o) OP * Perl_ck_method(pTHX_ OP *o) { + SV* sv; + const char* method; OP * const kid = cUNOPo->op_first; PERL_ARGS_ASSERT_CK_METHOD; - - if (kid->op_type == OP_CONST) { - SV* sv = kSVOP->op_sv; - const char * const method = SvPVX_const(sv); - if (!(strchr(method, ':') || strchr(method, '\''))) { - OP *cmop; - if (!SvIsCOW_shared_hash(sv)) { - sv = newSVpvn_share(method, SvUTF8(sv) ? -(I32)SvCUR(sv) : (I32)SvCUR(sv), 0); - } - else { - kSVOP->op_sv = NULL; - } - cmop = newSVOP(OP_METHOD_NAMED, 0, sv); - op_free(o); - return cmop; - } + if (kid->op_type != OP_CONST) return o; + + sv = kSVOP->op_sv; + method = SvPVX_const(sv); + if (!(strchr(method, ':') || strchr(method, '\''))) { + OP *cmop; + if (!SvIsCOW_shared_hash(sv)) { + sv = newSVpvn_share(method, SvUTF8(sv) ? -(I32)SvCUR(sv) : (I32)SvCUR(sv), 0); + } + else { + kSVOP->op_sv = NULL; + } + cmop = newMETHOP_named(OP_METHOD_NAMED, 0, sv); + op_free(o); + return cmop; } return o; } @@ -9652,6 +10073,82 @@ Perl_ck_open(pTHX_ OP *o) } OP * +Perl_ck_refassign(pTHX_ OP *o) +{ + OP * const right = cLISTOPo->op_first; + OP * const left = OP_SIBLING(right); + OP * const varop = cUNOPx(cUNOPx(left)->op_first)->op_first; + bool stacked = 0; + + PERL_ARGS_ASSERT_CK_REFASSIGN; + assert (left); + assert (left->op_type == OP_SREFGEN); + + switch (varop->op_type) { + case OP_PADAV: + o->op_private = OPpLVREF_AV; + goto settarg; + case OP_PADHV: + o->op_private = OPpLVREF_HV; + case OP_PADSV: + settarg: + o->op_targ = varop->op_targ; + varop->op_targ = 0; + PAD_COMPNAME_GEN_set(o->op_targ, PERL_INT_MAX); + break; + case OP_RV2AV: + o->op_private = OPpLVREF_AV; + goto checkgv; + case OP_RV2HV: + o->op_private = OPpLVREF_HV; + case OP_RV2SV: + checkgv: + if (cUNOPx(varop)->op_first->op_type != OP_GV) goto bad; + goto null_and_stack; + case OP_RV2CV: { + OP * const kid = + cUNOPx(cUNOPx(cUNOPx(varop)->op_first)->op_first->op_sibling) + ->op_first; + o->op_private = OPpLVREF_CV; + if (kid->op_type == OP_GV) goto null_and_stack; + if (kid->op_type != OP_PADCV) goto bad; + o->op_targ = kid->op_targ; + kid->op_targ = 0; + break; + } + case OP_AELEM: + case OP_HELEM: + o->op_private = OPpLVREF_ELEM; + null_and_stack: + op_null(varop); + op_null(left); + stacked = TRUE; + break; + default: + bad: + /* diag_listed_as: Can't modify %s in %s */ + yyerror(Perl_form(aTHX_ "Can't modify reference to %s in scalar " + "assignment", + OP_DESC(varop))); + return o; + } + if (!FEATURE_LVREF_IS_ENABLED) + Perl_croak(aTHX_ + "Experimental lvalue references not enabled"); + Perl_ck_warner_d(aTHX_ + packWARN(WARN_EXPERIMENTAL__LVALUE_REFS), + "Lvalue references are experimental"); + o->op_private |= varop->op_private & (OPpLVAL_INTRO|OPpPAD_STATE); + if (stacked) o->op_flags |= OPf_STACKED; + else { + o->op_flags &=~ OPf_STACKED; + op_sibling_splice(o, right, 1, NULL); + op_free(left); + } + return o; +} + +OP * Perl_ck_repeat(pTHX_ OP *o) { PERL_ARGS_ASSERT_CK_REPEAT; @@ -9662,6 +10159,7 @@ Perl_ck_repeat(pTHX_ OP *o) kids = op_sibling_splice(o, NULL, -1, NULL); /* detach all kids */ kids = force_list(kids, 1); /* promote them to a list */ op_sibling_splice(o, NULL, 0, kids); /* and add back */ + if (cBINOPo->op_last == kids) cBINOPo->op_last = NULL; } else scalar(o); @@ -9677,12 +10175,15 @@ Perl_ck_require(pTHX_ OP *o) if (o->op_flags & OPf_KIDS) { /* Shall we supply missing .pm? */ SVOP * const kid = (SVOP*)cUNOPo->op_first; - - if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) { - SV * const sv = kid->op_sv; - U32 was_readonly = SvREADONLY(sv); - char *s; - STRLEN len; + HEK *hek; + U32 hash; + char *s; + STRLEN len; + if (kid->op_type == OP_CONST) { + SV * const sv = kid->op_sv; + U32 const was_readonly = SvREADONLY(sv); + if (kid->op_private & OPpCONST_BARE) { + dVAR; const char *end; if (was_readonly) { @@ -9702,7 +10203,33 @@ Perl_ck_require(pTHX_ OP *o) } SvEND_set(sv, end); sv_catpvs(sv, ".pm"); + PERL_HASH(hash, SvPVX(sv), SvCUR(sv)); + hek = share_hek(SvPVX(sv), + (SSize_t)SvCUR(sv) * (SvUTF8(sv) ? -1 : 1), + hash); + sv_sethek(sv, hek); + unshare_hek(hek); SvFLAGS(sv) |= was_readonly; + } + else if (SvPOK(sv) && !SvNIOK(sv) && !SvGMAGICAL(sv)) { + s = SvPV(sv, len); + if (SvREFCNT(sv) > 1) { + kid->op_sv = newSVpvn_share( + s, SvUTF8(sv) ? -(SSize_t)len : (SSize_t)len, 0); + SvREFCNT_dec_NN(sv); + } + else { + dVAR; + if (was_readonly) SvREADONLY_off(sv); + PERL_HASH(hash, s, len); + hek = share_hek(s, + SvUTF8(sv) ? -(SSize_t)len : (SSize_t)len, + hash); + sv_sethek(sv, hek); + unshare_hek(hek); + SvFLAGS(sv) |= was_readonly; + } + } } } @@ -9830,6 +10357,33 @@ Perl_ck_sort(pTHX_ OP *o) kid->op_next = kid; o->op_flags |= OPf_SPECIAL; } + else if (kid->op_type == OP_CONST + && kid->op_private & OPpCONST_BARE) { + char tmpbuf[256]; + STRLEN len; + PADOFFSET off; + const char * const name = SvPV(kSVOP_sv, len); + *tmpbuf = '&'; + assert (len < 256); + Copy(name, tmpbuf+1, len, char); + off = pad_findmy_pvn(tmpbuf, len+1, SvUTF8(kSVOP_sv)); + if (off != NOT_IN_PAD) { + if (PAD_COMPNAME_FLAGS_isOUR(off)) { + SV * const fq = + newSVhek(HvNAME_HEK(PAD_COMPNAME_OURSTASH(off))); + sv_catpvs(fq, "::"); + sv_catsv(fq, kSVOP_sv); + SvREFCNT_dec_NN(kSVOP_sv); + kSVOP->op_sv = fq; + } + else { + OP * const padop = newOP(OP_PADCV, 0); + padop->op_targ = off; + cUNOPx(firstkid)->op_first = padop; + op_free(kid); + } + } + } firstkid = OP_SIBLING(firstkid); } @@ -10102,7 +10656,7 @@ Perl_rv2cv_op_cv(pTHX_ OP *cvop, U32 flags) CV *cv; GV *gv; PERL_ARGS_ASSERT_RV2CV_OP_CV; - if (flags & ~(RV2CVOPCV_MARK_EARLY|RV2CVOPCV_RETURN_NAME_GV)) + if (flags & ~RV2CVOPCV_FLAG_MASK) Perl_croak(aTHX_ "panic: rv2cv_op_cv bad flags %x", (unsigned)flags); if (cvop->op_type != OP_RV2CV) return NULL; @@ -10114,6 +10668,16 @@ Perl_rv2cv_op_cv(pTHX_ OP *cvop, U32 flags) switch (rvop->op_type) { case OP_GV: { gv = cGVOPx_gv(rvop); + if (!isGV(gv)) { + if (SvROK(gv) && SvTYPE(SvRV(gv)) == SVt_PVCV) { + cv = MUTABLE_CV(SvRV(gv)); + gv = NULL; + break; + } + if (flags & RV2CVOPCV_RETURN_STUB) + return (CV *)gv; + else return NULL; + } cv = GvCVu(gv); if (!cv) { if (flags & RV2CVOPCV_MARK_EARLY) @@ -10138,8 +10702,9 @@ Perl_rv2cv_op_cv(pTHX_ OP *cvop, U32 flags) } if (SvTYPE((SV*)cv) != SVt_PVCV) return NULL; - if (flags & RV2CVOPCV_RETURN_NAME_GV) { - if (!CvANON(cv) || !gv) + if (flags & (RV2CVOPCV_RETURN_NAME_GV|RV2CVOPCV_MAYBE_NAME_GV)) { + if ((!CvANON(cv) || !gv) && !CvLEXICAL(cv) + && ((flags & RV2CVOPCV_RETURN_NAME_GV) || !CvNAMED(cv))) gv = CvGV(cv); return (CV*)gv; } else { @@ -10235,7 +10800,12 @@ Perl_ck_entersub_args_proto(pTHX_ OP *entersubop, GV *namegv, SV *protosv) OP* o3 = aop; if (proto >= proto_end) - return too_many_arguments_sv(entersubop, gv_ename(namegv), 0); + { + SV * const namesv = cv_name((CV *)namegv, NULL, 0); + yyerror_pv(Perl_form(aTHX_ "Too many arguments for %"SVf, + SVfARG(namesv)), SvUTF8(namesv)); + return entersubop; + } switch (*proto) { case ';': @@ -10260,7 +10830,8 @@ Perl_ck_entersub_args_proto(pTHX_ OP *entersubop, GV *namegv, SV *protosv) case '&': proto++; arg++; - if (o3->op_type != OP_REFGEN && o3->op_type != OP_UNDEF) + if (o3->op_type != OP_REFGEN && o3->op_type != OP_SREFGEN + && o3->op_type != OP_UNDEF) bad_type_gv(arg, arg == 1 ? "block or sub {}" : "sub {}", namegv, 0, o3); @@ -10273,32 +10844,6 @@ Perl_ck_entersub_args_proto(pTHX_ OP *entersubop, GV *namegv, SV *protosv) goto wrapref; /* autoconvert GLOB -> GLOBref */ else if (o3->op_type == OP_CONST) o3->op_private &= ~OPpCONST_STRICT; - else if (o3->op_type == OP_ENTERSUB) { - /* accidental subroutine, revert to bareword */ - OP *gvop = ((UNOP*)o3)->op_first; - if (gvop && gvop->op_type == OP_NULL) { - gvop = ((UNOP*)gvop)->op_first; - if (gvop) { - for (; OP_HAS_SIBLING(gvop); gvop = OP_SIBLING(gvop)) - ; - if (gvop && - (gvop->op_private & OPpENTERSUB_NOPAREN) && - (gvop = ((UNOP*)gvop)->op_first) && - gvop->op_type == OP_GV) - { - OP * newop; - GV * const gv = cGVOPx_gv(gvop); - SV * const n = newSVpvs(""); - gv_fullname4(n, gv, "", FALSE); - /* replace the aop subtree with a const op */ - newop = newSVOP(OP_CONST, 0, n); - op_sibling_splice(parent, prev, 1, newop); - op_free(aop); - aop = newop; - } - } - } - } scalar(aop); break; case '+': @@ -10411,10 +10956,9 @@ Perl_ck_entersub_args_proto(pTHX_ OP *entersubop, GV *namegv, SV *protosv) continue; default: oops: { - SV* const tmpsv = sv_newmortal(); - gv_efullname3(tmpsv, namegv, NULL); Perl_croak(aTHX_ "Malformed prototype for %"SVf": %"SVf, - SVfARG(tmpsv), SVfARG(protosv)); + SVfARG(cv_name((CV *)namegv, NULL, 0)), + SVfARG(protosv)); } } @@ -10428,7 +10972,11 @@ Perl_ck_entersub_args_proto(pTHX_ OP *entersubop, GV *namegv, SV *protosv) } if (!optional && proto_end > proto && (*proto != '@' && *proto != '%' && *proto != ';' && *proto != '_')) - return too_few_arguments_sv(entersubop, gv_ename(namegv), 0); + { + SV * const namesv = cv_name((CV *)namegv, NULL, 0); + yyerror_pv(Perl_form(aTHX_ "Not enough arguments for %"SVf, + SVfARG(namesv)), SvUTF8(namesv)); + } return entersubop; } @@ -10596,24 +11144,33 @@ by L. =cut */ -void -Perl_cv_get_call_checker(pTHX_ CV *cv, Perl_call_checker *ckfun_p, SV **ckobj_p) +static void +S_cv_get_call_checker(CV *cv, Perl_call_checker *ckfun_p, SV **ckobj_p, + U8 *flagsp) { MAGIC *callmg; - PERL_ARGS_ASSERT_CV_GET_CALL_CHECKER; - PERL_UNUSED_CONTEXT; callmg = SvMAGICAL((SV*)cv) ? mg_find((SV*)cv, PERL_MAGIC_checkcall) : NULL; if (callmg) { *ckfun_p = DPTR2FPTR(Perl_call_checker, callmg->mg_ptr); *ckobj_p = callmg->mg_obj; + if (flagsp) *flagsp = callmg->mg_flags; } else { *ckfun_p = Perl_ck_entersub_args_proto_or_list; *ckobj_p = (SV*)cv; + if (flagsp) *flagsp = 0; } } +void +Perl_cv_get_call_checker(pTHX_ CV *cv, Perl_call_checker *ckfun_p, SV **ckobj_p) +{ + PERL_ARGS_ASSERT_CV_GET_CALL_CHECKER; + PERL_UNUSED_CONTEXT; + S_cv_get_call_checker(cv, ckfun_p, ckobj_p, NULL); +} + /* -=for apidoc Am|void|cv_set_call_checker|CV *cv|Perl_call_checker ckfun|SV *ckobj +=for apidoc Am|void|cv_set_call_checker_flags|CV *cv|Perl_call_checker ckfun|SV *ckobj|U32 flags Sets the function that will be used to fix up a call to I. Specifically, the function is applied to an C op tree for a @@ -10630,15 +11187,25 @@ It is intended to be called in this manner: entersubop = ckfun(aTHX_ entersubop, namegv, ckobj); In this call, I is a pointer to the C op, -which may be replaced by the check function, and I is a GV -supplying the name that should be used by the check function to refer +which may be replaced by the check function, and I supplies +the name that should be used by the check function to refer to the callee of the C op if it needs to emit any diagnostics. It is permitted to apply the check function in non-standard situations, such as to a call to a different subroutine or to a method call. +I may not actually be a GV. For efficiency, perl may pass a +CV or other SV instead. Whatever is passed can be used as the first +argument to L. You can force perl to pass a GV by including +C in the I. + The current setting for a particular CV can be retrieved by L. +=for apidoc Am|void|cv_set_call_checker|CV *cv|Perl_call_checker ckfun|SV *ckobj + +The original form of L, which passes it the +C flag for backward-compatibility. + =cut */ @@ -10646,6 +11213,14 @@ void Perl_cv_set_call_checker(pTHX_ CV *cv, Perl_call_checker ckfun, SV *ckobj) { PERL_ARGS_ASSERT_CV_SET_CALL_CHECKER; + cv_set_call_checker_flags(cv, ckfun, ckobj, CALL_CHECKER_REQUIRE_GV); +} + +void +Perl_cv_set_call_checker_flags(pTHX_ CV *cv, Perl_call_checker ckfun, + SV *ckobj, U32 flags) +{ + PERL_ARGS_ASSERT_CV_SET_CALL_CHECKER_FLAGS; if (ckfun == Perl_ck_entersub_args_proto_or_list && ckobj == (SV*)cv) { if (SvMAGICAL((SV*)cv)) mg_free_type((SV*)cv, PERL_MAGIC_checkcall); @@ -10664,7 +11239,8 @@ Perl_cv_set_call_checker(pTHX_ CV *cv, Perl_call_checker ckfun, SV *ckobj) SvREFCNT_inc_simple_void_NN(ckobj); callmg->mg_flags |= MGf_REFCOUNTED; } - callmg->mg_flags |= MGf_COPY; + callmg->mg_flags = (callmg->mg_flags &~ MGf_REQUIRE_GV) + | (U8)(flags & MGf_REQUIRE_GV) | MGf_COPY; } } @@ -10683,7 +11259,7 @@ Perl_ck_subr(pTHX_ OP *o) aop = OP_SIBLING(aop); for (cvop = aop; OP_HAS_SIBLING(cvop); cvop = OP_SIBLING(cvop)) ; cv = rv2cv_op_cv(cvop, RV2CVOPCV_MARK_EARLY); - namegv = cv ? (GV*)rv2cv_op_cv(cvop, RV2CVOPCV_RETURN_NAME_GV) : NULL; + namegv = cv ? (GV*)rv2cv_op_cv(cvop, RV2CVOPCV_MAYBE_NAME_GV) : NULL; o->op_private &= ~1; o->op_private |= OPpENTERSUB_HASTARG; @@ -10708,21 +11284,24 @@ Perl_ck_subr(pTHX_ OP *o) } else { Perl_call_checker ckfun; SV *ckobj; - cv_get_call_checker(cv, &ckfun, &ckobj); - if (!namegv) { /* expletive! */ - /* XXX The call checker API is public. And it guarantees that - a GV will be provided with the right name. So we have - to create a GV. But it is still not correct, as its - stringification will include the package. What we - really need is a new call checker API that accepts a - GV or string (or GV or CV). */ - HEK * const hek = CvNAME_HEK(cv); + U8 flags; + S_cv_get_call_checker(cv, &ckfun, &ckobj, &flags); + if (!namegv) { + /* The original call checker API guarantees that a GV will be + be provided with the right name. So, if the old API was + used (or the REQUIRE_GV flag was passed), we have to reify + the CV’s GV, unless this is an anonymous sub. This is not + ideal for lexical subs, as its stringification will include + the package. But it is the best we can do. */ + if (flags & MGf_REQUIRE_GV) { + if (!CvANON(cv) && (!CvNAMED(cv) || CvNAME_HEK(cv))) + namegv = CvGV(cv); + } + else namegv = MUTABLE_GV(cv); /* After a syntax error in a lexical sub, the cv that rv2cv_op_cv returns may be a nameless stub. */ - if (!hek) return ck_entersub_args_list(o);; - namegv = (GV *)sv_newmortal(); - gv_init_pvn(namegv, PL_curstash, HEK_KEY(hek), HEK_LEN(hek), - SVf_UTF8 * !!HEK_UTF8(hek)); + if (!namegv) return ck_entersub_args_list(o); + } return ckfun(aTHX_ o, namegv, ckobj); } @@ -11351,7 +11930,7 @@ Perl_rpeep(pTHX_ OP *o) OP *rv2av, *q; p = o->op_next; if ( p->op_type == OP_GV - && (gv = cGVOPx_gv(p)) + && (gv = cGVOPx_gv(p)) && isGV(gv) && GvNAMELEN_get(gv) == 1 && *GvNAME_get(gv) == '_' && GvSTASH(gv) == PL_defstash @@ -11765,7 +12344,9 @@ Perl_rpeep(pTHX_ OP *o) * altering the basic op_first/op_sibling layout. */ kid = kLISTOP->op_first; assert( - (kid->op_type == OP_NULL && kid->op_targ == OP_NEXTSTATE) + (kid->op_type == OP_NULL + && ( kid->op_targ == OP_NEXTSTATE + || kid->op_targ == OP_DBSTATE )) || kid->op_type == OP_STUB || kid->op_type == OP_ENTER); nullop->op_next = kLISTOP->op_next; @@ -11955,6 +12536,21 @@ Perl_rpeep(pTHX_ OP *o) } break; + case OP_AASSIGN: + /* We do the common-vars check here, rather than in newASSIGNOP + (as formerly), so that all lexical vars that get aliased are + marked as such before we do the check. */ + if (o->op_private & OPpASSIGN_COMMON) { + /* See the comment before S_aassign_common_vars concerning + PL_generation sorcery. */ + PL_generation++; + if (!aassign_common_vars(o)) + o->op_private &=~ OPpASSIGN_COMMON; + } + else if (S_aassign_common_vars_aliases_only(aTHX_ o)) + o->op_private |= OPpASSIGN_COMMON; + break; + case OP_CUSTOM: { Perl_cpeep_t cpeep = XopENTRYCUSTOM(o, xop_peep);