#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()
*/
{
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 :-) */
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)];
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)
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:
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) {
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;
}
}
|| 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 */
+ /* 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 = S_alloc_LOGOP(aTHX_ type, first, LINKLIST(other));
logop->op_flags |= (U8)flags;
logop->op_private = (U8)(1 | (flags >> 8));
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);
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;
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 = '/';
|| ( SvTYPE(SvRV(cSVOPx_sv(kid))) != SVt_PVAV
&& SvTYPE(SvRV(cSVOPx_sv(kid))) != SVt_PVHV )
)
- /* we let ck_fun handle it */
- break;
+ goto bad;
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);
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(
https://perl5.git.perl.org / perl5.git / blobdiff