/* This file contains the functions that create, manipulate and optimize
* the OP structures that hold a compiled perl program.
*
- * A Perl program is compiled into a tree of OPs. Each op contains
- * structural pointers (eg to its siblings and the next op in the
- * execution sequence), a pointer to the function that would execute the
- * op, plus any data specific to that op. For example, an OP_CONST op
- * points to the pp_const() function and to an SV containing the constant
- * value. When pp_const() is executed, its job is to push that SV onto the
- * stack.
+ * Note that during the build of miniperl, a temporary copy of this file
+ * is made, called opmini.c.
+ *
+ * A Perl program is compiled into a tree of OP nodes. Each op contains:
+ * * structural OP pointers to its children and siblings (op_sibling,
+ * op_first etc) that define the tree structure;
+ * * execution order OP pointers (op_next, plus sometimes op_other,
+ * op_lastop etc) that define the execution sequence plus variants;
+ * * a pointer to the C "pp" function that would execute the op;
+ * * any data specific to that op.
+ * For example, an OP_CONST op points to the pp_const() function and to an
+ * SV containing the constant value. When pp_const() is executed, its job
+ * is to push that SV onto the stack.
*
* OPs are mainly created by the newFOO() functions, which are mainly
* called from the parser (in perly.y) as the code is parsed. For example
* newBINOP(OP_MULTIPLY, flags, newSVREF($b), newSVREF($c))
* )
*
- * Note that during the build of miniperl, a temporary copy of this file
- * is made, called opmini.c.
+ * As the parser reduces low-level rules, it creates little op subtrees;
+ * as higher-level rules are resolved, these subtrees get joined together
+ * as branches on a bigger subtree, until eventually a top-level rule like
+ * a subroutine definition is reduced, at which point there is one large
+ * parse tree left.
+ *
+ * The execution order pointers (op_next) are generated as the subtrees
+ * are joined together. Consider this sub-expression: A*B + C/D: at the
+ * point when it's just been parsed, the op tree looks like:
+ *
+ * [+]
+ * |
+ * [*]------[/]
+ * | |
+ * A---B C---D
+ *
+ * with the intended execution order being:
+ *
+ * [PREV] => A => B => [*] => C => D => [/] => [+] => [NEXT]
+ *
+ * At this point all the nodes' op_next pointers will have been set,
+ * except that:
+ * * we don't know what the [NEXT] node will be yet;
+ * * we don't know what the [PREV] node will be yet, but when it gets
+ * created and needs its op_next set, it needs to be set to point to
+ * A, which is non-obvious.
+ * To handle both those cases, we temporarily set the top node's
+ * op_next to point to the first node to be executed in this subtree (A in
+ * this case). This means that initially a subtree's op_next chain,
+ * starting from the top node, will visit each node in execution sequence
+ * then point back at the top node.
+ * When we embed this subtree in a larger tree, its top op_next is used
+ * to get the start node, then is set to point to its new neighbour.
+ * For example the two separate [*],A,B and [/],C,D subtrees would
+ * initially have had:
+ * [*] => A; A => B; B => [*]
+ * and
+ * [/] => C; C => D; D => [/]
+ * When these two subtrees were joined together to make the [+] subtree,
+ * [+]'s op_next was set to [*]'s op_next, i.e. A; then [*]'s op_next was
+ * set to point to [/]'s op_next, i.e. C.
+ *
+ * This op_next linking is done by the LINKLIST() macro and its underlying
+ * op_linklist() function. Given a top-level op, if its op_next is
+ * non-null, it's already been linked, so leave it. Otherwise link it with
+ * its children as described above, possibly recursively if any of the
+ * children have a null op_next.
+ *
+ * In summary: given a subtree, its top-level node's op_next will either
+ * be:
+ * NULL: the subtree hasn't been LINKLIST()ed yet;
+ * fake: points to the start op for this subtree;
+ * real: once the subtree has been embedded into a larger tree
*/
/*
+
+Here's an older description from Larry.
+
Perl's compiler is essentially a 3-pass compiler with interleaved phases:
A bottom-up pass
#define CALL_RPEEP(o) PL_rpeepp(aTHX_ o)
#define CALL_OPFREEHOOK(o) if (PL_opfreehook) PL_opfreehook(aTHX_ o)
+static const char array_passed_to_stat[] = "Array passed to stat will be coerced to a scalar";
+
/* Used to avoid recursion through the op tree in scalarvoid() and
op_free()
*/
/* FALLTHROUGH */
case OP_ENTERTRY:
case OP_ENTEREVAL: /* Was holding hints. */
+ case OP_ARGDEFELEM: /* Was holding signature index. */
o->op_targ = 0;
break;
default:
break;
+ case OP_ARGCHECK:
+ PerlMemShared_free(cUNOP_AUXo->op_aux);
+ break;
+
case OP_MULTIDEREF:
{
UNOP_AUX_item *items = cUNOP_AUXo->op_aux;
* being spread throughout this file.
*/
-STATIC LOGOP *
-S_alloc_LOGOP(pTHX_ I32 type, OP *first, OP* other)
+LOGOP *
+Perl_alloc_LOGOP(pTHX_ I32 type, OP *first, OP* other)
{
dVAR;
LOGOP *logop;
{
PERL_ARGS_ASSERT_SCALARBOOLEAN;
- if (o->op_type == OP_SASSIGN && cBINOPo->op_first->op_type == OP_CONST
- && !(cBINOPo->op_first->op_flags & OPf_SPECIAL)) {
+ if ((o->op_type == OP_SASSIGN && cBINOPo->op_first->op_type == OP_CONST &&
+ !(cBINOPo->op_first->op_flags & OPf_SPECIAL)) ||
+ (o->op_type == OP_NOT && cUNOPo->op_first->op_type == OP_SASSIGN &&
+ cBINOPx(cUNOPo->op_first)->op_first->op_type == OP_CONST &&
+ !(cBINOPx(cUNOPo->op_first)->op_first->op_flags & OPf_SPECIAL))) {
if (ckWARN(WARN_SYNTAX)) {
const line_t oldline = CopLINE(PL_curcop);
}
static SV *
-S_op_varname(pTHX_ const OP *o)
+S_op_varname_subscript(pTHX_ const OP *o, int subscript_type)
{
assert(o);
assert(o->op_type == OP_PADAV || o->op_type == OP_RV2AV ||
if (cUNOPo->op_first->op_type != OP_GV
|| !(gv = cGVOPx_gv(cUNOPo->op_first)))
return NULL;
- return varname(gv, funny, 0, NULL, 0, 1);
+ return varname(gv, funny, 0, NULL, 0, subscript_type);
}
return
- varname(MUTABLE_GV(PL_compcv), funny, o->op_targ, NULL, 0, 1);
+ varname(MUTABLE_GV(PL_compcv), funny, o->op_targ, NULL, 0, subscript_type);
}
}
+static SV *
+S_op_varname(pTHX_ const OP *o)
+{
+ return S_op_varname_subscript(aTHX_ o, 1);
+}
+
static void
S_op_pretty(pTHX_ const OP *o, SV **retsv, const char **retpv)
{ /* or not so pretty :-) */
{
PERL_ARGS_ASSERT_FINALIZE_OP;
+ assert(o->op_type != OP_FREED);
switch (o->op_type) {
case OP_NEXTSTATE:
PadnameLVALUE_on(pn);
while (PadnameOUTER(pn) && PARENT_PAD_INDEX(pn)) {
cv = CvOUTSIDE(cv);
- assert(cv);
+ /* RT #127786: cv can be NULL due to an eval within the DB package
+ * called from an anon sub - anon subs don't have CvOUTSIDE() set
+ * unless they contain an eval, but calling eval within DB
+ * pretends the eval was done in the caller's scope.
+ */
+ if (!cv)
+ break;
assert(CvPADLIST(cv));
pn =
PadlistNAMESARRAY(CvPADLIST(cv))[PARENT_PAD_INDEX(pn)];
case OP_ASLICE:
case OP_HSLICE:
OpTYPE_set(o, OP_LVREFSLICE);
- o->op_private &= OPpLVAL_INTRO|OPpLVREF_ELEM;
+ o->op_private &= OPpLVAL_INTRO;
return;
case OP_NULL:
if (o->op_flags & OPf_SPECIAL) /* do BLOCK */
? "do block"
: OP_DESC(o),
PL_op_desc[type]));
+ return;
}
OpTYPE_set(o, OP_LVREF);
o->op_private &=
o->op_private |= OPpLVREF_ITER;
}
+PERL_STATIC_INLINE bool
+S_potential_mod_type(I32 type)
+{
+ /* Types that only potentially result in modification. */
+ return type == OP_GREPSTART || type == OP_ENTERSUB
+ || type == OP_REFGEN || type == OP_LEAVESUBLV;
+}
+
OP *
Perl_op_lvalue_flags(pTHX_ OP *o, I32 type, U32 flags)
{
else { /* lvalue subroutine call */
o->op_private |= OPpLVAL_INTRO;
PL_modcount = RETURN_UNLIMITED_NUMBER;
- if (type == OP_GREPSTART || type == OP_ENTERSUB
- || type == OP_REFGEN || type == OP_LEAVESUBLV) {
- /* Potential lvalue context: */
+ if (S_potential_mod_type(type)) {
o->op_private |= OPpENTERSUB_INARGS;
break;
}
nomod:
if (flags & OP_LVALUE_NO_CROAK) return NULL;
/* grep, foreach, subcalls, refgen */
- if (type == OP_GREPSTART || type == OP_ENTERSUB
- || type == OP_REFGEN || type == OP_LEAVESUBLV)
+ if (S_potential_mod_type(type))
break;
yyerror(Perl_form(aTHX_ "Can't modify %s in %s",
(o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)
break;
case OP_KVHSLICE:
case OP_KVASLICE:
+ case OP_AKEYS:
if (type == OP_LEAVESUBLV)
o->op_private |= OPpMAYBE_LVSUB;
goto nomod;
+ case OP_AVHVSWITCH:
+ if (type == OP_LEAVESUBLV
+ && (o->op_private & 3) + OP_EACH == OP_KEYS)
+ o->op_private |= OPpMAYBE_LVSUB;
+ goto nomod;
case OP_AV2ARYLEN:
PL_hints |= HINT_BLOCK_SCOPE;
if (type == OP_LEAVESUBLV)
break;
case OP_KEYS:
- if (type != OP_SASSIGN && type != OP_LEAVESUBLV)
+ if (type != OP_LEAVESUBLV && !scalar_mod_type(NULL, type))
goto nomod;
goto lvalue_func;
case OP_SUBSTR:
lvalue_func:
if (type == OP_LEAVESUBLV)
o->op_private |= OPpMAYBE_LVSUB;
- if (o->op_flags & OPf_KIDS)
- op_lvalue(OpSIBLING(cBINOPo->op_first), type);
+ if (o->op_flags & OPf_KIDS && OpHAS_SIBLING(cBINOPo->op_first)) {
+ /* substr and vec */
+ /* If this op is in merely potential (non-fatal) modifiable
+ context, then apply OP_ENTERSUB context to
+ the kid op (to avoid croaking). Other-
+ wise pass this op’s own type so the correct op is mentioned
+ in error messages. */
+ op_lvalue(OpSIBLING(cBINOPo->op_first),
+ S_potential_mod_type(type)
+ ? (I32)OP_ENTERSUB
+ : o->op_type);
+ }
break;
case OP_AELEM:
goto nomod;
case OP_SREFGEN:
+ if (type == OP_NULL) { /* local */
+ local_refgen:
+ if (!FEATURE_MYREF_IS_ENABLED)
+ Perl_croak(aTHX_ "The experimental declared_refs "
+ "feature is not enabled");
+ Perl_ck_warner_d(aTHX_
+ packWARN(WARN_EXPERIMENTAL__DECLARED_REFS),
+ "Declaring references is experimental");
+ op_lvalue(cUNOPo->op_first, OP_NULL);
+ return o;
+ }
if (type != OP_AASSIGN && type != OP_SASSIGN
&& type != OP_ENTERLOOP)
goto nomod;
assert (!OpHAS_SIBLING(kid));
goto kid_2lvref;
case OP_REFGEN:
+ if (type == OP_NULL) /* local */
+ goto local_refgen;
if (type != OP_AASSIGN) goto nomod;
kid = cUNOPo->op_first;
kid_2lvref:
goto nomod;
}
- /* [20011101.069] File test operators interpret OPf_REF to mean that
+ /* [20011101.069 (#7861)] File test operators interpret OPf_REF to mean that
their argument is a filehandle; thus \stat(".") should not set
it. AMS 20011102 */
if (type == OP_REFGEN &&
o->op_flags |= OPf_MOD;
if (type == OP_AASSIGN || type == OP_SASSIGN)
- o->op_flags |= OPf_SPECIAL|OPf_REF;
+ o->op_flags |= OPf_SPECIAL
+ |(o->op_type == OP_ENTERSUB ? 0 : OPf_REF);
else if (!type) { /* local() */
switch (localize) {
case 1:
}
}
else if (type != OP_GREPSTART && type != OP_ENTERSUB
- && type != OP_LEAVESUBLV)
+ && type != OP_LEAVESUBLV && o->op_type != OP_ENTERSUB)
o->op_flags |= OPf_REF;
return o;
}
case OP_BIT_AND:
case OP_BIT_XOR:
case OP_BIT_OR:
+ case OP_NBIT_AND:
+ case OP_NBIT_XOR:
+ case OP_NBIT_OR:
+ case OP_SBIT_AND:
+ case OP_SBIT_XOR:
+ case OP_SBIT_OR:
case OP_CONCAT:
case OP_SUBST:
case OP_TRANS:
case OP_ANDASSIGN:
case OP_ORASSIGN:
case OP_DORASSIGN:
+ case OP_VEC:
+ case OP_SUBSTR:
return TRUE;
default:
return FALSE;
type = o->op_type;
- if (type == OP_LIST) {
+ if (OP_TYPE_IS_OR_WAS(o, OP_LIST)) {
OP *kid;
for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid))
my_kid(kid, attrs, imopsp);
return o;
} else if (type == OP_RV2SV || /* "our" declaration */
type == OP_RV2AV ||
- type == OP_RV2HV) { /* XXX does this let anything illegal in? */
+ type == OP_RV2HV) {
if (cUNOPo->op_first->op_type != OP_GV) { /* MJD 20011224 */
S_cant_declare(aTHX_ o);
} else if (attrs) {
o->op_private |= OPpOUR_INTRO;
return o;
}
+ else if (type == OP_REFGEN || type == OP_SREFGEN) {
+ if (!FEATURE_MYREF_IS_ENABLED)
+ Perl_croak(aTHX_ "The experimental declared_refs "
+ "feature is not enabled");
+ Perl_ck_warner_d(aTHX_
+ packWARN(WARN_EXPERIMENTAL__DECLARED_REFS),
+ "Declaring references is experimental");
+ /* Kid is a nulled OP_LIST, handled above. */
+ my_kid(cUNOPo->op_first, attrs, imopsp);
+ return o;
+ }
else if (type != OP_PADSV &&
type != OP_PADAV &&
type != OP_PADHV &&
goto nope; /* Don't try to run w/ errors */
for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
- const OPCODE type = curop->op_type;
- if ((type != OP_CONST || (curop->op_private & OPpCONST_BARE)) &&
- type != OP_LIST &&
- type != OP_SCALAR &&
- type != OP_NULL &&
- type != OP_PUSHMARK)
- {
+ switch (curop->op_type) {
+ case OP_CONST:
+ if ( (curop->op_private & OPpCONST_BARE)
+ && (curop->op_private & OPpCONST_STRICT)) {
+ no_bareword_allowed(curop);
+ goto nope;
+ }
+ /* FALLTHROUGH */
+ case OP_LIST:
+ case OP_SCALAR:
+ case OP_NULL:
+ case OP_PUSHMARK:
+ /* Foldable; move to next op in list */
+ break;
+
+ default:
+ /* No other op types are considered foldable */
goto nope;
}
}
SSize_t i = 0;
assert(PadnamelistMAXNAMED(PL_comppad_name) == 0);
while (++i <= AvFILLp(PL_comppad)) {
+# ifdef USE_PAD_RESET
+ /* under USE_PAD_RESET, pad swipe replaces a swiped
+ * folded constant with a fresh padtmp */
+ assert(!PL_curpad[i] || SvPADTMP(PL_curpad[i]));
+# else
assert(!PL_curpad[i]);
+# endif
}
#endif
/* But we know that one op is using this CV's slab. */
expr = list(force_list(newUNOP(OP_ENTERSUB, 0, scalar(expr)), 1));
}
- rcop = S_alloc_LOGOP(aTHX_ OP_REGCOMP, scalar(expr), o);
+ rcop = alloc_LOGOP(OP_REGCOMP, scalar(expr), o);
rcop->op_flags |= ((PL_hints & HINT_RE_EVAL) ? OPf_SPECIAL : 0)
| (reglist ? OPf_STACKED : 0);
rcop->op_targ = cv_targ;
op_prepend_elem(o->op_type, scalar(repl), o);
}
else {
- rcop = S_alloc_LOGOP(aTHX_ OP_SUBSTCONT, scalar(repl), o);
+ rcop = alloc_LOGOP(OP_SUBSTCONT, scalar(repl), o);
rcop->op_private = 1;
/* establish postfix order */
|| type == OP_CUSTOM);
scalarboolean(first);
- /* optimize AND and OR ops that have NOTs as children */
- if (first->op_type == OP_NOT
- && (first->op_flags & OPf_KIDS)
- && ((first->op_flags & OPf_SPECIAL) /* unless ($x) { } */
- || (other->op_type == OP_NOT)) /* if (!$x && !$y) { } */
- ) {
- if (type == OP_AND || type == OP_OR) {
- if (type == OP_AND)
- type = OP_OR;
- else
- type = OP_AND;
- op_null(first);
- if (other->op_type == OP_NOT) { /* !a AND|OR !b => !(a OR|AND b) */
- op_null(other);
- prepend_not = 1; /* prepend a NOT op later */
- }
- }
- }
+
/* search for a constant op that could let us fold the test */
if ((cstop = search_const(first))) {
if (cstop->op_private & OPpCONST_STRICT)
if ((type == OP_AND && SvTRUE(((SVOP*)cstop)->op_sv)) ||
(type == OP_OR && !SvTRUE(((SVOP*)cstop)->op_sv)) ||
(type == OP_DOR && !SvOK(((SVOP*)cstop)->op_sv))) {
+ /* Elide the (constant) lhs, since it can't affect the outcome */
*firstp = NULL;
if (other->op_type == OP_CONST)
other->op_private |= OPpCONST_SHORTCIRCUIT;
return other;
}
else {
+ /* Elide the rhs, since the outcome is entirely determined by
+ * the (constant) lhs */
+
/* check for C<my $x if 0>, or C<my($x,$y) if 0> */
const OP *o2 = other;
if ( ! (o2->op_type == OP_LIST
*otherp = NULL;
if (cstop->op_type == OP_CONST)
cstop->op_private |= OPpCONST_SHORTCIRCUIT;
- op_free(other);
+ op_free(other);
return first;
}
}
}
}
- if (!other)
- return first;
-
if (type == OP_ANDASSIGN || type == OP_ORASSIGN || type == OP_DORASSIGN)
other->op_private |= OPpASSIGN_BACKWARDS; /* other is an OP_SASSIGN */
- logop = S_alloc_LOGOP(aTHX_ type, first, LINKLIST(other));
+ /* optimize AND and OR ops that have NOTs as children */
+ if (first->op_type == OP_NOT
+ && (first->op_flags & OPf_KIDS)
+ && ((first->op_flags & OPf_SPECIAL) /* unless ($x) { } */
+ || (other->op_type == OP_NOT)) /* if (!$x && !$y) { } */
+ ) {
+ if (type == OP_AND || type == OP_OR) {
+ if (type == OP_AND)
+ type = OP_OR;
+ else
+ type = OP_AND;
+ op_null(first);
+ if (other->op_type == OP_NOT) { /* !a AND|OR !b => !(a OR|AND b) */
+ op_null(other);
+ prepend_not = 1; /* prepend a NOT op later */
+ }
+ }
+ }
+
+ logop = alloc_LOGOP(type, first, LINKLIST(other));
logop->op_flags |= (U8)flags;
logop->op_private = (U8)(1 | (flags >> 8));
live->op_folded = 1;
return live;
}
- logop = S_alloc_LOGOP(aTHX_ OP_COND_EXPR, first, LINKLIST(trueop));
+ logop = alloc_LOGOP(OP_COND_EXPR, first, LINKLIST(trueop));
logop->op_flags |= (U8)flags;
logop->op_private = (U8)(1 | (flags >> 8));
logop->op_next = LINKLIST(falseop);
PERL_ARGS_ASSERT_NEWRANGE;
- range = S_alloc_LOGOP(aTHX_ OP_RANGE, left, LINKLIST(right));
+ range = alloc_LOGOP(OP_RANGE, left, LINKLIST(right));
range->op_flags = OPf_KIDS;
leftstart = LINKLIST(left);
range->op_private = (U8)(1 | (flags >> 8));
PERL_ARGS_ASSERT_NEWGIVWHENOP;
PERL_UNUSED_ARG(entertarg); /* used to indicate targ of lexical $_ */
- enterop = S_alloc_LOGOP(aTHX_ enter_opcode, block, NULL);
+ enterop = alloc_LOGOP(enter_opcode, block, NULL);
enterop->op_targ = 0;
enterop->op_private = 0;
return sv;
}
-static bool
+static void
S_already_defined(pTHX_ CV *const cv, OP * const block, OP * const o,
PADNAME * const name, SV ** const const_svp)
{
assert (cv);
assert (o || name);
assert (const_svp);
- if ((!block
- )) {
+ if (!block) {
if (CvFLAGS(PL_compcv)) {
/* might have had built-in attrs applied */
const bool pureperl = !CvISXSUB(cv) && CvROOT(cv);
(CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS
& ~(CVf_LVALUE * pureperl));
}
- return FALSE;
+ return;
}
/* redundant check for speed: */
CopLINE_set(PL_curcop, oldline);
}
SAVEFREESV(cv);
- return TRUE;
+ return;
}
CV *
outside, as in:
my sub foo; sub { sub foo { } }
*/
- redo:
+ redo:
name = PadlistNAMESARRAY(CvPADLIST(outcv))[pax];
if (PadnameOUTER(name) && PARENT_PAD_INDEX(name)) {
pax = PARENT_PAD_INDEX(name);
ps_utf8);
/* already defined? */
if (exists) {
- if (S_already_defined(aTHX_ cv,block,NULL,name,&const_sv))
+ S_already_defined(aTHX_ cv, block, NULL, name, &const_sv);
+ if (block)
cv = NULL;
else {
- if (attrs) goto attrs;
+ if (attrs)
+ goto attrs;
/* just a "sub foo;" when &foo is already defined */
SAVEFREESV(compcv);
goto done;
reusable = TRUE;
}
}
+
if (const_sv) {
SvREFCNT_inc_simple_void_NN(const_sv);
SvFLAGS(const_sv) |= SVs_PADTMP;
PL_compcv = NULL;
goto setname;
}
+
/* 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-
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
- ) {
+ if (block) {
cv_flags_t preserved_flags =
CvFLAGS(cv) & (CVf_BUILTIN_ATTRS|CVf_NAMED);
PADLIST *const temp_padl = CvPADLIST(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;
+ ++PL_sub_generation;
}
else {
/* Might have had built-in attributes applied -- propagate them. */
cv = compcv;
*spot = cv;
}
- setname:
+
+ setname:
CvLEXICAL_on(cv);
if (!CvNAME_HEK(cv)) {
if (hek) (void)share_hek_hek(hek);
}
CvNAME_HEK_set(cv, hek);
}
- if (const_sv) goto clone;
+
+ if (const_sv)
+ goto clone;
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));
+ if (ps_utf8)
+ SvUTF8_on(MUTABLE_SV(cv));
}
- 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++;
- 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
- itself has a refcount. */
- CvSLABBED_off(cv);
- OpslabREFCNT_dec_padok((OPSLAB *)CvSTART(cv));
+ if (block) {
+ /* 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++;
+ 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
+ itself has a refcount. */
+ CvSLABBED_off(cv);
+ OpslabREFCNT_dec_padok((OPSLAB *)CvSTART(cv));
#ifdef PERL_DEBUG_READONLY_OPS
- slab = (OPSLAB *)CvSTART(cv);
+ slab = (OPSLAB *)CvSTART(cv);
#endif
- CvSTART(cv) = start;
- CALL_PEEP(start);
- finalize_optree(CvROOT(cv));
- S_prune_chain_head(&CvSTART(cv));
+ CvSTART(cv) = start;
+ CALL_PEEP(start);
+ finalize_optree(CvROOT(cv));
+ S_prune_chain_head(&CvSTART(cv));
- /* now that optimizer has done its work, adjust pad values */
+ /* now that optimizer has done its work, adjust pad values */
- pad_tidy(CvCLONE(cv) ? padtidy_SUBCLONE : padtidy_SUB);
+ pad_tidy(CvCLONE(cv) ? padtidy_SUBCLONE : padtidy_SUB);
+ }
attrs:
if (attrs) {
sv_sethek(tmpstr, HvNAME_HEK(PL_curstash));
sv_catpvs(tmpstr, "::");
}
- else sv_setpvs(tmpstr, "__ANON__::");
+ 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),
assert(CvDEPTH(outcv));
spot = (CV **)
&PadARRAY(PadlistARRAY(CvPADLIST(outcv))[CvDEPTH(outcv)])[pax];
- if (reusable) cv_clone_into(clonee, *spot);
+ if (reusable)
+ cv_clone_into(clonee, *spot);
else *spot = cv_clone(clonee);
SvREFCNT_dec_NN(clonee);
cv = *spot;
}
+
if (CvDEPTH(outcv) && !reusable && PadnameIsSTATE(name)) {
PADOFFSET depth = CvDEPTH(outcv);
while (--depth) {
return cv;
}
+
/* _x = extended */
CV *
Perl_newATTRSUB_x(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs,
const char *ps;
STRLEN ps_len = 0; /* init it to avoid false uninit warning from icc */
U32 ps_utf8 = 0;
- CV *cv = NULL;
+ CV *cv = NULL; /* the previous CV with this name, if any */
SV *const_sv;
const bool ec = PL_parser && PL_parser->error_count;
/* If the subroutine has no body, no attributes, and no builtin attributes
gv = gv_fetchpvs("__ANON__::__ANON__", gv_fetch_flags, SVt_PVCV);
has_name = FALSE;
}
+
if (!ec) {
if (isGV(gv)) {
move_proto_attr(&proto, &attrs, gv);
if (ec) {
op_free(block);
- if (name) SvREFCNT_dec(PL_compcv);
- else cv = PL_compcv;
+
+ if (name)
+ SvREFCNT_dec(PL_compcv);
+ else
+ cv = PL_compcv;
+
PL_compcv = 0;
if (name && block) {
const char *s = strrchr(name, ':');
}
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 (!SvROK(gv)) {
- if (ps) {
- sv_setpvn(MUTABLE_SV(gv), ps, ps_len);
- if ( ps_utf8 ) SvUTF8_on(MUTABLE_SV(gv));
- }
- else
- sv_setiv(MUTABLE_SV(gv), -1);
- }
+ /* 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);
+ }
- SvREFCNT_dec(PL_compcv);
- cv = PL_compcv = NULL;
- goto done;
- }
+ if (!SvROK(gv)) {
+ if (ps) {
+ sv_setpvn(MUTABLE_SV(gv), ps, ps_len);
+ if (ps_utf8)
+ SvUTF8_on(MUTABLE_SV(gv));
+ }
+ else
+ sv_setiv(MUTABLE_SV(gv), -1);
+ }
+
+ SvREFCNT_dec(PL_compcv);
+ cv = PL_compcv = NULL;
+ goto done;
+ }
}
cv = (!name || (isGV(gv) && GvCVGEN(gv)))
if (ckWARN(WARN_REDEFINE)
|| ( ckWARN_d(WARN_REDEFINE)
&& ( !const_sv || SvRV(gv) == const_sv
- || sv_cmp(SvRV(gv), const_sv) )))
+ || sv_cmp(SvRV(gv), const_sv) ))) {
+ assert(cSVOPo);
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);
cv_ckproto_len_flags(cv, gv, ps, ps_len, ps_utf8);
/* already defined (or promised)? */
if (exists || (isGV(gv) && GvASSUMECV(gv))) {
- if (S_already_defined(aTHX_ cv, block, o, NULL, &const_sv))
+ S_already_defined(aTHX_ cv, block, o, NULL, &const_sv);
+ if (block)
cv = NULL;
else {
- if (attrs) goto attrs;
+ if (attrs)
+ goto attrs;
/* just a "sub foo;" when &foo is already defined */
SAVEFREESV(PL_compcv);
goto done;
}
}
}
+
if (const_sv) {
SvREFCNT_inc_simple_void_NN(const_sv);
SvFLAGS(const_sv) |= SVs_PADTMP;
PL_compcv = NULL;
goto done;
}
+
+ /* don't copy new BEGIN CV to old BEGIN CV - RT #129099 */
+ if (name && cv && *name == 'B' && strEQ(name, "BEGIN"))
+ cv = NULL;
+
if (cv) { /* must reuse cv if autoloaded */
/* transfer PL_compcv to cv */
- if (block
- ) {
+ if (block) {
cv_flags_t existing_builtin_attrs = CvFLAGS(cv) & CVf_BUILTIN_ATTRS;
PADLIST *const temp_av = CvPADLIST(cv);
CV *const temp_cv = CvOUTSIDE(cv);
if (CvFILE(cv) && CvDYNFILE(cv)) {
Safefree(CvFILE(cv));
- }
+ }
CvFILE_set_from_cop(cv, PL_curcop);
CvSTASH_set(cv, PL_curstash);
/* inner references to PL_compcv must be fixed up ... */
pad_fixup_inner_anons(CvPADLIST(cv), PL_compcv, cv);
if (PERLDB_INTER)/* Advice debugger on the new sub. */
- ++PL_sub_generation;
+ ++PL_sub_generation;
}
else {
/* Might have had built-in attributes applied -- propagate them. */
SvRV_set(gv, (SV *)cv);
}
}
+
if (!CvHASGV(cv)) {
- if (isGV(gv)) CvGV_set(cv, gv);
+ if (isGV(gv))
+ CvGV_set(cv, gv);
else {
dVAR;
U32 hash;
if (ps) {
sv_setpvn(MUTABLE_SV(cv), ps, ps_len);
- if ( ps_utf8 ) SvUTF8_on(MUTABLE_SV(cv));
+ if ( ps_utf8 )
+ SvUTF8_on(MUTABLE_SV(cv));
}
- 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++;
- 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
- itself has a refcount. */
- CvSLABBED_off(cv);
- OpslabREFCNT_dec_padok((OPSLAB *)CvSTART(cv));
+ if (block) {
+ /* 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++;
+ 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
+ itself has a refcount. */
+ CvSLABBED_off(cv);
+ OpslabREFCNT_dec_padok((OPSLAB *)CvSTART(cv));
#ifdef PERL_DEBUG_READONLY_OPS
- slab = (OPSLAB *)CvSTART(cv);
+ slab = (OPSLAB *)CvSTART(cv);
#endif
- CvSTART(cv) = start;
- CALL_PEEP(start);
- finalize_optree(CvROOT(cv));
- S_prune_chain_head(&CvSTART(cv));
+ CvSTART(cv) = start;
+ CALL_PEEP(start);
+ finalize_optree(CvROOT(cv));
+ S_prune_chain_head(&CvSTART(cv));
- /* now that optimizer has done its work, adjust pad values */
+ /* now that optimizer has done its work, adjust pad values */
- pad_tidy(CvCLONE(cv) ? padtidy_SUBCLONE : padtidy_SUB);
+ pad_tidy(CvCLONE(cv) ? padtidy_SUBCLONE : padtidy_SUB);
+ }
attrs:
if (attrs) {
HV *stash = name && !CvNAMED(cv) && GvSTASH(CvGV(cv))
? GvSTASH(CvGV(cv))
: PL_curstash;
- if (!name) SAVEFREESV(cv);
+ if (!name)
+ SAVEFREESV(cv);
apply_attrs(stash, MUTABLE_SV(cv), attrs);
- if (!name) SvREFCNT_inc_simple_void_NN(cv);
+ if (!name)
+ SvREFCNT_inc_simple_void_NN(cv);
}
if (block && has_name) {
if (PL_parser)
PL_parser->copline = NOLINE;
LEAVE_SCOPE(floor);
+
if (!evanescent) {
#ifdef PERL_DEBUG_READONLY_OPS
- if (slab)
+ if (slab)
Slab_to_ro(slab);
#endif
- if (cv && name && CvOUTSIDE(cv) && !CvEVAL(CvOUTSIDE(cv)))
+ if (cv && name && block && CvOUTSIDE(cv) && !CvEVAL(CvOUTSIDE(cv)))
pad_add_weakref(cv);
}
return cv;
assert(!GvCVu(gv));
GvCV_set(gv, cv);
GvCVGEN(gv) = 0;
- if (!fake && HvENAME_HEK(GvSTASH(gv)))
+ if (!fake && GvSTASH(gv) && HvENAME_HEK(GvSTASH(gv)))
gv_method_changed(gv);
if (SvFAKE(gv)) {
cvgv = gv_fetchsv((SV *)gv, GV_ADDMULTI, SVt_PVCV);
op_sibling_splice(o, NULL, -1, NULL);
op_free(o);
- enter = S_alloc_LOGOP(aTHX_ OP_ENTERTRY, NULL, NULL);
+ enter = alloc_LOGOP(OP_ENTERTRY, NULL, NULL);
/* establish postfix order */
enter->op_next = (OP*)enter;
op_free(o);
return newop;
}
+
+ if ((kidtype == OP_RV2AV || kidtype == OP_PADAV) && ckWARN(WARN_SYNTAX)) {
+ SV *name = S_op_varname_subscript(aTHX_ (OP*)kid, 2);
+ if (name) {
+ /* diag_listed_as: Array passed to stat will be coerced to a scalar%s */
+ Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "%s (did you want stat %" SVf "?)",
+ array_passed_to_stat, name);
+ }
+ else {
+ /* diag_listed_as: Array passed to stat will be coerced to a scalar%s */
+ Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "%s", array_passed_to_stat);
+ }
+ }
scalar((OP *) kid);
if ((PL_hints & HINT_FILETEST_ACCESS) && OP_IS_FILETEST_ACCESS(o->op_type))
o->op_private |= OPpFT_ACCESS;
Perl_croak(aTHX_ "panic: ck_grep, type=%u", (unsigned) kid->op_type);
kid = kUNOP->op_first;
- gwop = S_alloc_LOGOP(aTHX_ type, o, LINKLIST(kid));
+ gwop = alloc_LOGOP(type, o, LINKLIST(kid));
kid->op_next = (OP*)gwop;
o->op_private = gwop->op_private = 0;
gwop->op_targ = pad_alloc(type, SVs_PADTMP);
s = SvPVX(sv);
len = SvCUR(sv);
end = s + len;
+ /* treat ::foo::bar as foo::bar */
+ if (len >= 2 && s[0] == ':' && s[1] == ':')
+ DIE(aTHX_ "Bareword in require must not start with a double-colon: \"%s\"\n", s);
+ if (s == end)
+ DIE(aTHX_ "Bareword in require maps to empty filename");
+
for (; s < end; s++) {
if (*s == ':' && s[1] == ':') {
*s = '/';
case OP_METHOD_SUPER:
case OP_METHOD_REDIR:
case OP_METHOD_REDIR_SUPER:
+ o->op_flags |= OPf_REF;
if (aop->op_type == OP_CONST) {
aop->op_private &= ~OPpCONST_STRICT;
const_class = &cSVOPx(aop)->op_sv;
|| ( SvTYPE(SvRV(cSVOPx_sv(kid))) != SVt_PVAV
&& SvTYPE(SvRV(cSVOPx_sv(kid))) != SVt_PVHV )
)
- /* we let ck_fun handle it */
- break;
+ goto bad;
+ /* FALLTHROUGH */
default:
- Perl_croak_nocontext(
+ qerror(Perl_mess(aTHX_
"Experimental %s on scalar is now forbidden",
- PL_op_desc[orig_type]);
- break;
+ PL_op_desc[orig_type]));
+ bad:
+ bad_type_pv(1, "hash or array", o, kid);
+ return o;
}
}
return ck_fun(o);
is_last = TRUE;
index_skip = action_count;
action |= MDEREF_FLAG_last;
+ if (index_type != MDEREF_INDEX_none)
+ arg--;
}
if (pass)
if (!o || o->op_opt)
return;
+
+ assert(o->op_type != OP_FREED);
+
ENTER;
SAVEOP();
SAVEVPTR(PL_curcop);
/* XXX: We avoid setting op_seq here to prevent later calls
to rpeep() from mistakenly concluding that optimisation
has already occurred. This doesn't fix the real problem,
- though (See 20010220.007). AMS 20010719 */
+ though (See 20010220.007 (#5874)). AMS 20010719 */
/* op_seq functionality is now replaced by op_opt */
o->op_opt = 0;
/* FALLTHROUGH */
/* Note that you'd normally expect targs to be
* contiguous in my($a,$b,$c), but that's not the case
* when external modules start doing things, e.g.
- i* Function::Parameters */
+ * Function::Parameters */
if (p->op_targ != base + count)
break;
assert(p->op_targ == base + count);
* SAVEt_CLEARPADRANGE in pp_padrange.
* (The sizeof() stuff will be constant-folded, and is
* intended to avoid getting "comparison is always false"
- * compiler warnings)
+ * compiler warnings. See the comments above
+ * MEM_WRAP_CHECK for more explanation on why we do this
+ * in a weird way to avoid compiler warnings.)
*/
if ( intro
&& (8*sizeof(base) >
8*sizeof(UV)-OPpPADRANGE_COUNTSHIFT-SAVE_TIGHT_SHIFT
- ? base : 0) >
+ ? (Size_t)base
+ : (UV_MAX >> (OPpPADRANGE_COUNTSHIFT+SAVE_TIGHT_SHIFT))
+ ) >
(UV_MAX >> (OPpPADRANGE_COUNTSHIFT+SAVE_TIGHT_SHIFT))
)
break;
* optimise away would have exactly the same effect as the
* padrange.
* In particular in void context, we can only optimise to
- * a padrange if see see the complete sequence
+ * a padrange if we see the complete sequence
* 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
+ * which has the net effect of leaving the markstack as it
+ * was. Not pushing onto the stack (whereas padsv does touch
* the stack) makes no difference in void context.
*/
assert(followop);
|| o->op_next->op_type == OP_NULL))
o->op_next = o->op_next->op_next;
- /* if we're an OR and our next is a AND in void context, we'll
- follow it's op_other on short circuit, same for reverse.
+ /* If we're an OR and our next is an AND in void context, we'll
+ follow its op_other on short circuit, same for reverse.
We can't do this with OP_DOR since if it's true, its return
value is the underlying value which must be evaluated
- by the next op */
+ by the next op. */
if (o->op_next &&
(
(IS_AND_OP(o) && IS_OR_OP(o->op_next))
case OP_DORASSIGN:
case OP_RANGE:
case OP_ONCE:
+ case OP_ARGDEFELEM:
while (cLOGOP->op_other->op_type == OP_NULL)
cLOGOP->op_other = cLOGOP->op_other->op_next;
DEFER(cLOGOP->op_other);
case KEY_keys: retsetpvs("\\[%@]", OP_KEYS);
case KEY_values: retsetpvs("\\[%@]", OP_VALUES);
case KEY_each: retsetpvs("\\[%@]", OP_EACH);
- case KEY_push: retsetpvs("\\@@", OP_PUSH);
- case KEY_unshift: retsetpvs("\\@@", OP_UNSHIFT);
- case KEY_pop: retsetpvs(";\\@", OP_POP);
- case KEY_shift: retsetpvs(";\\@", OP_SHIFT);
case KEY_pos: retsetpvs(";\\[$*]", OP_POS);
- case KEY_splice:
- retsetpvs("\\@;$$@", OP_SPLICE);
case KEY___FILE__: case KEY___LINE__: case KEY___PACKAGE__:
retsetpvs("", 0);
case KEY_evalbytes:
newOP(OP_CALLER,0)
)
);
+ case OP_EACH:
+ case OP_KEYS:
+ case OP_VALUES:
+ o = newUNOP(OP_AVHVSWITCH,0,argop);
+ o->op_private = opnum-OP_EACH;
+ return o;
case OP_SELECT: /* which represents OP_SSELECT as well */
if (code)
return newCONDOP(
XSRETURN(AvFILLp(av)+1);
}
+
/*
* ex: set ts=8 sts=4 sw=4 et:
*/