Upgrade to Cwd 2.17_03

[p5sagit/p5-mst-13.2.git] / op.c

diff --git a/op.c b/op.c
index c8a74fd..cdc0749 100644 (file)
--- a/op.c
+++ b/op.c
@@ -1,7 +1,7 @@
 /*    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.
@@ -661,6 +661,15 @@ Perl_scalarvoid(pTHX_ OP *o)
            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:
@@ -1763,13 +1772,11 @@ Perl_scope(pTHX_ OP *o)
     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
@@ -3126,6 +3133,15 @@ Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right)
            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));
@@ -3362,16 +3378,37 @@ S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp)
            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;
-           other->op_private |= OPpCONST_SHORTCIRCUIT;
+           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;
-           first->op_private |= OPpCONST_SHORTCIRCUIT;
+           if (first->op_type == OP_CONST)
+               first->op_private |= OPpCONST_SHORTCIRCUIT;
            return first;
        }
     }
@@ -3894,6 +3931,8 @@ Perl_cv_ckproto(pTHX_ CV *cv, GV *gv, char *p)
            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);
@@ -5059,6 +5098,7 @@ Perl_ck_ftst(pTHX_ OP *o)
                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) &&
@@ -5401,7 +5441,7 @@ Perl_ck_grep(pTHX_ OP *o)
        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;
@@ -5574,6 +5614,19 @@ Perl_ck_sassign(pTHX_ OP *o)
            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;
 }
 
@@ -6386,7 +6439,7 @@ Perl_peep(pTHX_ register OP *o)
                            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)) &&
@@ -6395,6 +6448,8 @@ Perl_peep(pTHX_ register OP *o)
                    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);
@@ -6587,6 +6642,17 @@ Perl_peep(pTHX_ register OP *o)
                    || (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