+ PADNAME *name;
+ PADOFFSET pax = o->op_targ;
+ CV *outcv = CvOUTSIDE(PL_compcv);
+ CV *clonee = NULL;
+ HEK *hek = NULL;
+ bool reusable = FALSE;
+
+ PERL_ARGS_ASSERT_NEWMYSUB;
+
+ /* Find the pad slot for storing the new sub.
+ We cannot use PL_comppad, as it is the pad owned by the new sub. We
+ need to look in CvOUTSIDE and find the pad belonging to the enclos-
+ ing sub. And then we need to dig deeper if this is a lexical from
+ outside, as in:
+ my sub foo; sub { sub foo { } }
+ */
+ redo:
+ name = PadlistNAMESARRAY(CvPADLIST(outcv))[pax];
+ if (PadnameOUTER(name) && PARENT_PAD_INDEX(name)) {
+ pax = PARENT_PAD_INDEX(name);
+ outcv = CvOUTSIDE(outcv);
+ assert(outcv);
+ goto redo;
+ }
+ svspot =
+ &PadARRAY(PadlistARRAY(CvPADLIST(outcv))
+ [CvDEPTH(outcv) ? CvDEPTH(outcv) : 1])[pax];
+ spot = (CV **)svspot;
+
+ if (proto) {
+ assert(proto->op_type == OP_CONST);
+ ps = SvPV_const(((SVOP*)proto)->op_sv, ps_len);
+ ps_utf8 = SvUTF8(((SVOP*)proto)->op_sv);
+ }
+ else
+ ps = NULL;
+
+ if (!PL_madskills) {
+ if (proto)
+ SAVEFREEOP(proto);
+ if (attrs)
+ SAVEFREEOP(attrs);
+ }
+
+ if (PL_parser && PL_parser->error_count) {
+ op_free(block);
+ goto done;
+ }
+
+ if (CvDEPTH(outcv) && CvCLONE(compcv)) {
+ cv = *spot;
+ svspot = (SV **)(spot = &clonee);
+ }
+ else if (PadnameIsSTATE(name) || CvDEPTH(outcv))
+ cv = *spot;
+ else {
+ MAGIC *mg;
+ SvUPGRADE(name, SVt_PVMG);
+ mg = mg_find(name, PERL_MAGIC_proto);
+ assert (SvTYPE(*spot) == SVt_PVCV);
+ if (CvNAMED(*spot))
+ hek = CvNAME_HEK(*spot);
+ else {
+ CvNAME_HEK_set(*spot, hek =
+ share_hek(
+ PadnamePV(name)+1,
+ PadnameLEN(name)-1 * (PadnameUTF8(name) ? -1 : 1), 0
+ )
+ );
+ }
+ if (mg) {
+ assert(mg->mg_obj);
+ cv = (CV *)mg->mg_obj;
+ }
+ else {
+ sv_magic(name, &PL_sv_undef, PERL_MAGIC_proto, NULL, 0);
+ mg = mg_find(name, PERL_MAGIC_proto);
+ }
+ spot = (CV **)(svspot = &mg->mg_obj);
+ }
+
+ if (!block || !ps || *ps || attrs
+ || (CvFLAGS(compcv) & CVf_BUILTIN_ATTRS)
+#ifdef PERL_MAD
+ || block->op_type == OP_NULL
+#endif
+ )
+ const_sv = NULL;
+ else
+ const_sv = op_const_sv(block, NULL);
+
+ if (cv) {
+ const bool exists = CvROOT(cv) || CvXSUB(cv);
+
+ /* if the subroutine doesn't exist and wasn't pre-declared
+ * with a prototype, assume it will be AUTOLOADed,
+ * skipping the prototype check
+ */
+ if (exists || SvPOK(cv))
+ cv_ckproto_len_flags(cv, (GV *)name, ps, ps_len, ps_utf8);
+ /* already defined? */
+ if (exists) {
+ if ((!block
+#ifdef PERL_MAD
+ || block->op_type == OP_NULL
+#endif
+ )) {
+ if (CvFLAGS(compcv)) {
+ /* might have had built-in attrs applied */
+ const bool pureperl = !CvISXSUB(cv) && CvROOT(cv);
+ if (CvLVALUE(compcv) && ! CvLVALUE(cv) && pureperl
+ && ckWARN(WARN_MISC))
+ Perl_warner(aTHX_ packWARN(WARN_MISC), "lvalue attribute ignored after the subroutine has been defined");
+ CvFLAGS(cv) |=
+ (CvFLAGS(compcv) & CVf_BUILTIN_ATTRS
+ & ~(CVf_LVALUE * pureperl));
+ }
+ if (attrs) goto attrs;
+ /* just a "sub foo;" when &foo is already defined */
+ SAVEFREESV(compcv);
+ goto done;
+ }
+ else {
+ /* redundant check that avoids creating the extra SV
+ most of the time: */
+ if (const_sv || ckWARN(WARN_REDEFINE)) {
+ const line_t oldline = CopLINE(PL_curcop);
+ SV *noamp = sv_2mortal(newSVpvn_utf8(
+ PadnamePV(name)+1,PadnameLEN(name)-1,
+ PadnameUTF8(name)
+ ));
+ if (PL_parser && PL_parser->copline != NOLINE)
+ CopLINE_set(PL_curcop, PL_parser->copline);
+ report_redefined_cv(noamp, cv, &const_sv);
+ CopLINE_set(PL_curcop, oldline);
+ }
+#ifdef PERL_MAD
+ if (!PL_minus_c) /* keep old one around for madskills */
+#endif
+ {
+ /* (PL_madskills unset in used file.) */
+ SvREFCNT_dec(cv);
+ }
+ cv = NULL;
+ }
+ }
+ else if (CvDEPTH(outcv) && CvCLONE(compcv)) {
+ cv = NULL;
+ reusable = TRUE;
+ }
+ }
+ if (const_sv) {
+ SvREFCNT_inc_simple_void_NN(const_sv);
+ if (cv) {
+ assert(!CvROOT(cv) && !CvCONST(cv));
+ cv_forget_slab(cv);
+ }
+ else {
+ cv = MUTABLE_CV(newSV_type(SVt_PVCV));
+ CvFILE_set_from_cop(cv, PL_curcop);
+ CvSTASH_set(cv, PL_curstash);
+ *spot = cv;
+ }
+ sv_setpvs(MUTABLE_SV(cv), ""); /* prototype is "" */
+ CvXSUBANY(cv).any_ptr = const_sv;
+ CvXSUB(cv) = const_sv_xsub;
+ CvCONST_on(cv);
+ CvISXSUB_on(cv);
+ if (PL_madskills)
+ goto install_block;
+ op_free(block);
+ SvREFCNT_dec(compcv);
+ PL_compcv = NULL;
+ goto clone;
+ }
+ /* Checking whether outcv is CvOUTSIDE(compcv) is not sufficient to
+ determine whether this sub definition is in the same scope as its
+ declaration. If this sub definition is inside an inner named pack-
+ age sub (my sub foo; sub bar { sub foo { ... } }), outcv points to
+ the package sub. So check PadnameOUTER(name) too.
+ */
+ if (outcv == CvOUTSIDE(compcv) && !PadnameOUTER(name)) {
+ assert(!CvWEAKOUTSIDE(compcv));
+ SvREFCNT_dec(CvOUTSIDE(compcv));
+ CvWEAKOUTSIDE_on(compcv);
+ }
+ /* XXX else do we have a circular reference? */
+ if (cv) { /* must reuse cv in case stub is referenced elsewhere */
+ /* transfer PL_compcv to cv */
+ if (block
+#ifdef PERL_MAD
+ && block->op_type != OP_NULL
+#endif
+ ) {
+ cv_flags_t preserved_flags =
+ CvFLAGS(cv) & (CVf_BUILTIN_ATTRS|CVf_NAMED);
+ PADLIST *const temp_padl = CvPADLIST(cv);
+ CV *const temp_cv = CvOUTSIDE(cv);
+ const cv_flags_t other_flags =
+ CvFLAGS(cv) & (CVf_SLABBED|CVf_WEAKOUTSIDE);
+ OP * const cvstart = CvSTART(cv);
+
+ SvPOK_off(cv);
+ CvFLAGS(cv) =
+ CvFLAGS(compcv) | preserved_flags;
+ CvOUTSIDE(cv) = CvOUTSIDE(compcv);
+ CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(compcv);
+ CvPADLIST(cv) = CvPADLIST(compcv);
+ CvOUTSIDE(compcv) = temp_cv;
+ CvPADLIST(compcv) = temp_padl;
+ CvSTART(cv) = CvSTART(compcv);
+ CvSTART(compcv) = cvstart;
+ CvFLAGS(compcv) &= ~(CVf_SLABBED|CVf_WEAKOUTSIDE);
+ CvFLAGS(compcv) |= other_flags;
+
+ if (CvFILE(cv) && CvDYNFILE(cv)) {
+ Safefree(CvFILE(cv));
+ }
+
+ /* inner references to compcv must be fixed up ... */
+ pad_fixup_inner_anons(CvPADLIST(cv), compcv, cv);
+ if (PERLDB_INTER)/* Advice debugger on the new sub. */
+ ++PL_sub_generation;
+ }
+ else {
+ /* Might have had built-in attributes applied -- propagate them. */
+ CvFLAGS(cv) |= (CvFLAGS(compcv) & CVf_BUILTIN_ATTRS);
+ }
+ /* ... before we throw it away */
+ SvREFCNT_dec(compcv);
+ PL_compcv = compcv = cv;
+ }
+ else {
+ cv = compcv;
+ *spot = cv;
+ }
+ if (!CvNAME_HEK(cv)) {
+ CvNAME_HEK_set(cv,
+ hek
+ ? share_hek_hek(hek)
+ : share_hek(PadnamePV(name)+1,
+ PadnameLEN(name)-1 * (PadnameUTF8(name) ? -1 : 1),
+ 0)
+ );
+ }
+ CvFILE_set_from_cop(cv, PL_curcop);
+ CvSTASH_set(cv, PL_curstash);
+
+ if (ps) {
+ sv_setpvn(MUTABLE_SV(cv), ps, ps_len);
+ if ( ps_utf8 ) SvUTF8_on(MUTABLE_SV(cv));
+ }
+
+ install_block:
+ if (!block)
+ goto attrs;
+
+ /* If we assign an optree to a PVCV, then we've defined a subroutine that
+ the debugger could be able to set a breakpoint in, so signal to
+ pp_entereval that it should not throw away any saved lines at scope
+ exit. */
+
+ PL_breakable_sub_gen++;
+ /* This makes sub {}; work as expected. */
+ if (block->op_type == OP_STUB) {
+ OP* const newblock = newSTATEOP(0, NULL, 0);
+#ifdef PERL_MAD
+ op_getmad(block,newblock,'B');
+#else
+ op_free(block);
+#endif
+ block = newblock;
+ }
+ CvROOT(cv) = CvLVALUE(cv)
+ ? newUNOP(OP_LEAVESUBLV, 0,
+ op_lvalue(scalarseq(block), OP_LEAVESUBLV))
+ : newUNOP(OP_LEAVESUB, 0, scalarseq(block));
+ CvROOT(cv)->op_private |= OPpREFCOUNTED;
+ OpREFCNT_set(CvROOT(cv), 1);
+ /* The cv no longer needs to hold a refcount on the slab, as CvROOT
+ itself has a refcount. */
+ CvSLABBED_off(cv);
+ OpslabREFCNT_dec_padok((OPSLAB *)CvSTART(cv));
+ CvSTART(cv) = LINKLIST(CvROOT(cv));
+ CvROOT(cv)->op_next = 0;
+ CALL_PEEP(CvSTART(cv));
+ finalize_optree(CvROOT(cv));
+
+ /* now that optimizer has done its work, adjust pad values */
+
+ pad_tidy(CvCLONE(cv) ? padtidy_SUBCLONE : padtidy_SUB);
+
+ if (CvCLONE(cv)) {
+ assert(!CvCONST(cv));
+ if (ps && !*ps && op_const_sv(block, cv))
+ CvCONST_on(cv);
+ }
+
+ attrs:
+ if (attrs) {
+ /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>. */
+ apply_attrs(PL_curstash, MUTABLE_SV(cv), attrs);
+ }
+
+ if (block) {
+ if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
+ SV * const tmpstr = sv_newmortal();
+ GV * const db_postponed = gv_fetchpvs("DB::postponed",
+ GV_ADDMULTI, SVt_PVHV);
+ HV *hv;
+ SV * const sv = Perl_newSVpvf(aTHX_ "%s:%ld-%ld",
+ CopFILE(PL_curcop),
+ (long)PL_subline,
+ (long)CopLINE(PL_curcop));
+ if (HvNAME_HEK(PL_curstash)) {
+ sv_sethek(tmpstr, HvNAME_HEK(PL_curstash));
+ sv_catpvs(tmpstr, "::");
+ }
+ else sv_setpvs(tmpstr, "__ANON__::");
+ sv_catpvn_flags(tmpstr, PadnamePV(name)+1, PadnameLEN(name)-1,
+ PadnameUTF8(name) ? SV_CATUTF8 : SV_CATBYTES);
+ (void)hv_store(GvHV(PL_DBsub), SvPVX_const(tmpstr),
+ SvUTF8(tmpstr) ? -(I32)SvCUR(tmpstr) : (I32)SvCUR(tmpstr), sv, 0);
+ hv = GvHVn(db_postponed);
+ if (HvTOTALKEYS(hv) > 0 && hv_exists(hv, SvPVX_const(tmpstr), SvUTF8(tmpstr) ? -(I32)SvCUR(tmpstr) : (I32)SvCUR(tmpstr))) {
+ CV * const pcv = GvCV(db_postponed);
+ if (pcv) {
+ dSP;
+ PUSHMARK(SP);
+ XPUSHs(tmpstr);
+ PUTBACK;
+ call_sv(MUTABLE_SV(pcv), G_DISCARD);
+ }
+ }
+ }
+ }
+
+ clone:
+ if (clonee) {
+ assert(CvDEPTH(outcv));
+ spot = (CV **)
+ &PadARRAY(PadlistARRAY(CvPADLIST(outcv))[CvDEPTH(outcv)])[pax];
+ if (reusable) cv_clone_into(clonee, *spot);
+ else *spot = cv_clone(clonee);
+ SvREFCNT_dec(clonee);
+ cv = *spot;
+ SvPADMY_on(cv);
+ }
+ if (CvDEPTH(outcv) && !reusable && PadnameIsSTATE(name)) {
+ PADOFFSET depth = CvDEPTH(outcv);
+ while (--depth) {
+ SV *oldcv;
+ svspot = &PadARRAY(PadlistARRAY(CvPADLIST(outcv))[depth])[pax];
+ oldcv = *svspot;
+ *svspot = SvREFCNT_inc_simple_NN(cv);
+ SvREFCNT_dec(oldcv);
+ }
+ }
+
+ done:
+ if (PL_parser)
+ PL_parser->copline = NOLINE;
+ LEAVE_SCOPE(floor);
+ if (o) op_free(o);
+ return cv;
+}
+
+CV *
+Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
+{
+ return newATTRSUB_flags(floor, o, proto, attrs, block, 0);
+}
+
+CV *
+Perl_newATTRSUB_flags(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs,
+ OP *block, U32 flags)
+{
+ dVAR;
+ GV *gv;
+ const char *ps;
+ STRLEN ps_len = 0; /* init it to avoid false uninit warning from icc */
+ U32 ps_utf8 = 0;
+ CV *cv = NULL;
+ SV *const_sv;
+ const bool ec = PL_parser && PL_parser->error_count;
+ /* 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
+ store it. */