/* op.c
*
* Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
- * 2000, 2001, 2002, 2003, by Larry Wall and others
+ * 2000, 2001, 2002, 2003, 2004, by Larry Wall and others
*
* You may distribute under the terms of either the GNU General Public
* License or the Artistic License, as specified in the README file.
useless = OP_DESC(o);
break;
+ case OP_NOT:
+ kid = cUNOPo->op_first;
+ if (kid->op_type != OP_MATCH && kid->op_type != OP_SUBST &&
+ kid->op_type != OP_TRANS) {
+ goto func_ops;
+ }
+ useless = "negative pattern binding (!~)";
+ break;
+
case OP_RV2GV:
case OP_RV2SV:
case OP_RV2AV:
else {
if (ckWARN(WARN_VOID)) {
useless = "a constant";
+ /* don't warn on optimised away booleans, eg
+ * use constant Foo, 5; Foo || print; */
+ if (cSVOPo->op_private & OPpCONST_SHORTCIRCUIT)
+ useless = 0;
/* the constants 0 and 1 are permitted as they are
conventionally used as dummies in constructs like
1 while some_condition_with_side_effects; */
- if (SvNIOK(sv) && (SvNV(sv) == 0.0 || SvNV(sv) == 1.0))
+ else if (SvNIOK(sv) && (SvNV(sv) == 0.0 || SvNV(sv) == 1.0))
useless = 0;
else if (SvPOK(sv)) {
/* perl4's way of mixing documentation and code
return o;
}
+/* XXX kept for BINCOMPAT only */
void
Perl_save_hints(pTHX)
{
- SAVEI32(PL_hints);
- SAVESPTR(GvHV(PL_hintgv));
- GvHV(PL_hintgv) = newHVhv(GvHV(PL_hintgv));
- SAVEFREESV(GvHV(PL_hintgv));
+ Perl_croak(aTHX_ "internal error: obsolete function save_hints() called");
}
int
op_free(right);
return Nullop;
}
+ /* optimise C<my @x = ()> to C<my @x>, and likewise for hashes */
+ if ((left->op_type == OP_PADAV || left->op_type == OP_PADHV)
+ && right->op_type == OP_STUB
+ && (left->op_private & OPpLVAL_INTRO))
+ {
+ op_free(right);
+ left->op_flags &= ~(OPf_REF|OPf_SPECIAL);
+ return left;
+ }
curop = list(force_list(left));
o = newBINOP(OP_AASSIGN, flags, list(force_list(right)), curop);
o->op_private = (U8)(0 | (flags >> 8));
}
}
- o = prepend_elem(OP_LINESEQ, (OP*)cop, o);
- CHECKOP(cop->op_type, cop);
- return o;
+ return prepend_elem(OP_LINESEQ, (OP*)cop, o);
}
no_bareword_allowed(first);
else if (ckWARN(WARN_BAREWORD) && (first->op_private & OPpCONST_BARE))
Perl_warner(aTHX_ packWARN(WARN_BAREWORD), "Bareword found in conditional");
- if ((type == OP_AND) == (SvTRUE(((SVOP*)first)->op_sv))) {
+ if ((type == OP_AND && SvTRUE(((SVOP*)first)->op_sv)) ||
+ (type == OP_OR && !SvTRUE(((SVOP*)first)->op_sv)) ||
+ (type == OP_DOR && !SvOK(((SVOP*)first)->op_sv))) {
op_free(first);
*firstp = Nullop;
+ if (other->op_type == OP_CONST)
+ other->op_private |= OPpCONST_SHORTCIRCUIT;
return other;
}
else {
+ /* check for C<my $x if 0>, or C<my($x,$y) if 0> */
+ OP *o2 = other;
+ if ( ! (o2->op_type == OP_LIST
+ && (( o2 = cUNOPx(o2)->op_first))
+ && o2->op_type == OP_PUSHMARK
+ && (( o2 = o2->op_sibling)) )
+ )
+ o2 = other;
+ if ((o2->op_type == OP_PADSV || o2->op_type == OP_PADAV
+ || o2->op_type == OP_PADHV)
+ && o2->op_private & OPpLVAL_INTRO
+ && ckWARN(WARN_DEPRECATED))
+ {
+ Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
+ "Deprecated use of my() in false conditional");
+ }
+
op_free(other);
*otherp = Nullop;
+ if (first->op_type == OP_CONST)
+ first->op_private |= OPpCONST_SHORTCIRCUIT;
return first;
}
}
}
}
+ /* if block is null, the next append_elem() would put UNSTACK, a scalar
+ * op, in listop. This is wrong. [perl #27024] */
+ if (!block)
+ block = newOP(OP_NULL, 0);
listop = append_elem(OP_LINESEQ, block, newOP(OP_UNSTACK, 0));
o = new_logop(OP_AND, 0, &expr, &listop);
Perl_sv_catpvf(aTHX_ msg, " sub %"SVf, name);
if (SvPOK(cv))
Perl_sv_catpvf(aTHX_ msg, " (%"SVf")", (SV *)cv);
+ else
+ Perl_sv_catpvf(aTHX_ msg, ": none");
sv_catpv(msg, " vs ");
if (p)
Perl_sv_catpvf(aTHX_ msg, "(%s)", p);
gv_fetchpv(SvPVx(kid->op_sv, n_a), TRUE, SVt_PVIO));
op_free(o);
o = newop;
+ return o;
}
else {
if ((PL_hints & HINT_FILETEST_ACCESS) &&
OP* k;
o = ck_sort(o);
kid = cLISTOPo->op_first->op_sibling;
- for (k = cLISTOPo->op_first->op_sibling->op_next; k; k = k->op_next) {
+ for (k = cUNOPx(kid)->op_first; k; k = k->op_next) {
kid = k;
}
kid->op_next = (OP*)gwop;
return kid;
}
}
+ /* optimise C<my $x = undef> to C<my $x> */
+ if (kid->op_type == OP_UNDEF) {
+ OP *kkid = kid->op_sibling;
+ if (kkid && kkid->op_type == OP_PADSV
+ && (kkid->op_private & OPpLVAL_INTRO))
+ {
+ cLISTOPo->op_first = NULL;
+ kid->op_sibling = NULL;
+ op_free(o);
+ op_free(kid);
+ return kkid;
+ }
+ }
return o;
}
}
OP *
-Perl_ck_state(pTHX_ OP *o)
-{
- /* warn on C<my $x=1 if foo;> , C<$a && my $x=1;> style statements */
- OP *kid;
- o = o->op_sibling;
- if (!o || o->op_type != OP_NULL || !(o->op_flags & OPf_KIDS))
- return o;
- kid = cUNOPo->op_first;
- if (!(kid->op_type == OP_AND || kid->op_type == OP_OR))
- return o;
- kid = kUNOP->op_first->op_sibling;
- if (kid->op_type == OP_SASSIGN)
- kid = kBINOP->op_first->op_sibling;
- else if (kid->op_type == OP_AASSIGN)
- kid = kBINOP->op_first->op_sibling;
-
- if (kid->op_type == OP_LIST
- || (kid->op_type == OP_NULL && kid->op_targ == OP_LIST))
- {
- kid = kUNOP->op_first;
- if (kid->op_type == OP_PUSHMARK)
- kid = kid->op_sibling;
- }
- if ((kid->op_type == OP_PADSV || kid->op_type == OP_PADAV
- || kid->op_type == OP_PADHV)
- && (kid->op_private & OPpLVAL_INTRO)
- && (ckWARN(WARN_DEPRECATED)))
- {
- Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
- "Deprecated use of my() in conditional");
- }
- return o;
-}
-
-
-OP *
Perl_ck_subr(pTHX_ OP *o)
{
OP *prev = ((cUNOPo->op_first->op_sibling)
o->op_next : o->op_next->op_next;
IV i;
if (pop && pop->op_type == OP_CONST &&
- (PL_op = pop->op_next) &&
+ ((PL_op = pop->op_next)) &&
pop->op_next->op_type == OP_AELEM &&
!(pop->op_next->op_private &
(OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB)) &&
i >= 0)
{
GV *gv;
+ if (cSVOPx(pop)->op_private & OPpCONST_STRICT)
+ no_bareword_allowed(pop);
if (o->op_type == OP_GV)
op_null(o->op_next);
op_null(pop->op_next);
|| (o2->op_flags & OPf_WANT) != OPf_WANT_VOID)
break;
+ /* check that the sort is the first arg on RHS of assign */
+
+ o2 = cUNOPx(o2)->op_first;
+ if (!o2 || o2->op_type != OP_NULL)
+ break;
+ o2 = cUNOPx(o2)->op_first;
+ if (!o2 || o2->op_type != OP_PUSHMARK)
+ break;
+ if (o2->op_sibling != o)
+ break;
+
/* check the array is the same on both sides */
if (oleft->op_type == OP_RV2AV) {
if (oright->op_type != OP_RV2AV