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)
{
}
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;
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)
{
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)",
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 $<special_var>" etc etc */
if (len &&
!(is_our ||
((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\"",
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
)
);
void
Perl_op_free(pTHX_ OP *o)
{
-#ifdef USE_ITHREADS
dVAR;
-#endif
OPCODE type;
/* Though ops may be freed twice, freeing the op after its slab is a
/* 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_ppaddr == PL_ppaddr[o->op_type]) {
+ assert(!(o->op_private & ~PL_op_private_valid[type]));
+ }
if (o->op_private & OPpREFCOUNTED) {
switch (type) {
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;
}
}
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);
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
=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.
/*
=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.
case OP_SPLIT:
kid = cLISTOPo->op_first;
if (kid && kid->op_type == OP_PUSHRE
+ && !kid->op_targ
+ && !(o->op_flags & OPf_STACKED)
#ifdef USE_ITHREADS
&& !((PMOP*)kid)->op_pmreplrootu.op_pmtargetoff)
#else
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)
/* 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("");
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;
|| 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;
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)
{
/* 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;
|| 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
return 0;
}
+static void
+S_lvref(pTHX_ OP *o, I32 type)
+{
+ dVAR;
+ 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) {
+ 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:
+ 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 reference to %s in %s assignment */
+ 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)
{
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;
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)
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))
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;
|| !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_REFALIASING_IS_ENABLED)
+ Perl_croak(aTHX_
+ "Experimental aliasing via reference not enabled");
+ Perl_ck_warner_d(aTHX_
+ packWARN(WARN_EXPERIMENTAL__REFALIASING),
+ "Aliasing via reference is 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
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);
OP * VOL curop;
OP *newop;
VOL I32 type = o->op_type;
+ bool folded;
SV * VOL sv = NULL;
int ret = 0;
I32 oldscope;
if (ret)
goto nope;
+ folded = cBOOL(o->op_folded);
op_free(o);
assert(sv);
if (type == OP_STRINGIFY) SvPADTMP_off(sv);
else
{
newop = newSVOP(OP_CONST, 0, MUTABLE_SV(sv));
- if (type != OP_STRINGIFY) newop->op_folded = 1;
+ /* OP_STRINGIFY and constant folding are used to implement qq.
+ Here the constant folding is an implementation detail that we
+ want to hide. If the stringify op is itself already marked
+ folded, however, then it is actually a folded join. */
+ if (type != OP_STRINGIFY || folded) newop->op_folded = 1;
}
return newop;
}
/*
+=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<type> is the opcode. I<flags> gives the eight
+bits of C<op_flags>, except that C<OPf_KIDS> will be set automatically,
+and, shifted up eight bits, the eight bits of C<op_private>, except that
+the bit with value 1 is automatically set. I<dynamic_meth> 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<type> is the opcode. I<flags> gives the eight bits of
+C<op_flags>, and, shifted up eight bits, the eight bits of
+C<op_private>. I<const_meth> 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<type>
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)));
}
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)
padop->op_type = (OPCODE)type;
padop->op_ppaddr = PL_ppaddr[type];
padop->op_padix =
- pad_alloc(type, IS_PADGV(sv) ? SVf_READONLY : SVs_PADTMP);
+ pad_alloc(type, isGV(sv) ? SVf_READONLY : SVs_PADTMP);
SvREFCNT_dec(PAD_SVl(padop->op_padix));
PAD_SETSV(padop->op_padix, sv);
assert(sv);
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));
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)));
}
}
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. */
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;
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)
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
+ || curop->op_type == OP_AELEMFAST) {
GV *gv = cGVOPx_gv(curop);
if (gv == PL_defgv
|| (int)GvASSIGN_GENERATION(gv) == PL_generation)
else if (curop->op_type == OP_PADSV ||
curop->op_type == OP_PADAV ||
curop->op_type == OP_PADHV ||
+ curop->op_type == OP_AELEMFAST_LEX ||
curop->op_type == OP_PADANY)
{
+ padcheck:
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);
return TRUE;
GvASSIGN_GENERATION_set(gv, PL_generation);
}
+ else if (curop->op_targ)
+ goto padcheck;
}
+ else if (curop->op_type == OP_PADRANGE)
+ /* Ignore padrange; checking its siblings is sufficient. */
+ continue;
else
return TRUE;
}
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_AELEMFAST_LEX ||
+ curop->op_type == OP_PADANY)
+ && PAD_COMPNAME_GEN(curop->op_targ) == PERL_INT_MAX)
+ return TRUE;
+
+ if (curop->op_type == OP_PUSHRE && curop->op_targ
+ && 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
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) {
}
}
- 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;
}
}
- /* 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) {
+ if (right && right->op_type == OP_SPLIT
+ && !(right->op_flags & OPf_STACKED)) {
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
+ PMOP * const pm = (PMOP*)tmpop;
+ assert (tmpop && (tmpop->op_type == OP_PUSHRE));
+ 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
+ && !pm->op_targ
+ ) {
+ if (!(left->op_private & OPpLVAL_INTRO) &&
+ ( (left->op_type == OP_RV2AV &&
+ (tmpop=((UNOP*)left)->op_first)->op_type==OP_GV)
+ || left->op_type == OP_PADAV )
) {
+ if (tmpop != (OP *)pm) {
#ifdef USE_ITHREADS
- pm->op_pmreplrootu.op_pmtargetoff
+ pm->op_pmreplrootu.op_pmtargetoff
= cPADOPx(tmpop)->op_padix;
- cPADOPx(tmpop)->op_padix = 0; /* steal it */
+ cPADOPx(tmpop)->op_padix = 0; /* steal it */
#else
- pm->op_pmreplrootu.op_pmtargetgv
+ pm->op_pmreplrootu.op_pmtargetgv
= MUTABLE_GV(cSVOPx(tmpop)->op_sv);
- cSVOPx(tmpop)->op_sv = NULL; /* steal it */
+ cSVOPx(tmpop)->op_sv = NULL; /* steal it */
#endif
+ right->op_private |=
+ left->op_private & OPpOUR_INTRO;
+ }
+ else {
+ pm->op_targ = left->op_targ;
+ left->op_targ = 0; /* filch it */
+ }
+ detach_split:
tmpop = cUNOPo->op_first; /* to list (nulled) */
tmpop = ((UNOP*)tmpop)->op_first; /* to pushmark */
/* 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 */
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 (left->op_type == OP_RV2AV
+ || left->op_type == OP_PADAV)
+ {
+ /* Detach the array. */
+#ifdef DEBUGGING
+ OP * const ary =
+#endif
+ op_sibling_splice(cBINOPo->op_last,
+ cUNOPx(cBINOPo->op_last)
+ ->op_first, 1, NULL);
+ assert(ary == left);
+ /* Attach it to the split. */
+ op_sibling_splice(right, cLISTOPx(right)->op_last,
+ 0, left);
+ right->op_flags |= OPf_STACKED;
+ /* Detach split and expunge aassign as above. */
+ goto detach_split;
+ }
+ 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;
}
}
}
- }
}
}
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) {
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;
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) {
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;
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:");
}
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);
else *spot = cv_clone(clonee);
SvREFCNT_dec_NN(clonee);
cv = *spot;
- SvPADMY_on(cv);
}
if (CvDEPTH(outcv) && !reusable && PadnameIsSTATE(name)) {
PADOFFSET depth = CvDEPTH(outcv);
/* 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 :
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) {
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();
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);
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,
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)
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);
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 {
}
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);
CvISXSUB_on(cv);
}
else {
- if (name) 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);
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);
}
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);
}
attrs:
if (attrs) {
/* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>. */
- 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);
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;
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);
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);
}
}
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;
}
|| (*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)
if (strEQ(name, "BEGIN")) {
const I32 oldscope = PL_scopestack_ix;
dSP;
+ (void)CvGV(cv);
if (floor) LEAVE_SCOPE(floor);
ENTER;
PUSHSTACKi(PERLSI_REQUIRE);
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)
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)
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;
}
}
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 */
if (kid->op_type == OP_CONST) {
int iscv;
- const int noexpand = o->op_type == OP_RV2CV
- && o->op_private & OPpMAY_RETURN_CONSTANT
- ? GV_NOEXPAND
- : 0;
GV *gv;
SV * const kidsv = kid->op_sv;
* 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;
+ iscv = o->op_type == OP_RV2CV ? GV_NOEXPAND|GV_ADDMULTI : 0;
gv = gv_fetchsv(kidsv,
- noexpand
- ? noexpand
+ o->op_type == OP_RV2CV
+ && o->op_private & OPpMAY_RETURN_CONSTANT
+ ? GV_NOEXPAND
: iscv | !(kid->op_private & OPpCONST_ENTERED),
iscv
? SVt_PVCV
? SVt_PVHV
: SVt_PVGV);
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
assert (sizeof(PADOP) <= sizeof(SVOP));
kPADOP->op_padix = pad_alloc(OP_GV, SVf_READONLY);
SvREFCNT_dec(PAD_SVl(kPADOP->op_padix));
- if (isGV(gv)) 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);
}
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;
}
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;
}
}
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;
}
}
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 reference to %s in %s assignment */
+ yyerror(Perl_form(aTHX_ "Can't modify reference to %s in scalar "
+ "assignment",
+ OP_DESC(varop)));
+ return o;
+ }
+ if (!FEATURE_REFALIASING_IS_ENABLED)
+ Perl_croak(aTHX_
+ "Experimental aliasing via reference not enabled");
+ Perl_ck_warner_d(aTHX_
+ packWARN(WARN_EXPERIMENTAL__REFALIASING),
+ "Aliasing via reference is 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;
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);
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);
}
}
OP *
+Perl_ck_stringify(pTHX_ OP *o)
+{
+ OP * const kid = OP_SIBLING(cUNOPo->op_first);
+ PERL_ARGS_ASSERT_CK_STRINGIFY;
+ if (kid->op_type == OP_JOIN) {
+ assert(!OP_HAS_SIBLING(kid));
+ op_sibling_splice(o, cUNOPo->op_first, -1, NULL);
+ op_free(o);
+ return kid;
+ }
+ return ck_fun(o);
+}
+
+OP *
Perl_ck_join(pTHX_ OP *o)
{
- const OP * const kid = OP_SIBLING(cLISTOPo->op_first);
+ OP * const kid = OP_SIBLING(cLISTOPo->op_first);
PERL_ARGS_ASSERT_CK_JOIN;
SVfARG(msg), SVfARG(msg));
}
}
+ if (kid->op_type == OP_CONST /* an innocent, unsuspicious separator */
+ || (kid->op_type == OP_PADSV && !(kid->op_private & OPpLVAL_INTRO))
+ || (kid->op_type==OP_RV2SV && kUNOP->op_first->op_type == OP_GV
+ && !(kid->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO))))
+ {
+ const OP * const bairn = OP_SIBLING(kid); /* the list */
+ if (bairn && !OP_HAS_SIBLING(bairn) /* single-item list */
+ && PL_opargs[bairn->op_type] & OA_RETSCALAR)
+ {
+ OP * const ret = convert(OP_STRINGIFY, 0,
+ op_sibling_splice(o, kid, 1, NULL));
+ op_free(o);
+ ret->op_folded = 1;
+ return ret;
+ }
+ }
+
return ck_fun(o);
}
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;
}
if (SvTYPE((SV*)cv) != SVt_PVCV)
return NULL;
- if (flags & RV2CVOPCV_RETURN_NAME_GV) {
- if ((!CvANON(cv) || !gv) && !CvLEXICAL(cv))
+ 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 {
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 ';':
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);
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));
}
}
}
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;
}
=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<cv>.
Specifically, the function is applied to an C<entersub> op tree for a
entersubop = ckfun(aTHX_ entersubop, namegv, ckobj);
In this call, I<entersubop> is a pointer to the C<entersub> op,
-which may be replaced by the check function, and I<namegv> 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<namegv> supplies
+the name that should be used by the check function to refer
to the callee of the C<entersub> 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<namegv> 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</cv_name>. You can force perl to pass a GV by including
+C<CALL_CHECKER_REQUIRE_GV> in the I<flags>.
+
The current setting for a particular CV can be retrieved by
L</cv_get_call_checker>.
+=for apidoc Am|void|cv_set_call_checker|CV *cv|Perl_call_checker ckfun|SV *ckobj
+
+The original form of L</cv_set_call_checker_flags>, which passes it the
+C<CALL_CHECKER_REQUIRE_GV> flag for backward-compatibility.
+
=cut
*/
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);
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;
}
}
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;
} 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);
}
STATIC void
S_null_listop_in_list_context(pTHX_ OP *o)
{
- OP *kid;
-
PERL_ARGS_ASSERT_NULL_LISTOP_IN_LIST_CONTEXT;
- /* This is an OP_LIST in list context. That means we
+ /* This is an OP_LIST in list (or void) context. That means we
* can ditch the OP_LIST and the OP_PUSHMARK within. */
- kid = cLISTOPo->op_first;
- /* Find the end of the chain of OPs executed within the OP_LIST. */
- while (kid->op_next != o)
- kid = kid->op_next;
-
- kid->op_next = o->op_next; /* patch list out of exec chain */
op_null(cUNOPo->op_first); /* NULL the pushmark */
op_null(o); /* NULL the list */
}
break;
}
+ redo:
/* By default, this op has now been optimised. A couple of cases below
clear this again. */
o->op_opt = 1;
/* The following will have the OP_LIST and OP_PUSHMARK
- * patched out later IF the OP_LIST is in list context.
+ * patched out later IF the OP_LIST is in list context, or
+ * if it is in void context and padrange is not possible.
* So in that case, we can set the this OP's op_next
* to skip to after the OP_PUSHMARK:
* a THIS -> b
{
OP *sibling;
OP *other_pushmark;
+ OP *pushsib;
if (OP_TYPE_IS(o->op_next, OP_PUSHMARK)
&& (sibling = OP_SIBLING(o))
&& sibling->op_type == OP_LIST
/* This KIDS check is likely superfluous since OP_LIST
* would otherwise be an OP_STUB. */
&& sibling->op_flags & OPf_KIDS
- && (sibling->op_flags & OPf_WANT) == OPf_WANT_LIST
&& (other_pushmark = cLISTOPx(sibling)->op_first)
/* Pointer equality also effectively checks that it's a
* pushmark. */
- && other_pushmark == o->op_next)
+ && other_pushmark == o->op_next
+ /* List context */
+ && ( (sibling->op_flags & OPf_WANT) == OPf_WANT_LIST
+ /* ... or void context... */
+ || ( (sibling->op_flags & OPf_WANT) == OPf_WANT_VOID
+ /* ...and something padrange would reject */
+ && ( !(pushsib = OP_SIBLING(other_pushmark))
+ || ( pushsib->op_type != OP_PADSV
+ && pushsib->op_type != OP_PADAV
+ && pushsib->op_type != OP_PADHV)
+ || pushsib->op_private & ~OPpLVAL_INTRO))
+ ))
{
o->op_next = other_pushmark->op_next;
null_listop_in_list_context(sibling);
nextop = nextop->op_next;
if (nextop && (nextop->op_type == OP_NEXTSTATE)) {
- COP *firstcop = (COP *)o;
- COP *secondcop = (COP *)nextop;
- /* We want the COP pointed to by o (and anything else) to
- become the next COP down the line. */
- cop_free(firstcop);
-
- firstcop->op_next = secondcop->op_next;
-
- /* Now steal all its pointers, and duplicate the other
- data. */
- firstcop->cop_line = secondcop->cop_line;
-#ifdef USE_ITHREADS
- firstcop->cop_stashoff = secondcop->cop_stashoff;
- firstcop->cop_file = secondcop->cop_file;
-#else
- firstcop->cop_stash = secondcop->cop_stash;
- firstcop->cop_filegv = secondcop->cop_filegv;
-#endif
- firstcop->cop_hints = secondcop->cop_hints;
- firstcop->cop_seq = secondcop->cop_seq;
- firstcop->cop_warnings = secondcop->cop_warnings;
- firstcop->cop_hints_hash = secondcop->cop_hints_hash;
-
-#ifdef USE_ITHREADS
- secondcop->cop_stashoff = 0;
- secondcop->cop_file = NULL;
-#else
- secondcop->cop_stash = NULL;
- secondcop->cop_filegv = NULL;
-#endif
- secondcop->cop_warnings = NULL;
- secondcop->cop_hints_hash = NULL;
-
- /* If we use op_null(), and hence leave an ex-COP, some
- warnings are misreported. For example, the compile-time
- error in 'use strict; no strict refs;' */
- secondcop->op_type = OP_NULL;
- secondcop->op_ppaddr = PL_ppaddr[OP_NULL];
+ op_null(o);
+ if (oldop)
+ oldop->op_next = nextop;
}
}
break;
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
followop = p->op_next;
}
- if (count < 1)
+ if (count < 1 || (count == 1 && !defav))
break;
/* pp_padrange in specifically compile-time void context
* padrange.
* In particular in void context, we can only optimise to
* a padrange if see see the complete sequence
- * pushmark, pad*v, ...., list, nextstate
- * which has the net effect of of leaving the stack empty
- * (for now we leave the nextstate in the execution chain, for
- * its other side-effects).
+ * pushmark, pad*v, ...., list
+ * which has the net effect of of leaving the markstack as it
+ * was. Not pushing on to the stack (whereas padsv does touch
+ * the stack) makes no difference in void context.
*/
assert(followop);
if (gimme == OPf_WANT_VOID) {
- if (OP_TYPE_IS_OR_WAS(followop, OP_LIST)
+ if (followop->op_type == OP_LIST
&& gimme == (followop->op_flags & OPf_WANT)
- && ( followop->op_next->op_type == OP_NEXTSTATE
- || followop->op_next->op_type == OP_DBSTATE))
+ )
{
followop = followop->op_next; /* skip OP_LIST */
else
o->op_type = OP_AELEMFAST_LEX;
}
- break;
+ if (o->op_type != OP_GV)
+ break;
}
- if (o->op_next->op_type == OP_RV2SV) {
+ /* Remove $foo from the op_next chain in void context. */
+ if (oldop
+ && ( o->op_next->op_type == OP_RV2SV
+ || o->op_next->op_type == OP_RV2AV
+ || o->op_next->op_type == OP_RV2HV )
+ && (o->op_next->op_flags & OPf_WANT) == OPf_WANT_VOID
+ && !(o->op_next->op_private & OPpLVAL_INTRO))
+ {
+ oldop->op_next = o->op_next->op_next;
+ /* Reprocess the previous op if it is a nextstate, to
+ allow double-nextstate optimisation. */
+ if (oldop->op_type == OP_NEXTSTATE) {
+ oldop->op_opt = 0;
+ o = oldop;
+ oldop = oldoldop;
+ oldoldop = NULL;
+ goto redo;
+ }
+ o = oldop;
+ }
+ else if (o->op_next->op_type == OP_RV2SV) {
if (!(o->op_next->op_private & OPpDEREF)) {
op_null(o->op_next);
o->op_private |= o->op_next->op_private & (OPpLVAL_INTRO
* 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;
}
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);
https://perl5.git.perl.org / perl5.git / blobdiff