o->op_targ = 0;
}
#endif
+ case OP_METHOD:
+#ifdef USE_ITHREADS
+ if (cMETHOPx(o)->op_class_targ) {
+ pad_swipe(cMETHOPx(o)->op_class_targ, 1);
+ cMETHOPx(o)->op_class_targ = 0;
+ }
+#else
+ SvREFCNT_dec(cMETHOPx(o)->op_class_sv);
+ cMETHOPx(o)->op_class_sv = NULL;
+#endif
break;
case OP_CONST:
case OP_HINTSEVAL:
do_kids:
while (kid) {
OP *sib = OP_SIBLING(kid);
- if (sib && kid->op_type != OP_LEAVEWHEN)
+ if (sib && kid->op_type != OP_LEAVEWHEN
+ && ( OP_HAS_SIBLING(sib) || sib->op_type != OP_NULL
+ || ( sib->op_targ != OP_NEXTSTATE
+ && sib->op_targ != OP_DBSTATE )))
scalarvoid(kid);
else
scalar(kid);
=cut
*/
+static void
+S_mark_padname_lvalue(pTHX_ PADNAME *pn)
+{
+ CV *cv = PL_compcv;
+ PadnameLVALUE_on(pn);
+ while (PadnameOUTER(pn) && PARENT_PAD_INDEX(pn)) {
+ cv = CvOUTSIDE(cv);
+ assert(cv);
+ assert(CvPADLIST(cv));
+ pn =
+ PadlistNAMESARRAY(CvPADLIST(cv))[PARENT_PAD_INDEX(pn)];
+ assert(PadnameLEN(pn));
+ PadnameLVALUE_on(pn);
+ }
+}
+
static bool
S_vivifies(const OPCODE type)
{
if (!type) /* local() */
Perl_croak(aTHX_ "Can't localize lexical variable %"SVf,
PAD_COMPNAME_SV(o->op_targ));
+ if (!(o->op_private & OPpLVAL_INTRO)
+ || ( type != OP_SASSIGN && type != OP_AASSIGN
+ && PadnameIsSTATE(PAD_COMPNAME_SV(o->op_targ)) ))
+ S_mark_padname_lvalue(aTHX_ PAD_COMPNAME_SV(o->op_targ));
break;
case OP_PUSHMARK:
right->op_targ = 0;
right->op_private &= ~OPpTARGET_MY;
}
- if (!(right->op_flags & OPf_STACKED) && ismatchop) {
- OP *newleft;
-
- right->op_flags |= OPf_STACKED;
- if (rtype != OP_MATCH && rtype != OP_TRANSR &&
+ if (!(right->op_flags & OPf_STACKED) && !right->op_targ && ismatchop) {
+ if (left->op_type == OP_PADSV
+ && !(left->op_private & OPpLVAL_INTRO))
+ {
+ right->op_targ = left->op_targ;
+ op_free(left);
+ o = right;
+ }
+ else {
+ right->op_flags |= OPf_STACKED;
+ if (rtype != OP_MATCH && rtype != OP_TRANSR &&
! (rtype == OP_TRANS &&
right->op_private & OPpTRANS_IDENTICAL) &&
! (rtype == OP_SUBST &&
(cPMOPx(right)->op_pmflags & PMf_NONDESTRUCT)))
- newleft = op_lvalue(left, rtype);
- else
- newleft = left;
- if (right->op_type == OP_TRANS || right->op_type == OP_TRANSR)
- o = newBINOP(OP_NULL, OPf_STACKED, scalar(newleft), right);
- else
- o = op_prepend_elem(rtype, scalar(newleft), right);
+ left = op_lvalue(left, rtype);
+ if (right->op_type == OP_TRANS || right->op_type == OP_TRANSR)
+ o = newBINOP(OP_NULL, OPf_STACKED, scalar(left), right);
+ else
+ o = op_prepend_elem(rtype, scalar(left), right);
+ }
if (type == OP_NOT)
return newUNOP(OP_NOT, 0, scalar(o));
return o;
{
const int retval = PL_savestack_ix;
- PL_compiling.cop_seq = PL_cop_seqmax++;
- if (PL_cop_seqmax == PERL_PADSEQ_INTRO) /* not a legal value */
- PL_cop_seqmax++;
+ PL_compiling.cop_seq = PL_cop_seqmax;
+ COP_SEQMAX_INC;
pad_block_start(full);
SAVEHINTS();
PL_hints &= ~HINT_BLOCK_SCOPE;
OP* retval = scalarseq(seq);
OP *o;
+ /* XXX Is the null PL_parser check necessary here? */
+ assert(PL_parser); /* Let’s find out under debugging builds. */
+ if (PL_parser && PL_parser->parsed_sub) {
+ o = newSTATEOP(0, NULL, NULL);
+ op_null(o);
+ retval = op_append_elem(OP_LINESEQ, retval, o);
+ }
+
CALL_BLOCK_HOOKS(bhk_pre_end, &retval);
LEAVE_SCOPE(floor);
StructCopy(&PL_compiling, ¬_compiling, COP);
PL_curcop = ¬_compiling;
/* The above ensures that we run with all the correct hints of the
- currently compiling COP, but that IN_PERL_RUNTIME is not true. */
+ currently compiling COP, but that IN_PERL_RUNTIME is true. */
assert(IN_PERL_RUNTIME);
PL_warnhook = PERL_WARNHOOK_FATAL;
PL_diehook = NULL;
methop->op_flags = (U8)(flags | OPf_KIDS);
methop->op_u.op_first = dynamic_meth;
methop->op_private = (U8)(1 | (flags >> 8));
+
+#ifdef PERL_OP_PARENT
+ if (!OP_HAS_SIBLING(dynamic_meth))
+ dynamic_meth->op_sibling = (OP*)methop;
+#endif
}
else {
assert(const_meth);
methop->op_next = (OP*)methop;
}
+#ifdef USE_ITHREADS
+ methop->op_class_targ = 0;
+#else
+ methop->op_class_sv = NULL;
+#endif
CHANGE_TYPE(methop, type);
methop = (METHOP*) CHECKOP(type, methop);
return CHECKOP(type, pmop);
}
+static void
+S_set_haseval(pTHX)
+{
+ PADOFFSET i = 1;
+ PL_cv_has_eval = 1;
+ /* Any pad names in scope are potentially lvalues. */
+ for (; i < PadnamelistMAXNAMED(PL_comppad_name); i++) {
+ PADNAME *pn = PAD_COMPNAME_SV(i);
+ if (!pn || !PadnameLEN(pn))
+ continue;
+ if (PadnameOUTER(pn) || PadnameIN_SCOPE(pn, PL_cop_seqmax))
+ S_mark_padname_lvalue(aTHX_ pn);
+ }
+}
+
/* Given some sort of match op o, and an expression expr containing a
* pattern, either compile expr into a regex and attach it to o (if it's
* constant), or convert expr into a runtime regcomp op sequence (if it's
rcop->op_targ = cv_targ;
/* /$x/ may cause an eval, since $x might be qr/(?{..})/ */
- if (PL_hints & HINT_RE_EVAL) PL_cv_has_eval = 1;
+ if (PL_hints & HINT_RE_EVAL)
+ S_set_haseval(aTHX);
/* establish postfix order */
if (expr->op_type == OP_REGCRESET || expr->op_type == OP_REGCMAYBE) {
PL_hints |= HINT_BLOCK_SCOPE;
PL_parser->copline = NOLINE;
- PL_cop_seqmax++; /* Purely for B::*'s benefit */
- if (PL_cop_seqmax == PERL_PADSEQ_INTRO) /* not a legal value */
- PL_cop_seqmax++;
-
+ COP_SEQMAX_INC; /* Purely for B::*'s benefit */
}
/*
}
/*
- Helper function for newASSIGNOP to detection commonality between the
+ Helper function for newASSIGNOP to detect commonality between the
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
const U32 utf8 = flags & SVf_UTF8;
COP *cop;
+ PL_parser->parsed_sub = 0;
+
flags &= ~SVf_UTF8;
NewOp(1101, cop, 1, COP);
}
/* op_const_sv: examine an optree to determine whether it's in-lineable.
- * Can be called in 3 ways:
+ * Can be called in 2 ways:
*
- * !cv
+ * !allow_lex
* look for a single OP_CONST with attached value: return the value
*
- * cv && CvCLONE(cv) && !CvCONST(cv)
+ * allow_lex && !CvCONST(cv);
*
* examine the clone prototype, and if contains only a single
- * OP_CONST referencing a pad const, or a single PADSV referencing
- * an outer lexical, return a non-zero value to indicate the CV is
- * a candidate for "constizing" at clone time
- *
- * cv && CvCONST(cv)
- *
- * We have just cloned an anon prototype that was marked as a const
- * candidate. Try to grab the current value, and in the case of
- * PADSV, ignore it if it has multiple references. In this case we
- * return a newly created *copy* of the value.
+ * OP_CONST, return the value; or if it contains a single PADSV ref-
+ * erencing an outer lexical, turn on CvCONST to indicate the CV is
+ * a candidate for "constizing" at clone time, and return NULL.
*/
-SV *
-Perl_op_const_sv(pTHX_ const OP *o, CV *cv)
+static SV *
+S_op_const_sv(pTHX_ const OP *o, CV *cv, bool allow_lex)
{
SV *sv = NULL;
+ bool padsv = FALSE;
- if (!o)
- return NULL;
-
- if (o->op_type == OP_LINESEQ && cLISTOPo->op_first)
- o = OP_SIBLING(cLISTOPo->op_first);
+ assert(o);
+ assert(cv);
for (; o; o = o->op_next) {
const OPCODE type = o->op_type;
- if (sv && o->op_next == o)
- return sv;
- if (o->op_next != o) {
- if (type == OP_NEXTSTATE
- || (type == OP_NULL && !(o->op_flags & OPf_KIDS))
+ if (type == OP_NEXTSTATE || type == OP_LINESEQ
+ || type == OP_NULL
|| type == OP_PUSHMARK)
continue;
- if (type == OP_DBSTATE)
+ if (type == OP_DBSTATE)
continue;
- }
- if (type == OP_LEAVESUB || type == OP_RETURN)
+ if (type == OP_LEAVESUB)
break;
if (sv)
return NULL;
sv = newSV(0);
SAVEFREESV(sv);
}
- else if (cv && type == OP_CONST) {
- sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
- if (!sv)
- return NULL;
- }
- else if (cv && type == OP_PADSV) {
- if (CvCONST(cv)) { /* newly cloned anon */
- sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
- /* the candidate should have 1 ref from this pad and 1 ref
- * from the parent */
- if (!sv || SvREFCNT(sv) != 2)
- return NULL;
- sv = newSVsv(sv);
- SvREADONLY_on(sv);
- return sv;
- }
- else {
+ else if (allow_lex && type == OP_PADSV) {
if (PAD_COMPNAME_FLAGS(o->op_targ) & SVf_FAKE)
+ {
sv = &PL_sv_undef; /* an arbitrary non-null value */
- }
+ padsv = TRUE;
+ }
+ else
+ return NULL;
}
else {
return NULL;
}
}
+ if (padsv) {
+ CvCONST_on(cv);
+ return NULL;
+ }
return sv;
}
CV *clonee = NULL;
HEK *hek = NULL;
bool reusable = FALSE;
+ OP *start;
#ifdef PERL_DEBUG_READONLY_OPS
OPSLAB *slab = NULL;
#endif
spot = (CV **)(svspot = &mg->mg_obj);
}
+ if (block) {
+ /* This makes sub {}; work as expected. */
+ if (block->op_type == OP_STUB) {
+ const line_t l = PL_parser->copline;
+ op_free(block);
+ block = newSTATEOP(0, NULL, 0);
+ PL_parser->copline = l;
+ }
+ block = CvLVALUE(compcv)
+ || (cv && CvLVALUE(cv) && !CvROOT(cv) && !CvXSUB(cv))
+ ? newUNOP(OP_LEAVESUBLV, 0,
+ op_lvalue(scalarseq(block), OP_LEAVESUBLV))
+ : newUNOP(OP_LEAVESUB, 0, scalarseq(block));
+ start = LINKLIST(block);
+ block->op_next = 0;
+ }
+
if (!block || !ps || *ps || attrs
- || (CvFLAGS(compcv) & CVf_BUILTIN_ATTRS)
+ || CvLVALUE(compcv)
)
const_sv = NULL;
else
- const_sv = op_const_sv(block, NULL);
+ const_sv = S_op_const_sv(aTHX_ start, compcv, FALSE);
if (cv) {
const bool exists = CvROOT(cv) || CvXSUB(cv);
CvCONST_on(cv);
CvISXSUB_on(cv);
PoisonPADLIST(cv);
+ CvFLAGS(cv) |= CvMETHOD(compcv);
op_free(block);
SvREFCNT_dec(compcv);
PL_compcv = NULL;
exit. */
PL_breakable_sub_gen++;
- /* This makes sub {}; work as expected. */
- if (block->op_type == OP_STUB) {
- OP* const newblock = newSTATEOP(0, NULL, 0);
- op_free(block);
- block = newblock;
- }
- CvROOT(cv) = CvLVALUE(cv)
- ? newUNOP(OP_LEAVESUBLV, 0,
- op_lvalue(scalarseq(block), OP_LEAVESUBLV))
- : newUNOP(OP_LEAVESUB, 0, scalarseq(block));
+ CvROOT(cv) = 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
#ifdef PERL_DEBUG_READONLY_OPS
slab = (OPSLAB *)CvSTART(cv);
#endif
- CvSTART(cv) = LINKLIST(CvROOT(cv));
- CvROOT(cv)->op_next = 0;
- CALL_PEEP(CvSTART(cv));
+ CvSTART(cv) = start;
+ CALL_PEEP(start);
finalize_optree(CvROOT(cv));
S_prune_chain_head(&CvSTART(cv));
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>. */
o ? SvPV_const(o_is_gv ? (SV *)o : cSVOPo->op_sv, namlen) : NULL;
bool has_name;
bool name_is_utf8 = o && !o_is_gv && SvUTF8(cSVOPo->op_sv);
+ OP *start;
#ifdef PERL_DEBUG_READONLY_OPS
OPSLAB *slab = NULL;
bool special = FALSE;
? (CV *)SvRV(gv)
: NULL;
+ if (block) {
+ /* This makes sub {}; work as expected. */
+ if (block->op_type == OP_STUB) {
+ const line_t l = PL_parser->copline;
+ op_free(block);
+ block = newSTATEOP(0, NULL, 0);
+ PL_parser->copline = l;
+ }
+ block = CvLVALUE(PL_compcv)
+ || (cv && CvLVALUE(cv) && !CvROOT(cv) && !CvXSUB(cv)
+ && (!isGV(gv) || !GvASSUMECV(gv)))
+ ? newUNOP(OP_LEAVESUBLV, 0,
+ op_lvalue(scalarseq(block), OP_LEAVESUBLV))
+ : newUNOP(OP_LEAVESUB, 0, scalarseq(block));
+ start = LINKLIST(block);
+ block->op_next = 0;
+ }
if (!block || !ps || *ps || attrs
- || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS)
+ || CvLVALUE(PL_compcv)
)
const_sv = NULL;
else
- const_sv = op_const_sv(block, NULL);
+ const_sv =
+ S_op_const_sv(aTHX_ start, PL_compcv, CvCLONE(PL_compcv));
if (SvPOK(gv) || (SvROK(gv) && SvTYPE(SvRV(gv)) != SVt_PVCV)) {
assert (block);
CvCONST_on(cv);
CvISXSUB_on(cv);
PoisonPADLIST(cv);
+ CvFLAGS(cv) |= CvMETHOD(PL_compcv);
}
else {
- if (isGV(gv)) {
- if (name) GvCV_set(gv, NULL);
+ if (isGV(gv) || CvMETHOD(PL_compcv)) {
+ if (name && isGV(gv))
+ GvCV_set(gv, NULL);
cv = newCONSTSUB_flags(
NULL, name, namlen, name_is_utf8 ? SVf_UTF8 : 0,
const_sv
);
+ CvFLAGS(cv) |= CvMETHOD(PL_compcv);
}
else {
if (!SvROK(gv)) {
exit. */
PL_breakable_sub_gen++;
- /* This makes sub {}; work as expected. */
- if (block->op_type == OP_STUB) {
- OP* const newblock = newSTATEOP(0, NULL, 0);
- op_free(block);
- block = newblock;
- }
- CvROOT(cv) = CvLVALUE(cv)
- ? newUNOP(OP_LEAVESUBLV, 0,
- op_lvalue(scalarseq(block), OP_LEAVESUBLV))
- : newUNOP(OP_LEAVESUB, 0, scalarseq(block));
+ CvROOT(cv) = 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
#ifdef PERL_DEBUG_READONLY_OPS
slab = (OPSLAB *)CvSTART(cv);
#endif
- CvSTART(cv) = LINKLIST(CvROOT(cv));
- CvROOT(cv)->op_next = 0;
- CALL_PEEP(CvSTART(cv));
+ CvSTART(cv) = start;
+ CALL_PEEP(start);
finalize_optree(CvROOT(cv));
S_prune_chain_head(&CvSTART(cv));
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>. */
return cv;
}
+/*
+=for apidoc U||newXS
+
+Used by C<xsubpp> to hook up XSUBs as Perl subs. I<filename> needs to be
+static storage, as it is used directly as CvFILE(), without a copy being made.
+
+=cut
+*/
+
+CV *
+Perl_newXS(pTHX_ const char *name, XSUBADDR_t subaddr, const char *filename)
+{
+ PERL_ARGS_ASSERT_NEWXS;
+ return newXS_len_flags(
+ name, name ? strlen(name) : 0, subaddr, filename, NULL, NULL, 0
+ );
+}
+
CV *
Perl_newXS_flags(pTHX_ const char *name, XSUBADDR_t subaddr,
const char *const filename, const char *const proto,
}
CV *
+Perl_newXS_deffile(pTHX_ const char *name, XSUBADDR_t subaddr)
+{
+ PERL_ARGS_ASSERT_NEWXS_DEFFILE;
+ return newXS_len_flags(
+ name, name ? strlen(name) : 0, subaddr, NULL, NULL, NULL, 0
+ );
+}
+
+CV *
Perl_newXS_len_flags(pTHX_ const char *name, STRLEN len,
XSUBADDR_t subaddr, const char *const filename,
const char *const proto, SV **const_svp,
bool interleave = FALSE;
PERL_ARGS_ASSERT_NEWXS_LEN_FLAGS;
-
+ if (!subaddr)
+ Perl_croak_nocontext("panic: no address for '%s' in '%s'",
+ name, filename ? filename : PL_xsubfilename);
{
GV * const gv = gv_fetchpvn(
name ? name : PL_curstash ? "__ANON__" : "__ANON__::__ANON__",
name ? len : PL_curstash ? sizeof("__ANON__") - 1:
sizeof("__ANON__::__ANON__") - 1,
GV_ADDMULTI | flags, SVt_PVCV);
-
- if (!subaddr)
- Perl_croak(aTHX_ "panic: no address for '%s' in '%s'", name, filename);
-
+
if ((cv = (name ? GvCV(gv) : NULL))) {
if (GvCVGEN(gv)) {
/* just a cached method */
gv_method_changed(gv); /* newXS */
}
}
- if (!name)
- CvANON_on(cv);
+
CvGV_set(cv, gv);
- (void)gv_fetchfile(filename);
- CvFILE(cv) = (char *)filename; /* NOTE: not copied, as it is expected to be
- an external constant string */
- assert(!CvDYNFILE(cv)); /* cv_undef should have turned it off */
+ if(filename) {
+ (void)gv_fetchfile(filename);
+ assert(!CvDYNFILE(cv)); /* cv_undef should have turned it off */
+ if (flags & XS_DYNAMIC_FILENAME) {
+ CvDYNFILE_on(cv);
+ CvFILE(cv) = savepv(filename);
+ } else {
+ /* NOTE: not copied, as it is expected to be an external constant string */
+ CvFILE(cv) = (char *)filename;
+ }
+ } else {
+ assert((flags & XS_DYNAMIC_FILENAME) == 0 && PL_xsubfilename);
+ CvFILE(cv) = (char*)PL_xsubfilename;
+ }
CvISXSUB_on(cv);
CvXSUB(cv) = subaddr;
#ifndef PERL_IMPLICIT_CONTEXT
#else
PoisonPADLIST(cv);
#endif
-
+
if (name)
process_special_blocks(0, name, gv, cv);
- }
+ else
+ CvANON_on(cv);
+ } /* <- not a conditional branch */
+
- if (flags & XS_DYNAMIC_FILENAME) {
- CvFILE(cv) = savepv(filename);
- CvDYNFILE_on(cv);
- }
sv_setpv(MUTABLE_SV(cv), proto);
if (interleave) LEAVE;
return cv;
return cv;
}
-/*
-=for apidoc U||newXS
-
-Used by C<xsubpp> to hook up XSUBs as Perl subs. I<filename> needs to be
-static storage, as it is used directly as CvFILE(), without a copy being made.
-
-=cut
-*/
-
-CV *
-Perl_newXS(pTHX_ const char *name, XSUBADDR_t subaddr, const char *filename)
-{
- PERL_ARGS_ASSERT_NEWXS;
- return newXS_len_flags(
- name, name ? strlen(name) : 0, subaddr, filename, NULL, NULL, 0
- );
-}
-
void
Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block)
{
}
else {
scalar((OP*)kid);
- PL_cv_has_eval = 1;
+ S_set_haseval(aTHX);
}
}
else {
}
-OP *
-Perl_ck_sassign(pTHX_ OP *o)
+static OP *
+S_maybe_targlex(pTHX_ OP *o)
{
dVAR;
OP * const kid = cLISTOPo->op_first;
-
- PERL_ARGS_ASSERT_CK_SASSIGN;
-
/* has a disposable target? */
if ((PL_opargs[kid->op_type] & OA_TARGLEX)
&& !(kid->op_flags & OPf_STACKED)
/* Can just relocate the target. */
if (kkid && kkid->op_type == OP_PADSV
- && !(kkid->op_private & OPpLVAL_INTRO))
+ && (!(kkid->op_private & OPpLVAL_INTRO)
+ || kkid->op_private & OPpPAD_STATE))
{
kid->op_targ = kkid->op_targ;
kkid->op_targ = 0;
return kid;
}
}
+ return o;
+}
+
+OP *
+Perl_ck_sassign(pTHX_ OP *o)
+{
+ dVAR;
+ OP * const kid = cLISTOPo->op_first;
+
+ PERL_ARGS_ASSERT_CK_SASSIGN;
+
if (OP_HAS_SIBLING(kid)) {
OP *kkid = OP_SIBLING(kid);
- /* For state variable assignment, kkid is a list op whose op_last
- is a padsv. */
+ /* For state variable assignment with attributes, kkid is a list op
+ whose op_last is a padsv. */
if ((kkid->op_type == OP_PADSV ||
(OP_TYPE_IS_OR_WAS(kkid, OP_LIST) &&
(kkid = cLISTOPx(kkid)->op_last)->op_type == OP_PADSV
)
)
- && (kkid->op_private & OPpLVAL_INTRO)
- && SvPAD_STATE(PAD_COMPNAME_SV(kkid->op_targ))) {
+ && (kkid->op_private & (OPpLVAL_INTRO|OPpPAD_STATE))
+ == (OPpLVAL_INTRO|OPpPAD_STATE)) {
const PADOFFSET target = kkid->op_targ;
OP *const other = newOP(OP_PADSV,
kkid->op_flags
| ((kkid->op_private & ~OPpLVAL_INTRO) << 8));
OP *const first = newOP(OP_NULL, 0);
- OP *const nullop = newCONDOP(0, first, o, other);
+ OP *const nullop =
+ newCONDOP(0, first, S_maybe_targlex(aTHX_ o), other);
OP *const condop = first->op_next;
CHANGE_TYPE(condop, OP_ONCE);
return nullop;
}
}
- return o;
+ return S_maybe_targlex(aTHX_ o);
}
OP *
OP * const padop = newOP(OP_PADCV, 0);
padop->op_targ = off;
cUNOPx(firstkid)->op_first = padop;
+#ifdef PERL_OP_PARENT
+ padop->op_sibling = firstkid;
+#endif
op_free(kid);
}
}
case '&':
proto++;
arg++;
- if (o3->op_type != OP_REFGEN && o3->op_type != OP_SREFGEN
- && o3->op_type != OP_UNDEF)
+ if (o3->op_type != OP_SREFGEN
+ || ( cUNOPx(cUNOPx(o3)->op_first)->op_first->op_type
+ != OP_ANONCODE
+ && cUNOPx(cUNOPx(o3)->op_first)->op_first->op_type
+ != OP_RV2CV))
bad_type_gv(arg,
arg == 1 ? "block or sub {}" : "sub {}",
namegv, 0, o3);
OP *aop, *cvop;
CV *cv;
GV *namegv;
+ SV *const_class = NULL;
PERL_ARGS_ASSERT_CK_SUBR;
o->op_private |= (PL_hints & HINT_STRICT_REFS);
if (PERLDB_SUB && PL_curstash != PL_debstash)
o->op_private |= OPpENTERSUB_DB;
- if (cvop->op_type == OP_RV2CV) {
- o->op_private |= (cvop->op_private & OPpENTERSUB_AMPER);
- op_null(cvop);
- } else if (cvop->op_type == OP_METHOD || cvop->op_type == OP_METHOD_NAMED) {
- if (aop->op_type == OP_CONST)
- aop->op_private &= ~OPpCONST_STRICT;
- else if (aop->op_type == OP_LIST) {
- OP * const sib = OP_SIBLING(((UNOP*)aop)->op_first);
- if (sib && sib->op_type == OP_CONST)
- sib->op_private &= ~OPpCONST_STRICT;
- }
+ switch (cvop->op_type) {
+ case OP_RV2CV:
+ o->op_private |= (cvop->op_private & OPpENTERSUB_AMPER);
+ op_null(cvop);
+ break;
+ case OP_METHOD:
+ case OP_METHOD_NAMED:
+ if (aop->op_type == OP_CONST) {
+ aop->op_private &= ~OPpCONST_STRICT;
+ const_class = cSVOPx(aop)->op_sv;
+ }
+ else if (aop->op_type == OP_LIST) {
+ OP * const sib = OP_SIBLING(((UNOP*)aop)->op_first);
+ if (sib && sib->op_type == OP_CONST) {
+ sib->op_private &= ~OPpCONST_STRICT;
+ const_class = cSVOPx(sib)->op_sv;
+ }
+ }
+ /* cache const class' name to speedup class method calls */
+ if (const_class) {
+ STRLEN len;
+ SV* shared;
+ const char* str = SvPV(const_class, len);
+ if (len) {
+ shared = newSVpvn_share(
+ str, SvUTF8(const_class) ? -len : len, 0
+ );
+#ifdef USE_ITHREADS
+ op_relocate_sv(&shared, &cMETHOPx(cvop)->op_class_targ);
+#else
+ cMETHOPx(cvop)->op_class_sv = shared;
+#endif
+ }
+ }
+ break;
}
if (!cv) {
break;
case OP_RUNCV:
- if (!(o->op_private & OPpOFFBYONE) && !CvCLONE(PL_compcv)) {
+ if (!(o->op_private & OPpOFFBYONE) && !CvCLONE(PL_compcv)
+ && (!CvANON(PL_compcv) || (!PL_cv_has_eval && !PL_perldb)))
+ {
SV *sv;
if (CvEVAL(PL_compcv)) sv = &PL_sv_undef;
else {
/* 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. */
+ /* There can’t be common vars if the lhs is a stub. */
+ if (OP_SIBLING(cLISTOPx(cBINOPo->op_last)->op_first)
+ == cLISTOPx(cBINOPo->op_last)->op_last
+ && cLISTOPx(cBINOPo->op_last)->op_last->op_type == OP_STUB)
+ {
+ o->op_private &=~ OPpASSIGN_COMMON;
+ break;
+ }
if (o->op_private & OPpASSIGN_COMMON) {
/* See the comment before S_aassign_common_vars concerning
PL_generation sorcery. */
https://perl5.git.perl.org / perl5.git / blobdiff