do subname() is deprecated, so update this hunk of test dating from perl 1.

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

diff --git a/op.c b/op.c
index 35b7c95..796bec3 100644 (file)
--- a/op.c
+++ b/op.c
@@ -5583,10 +5583,9 @@ Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
                                           maximum a prototype before. */
        if (SvTYPE(gv) > SVt_NULL) {
            if (!SvPOK((const SV *)gv)
-               && !(SvIOK((const SV *)gv) && SvIVX((const SV *)gv) == -1)
-               && ckWARN_d(WARN_PROTOTYPE))
+               && !(SvIOK((const SV *)gv) && SvIVX((const SV *)gv) == -1))
            {
-               Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "Runaway prototype");
+               Perl_ck_warner_d(aTHX_ packWARN(WARN_PROTOTYPE), "Runaway prototype");
            }
            cv_ckproto_len((const CV *)gv, NULL, ps, ps_len);
        }
@@ -6219,8 +6218,7 @@ Perl_oopsAV(pTHX_ OP *o)
        break;
 
     default:
-       if (ckWARN_d(WARN_INTERNAL))
-           Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsAV");
+       Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsAV");
        break;
     }
     return o;
@@ -6248,8 +6246,7 @@ Perl_oopsHV(pTHX_ OP *o)
        break;
 
     default:
-       if (ckWARN_d(WARN_INTERNAL))
-           Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsHV");
+       Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsHV");
        break;
     }
     return o;
@@ -6848,7 +6845,7 @@ Perl_ck_fun(pTHX_ OP *o)
                {
                    OP * const newop = newAVREF(newGVOP(OP_GV, 0,
                        gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVAV) ));
-                   Perl_ck_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
+                   Perl_ck_warner(aTHX_ packWARN(WARN_DEPRECATED),
                                   "Array @%"SVf" missing the @ in argument %"IVdf" of %s()",
                                   SVfARG(((SVOP*)kid)->op_sv), (IV)numargs, PL_op_desc[type]);
 #ifdef PERL_MAD
@@ -6870,7 +6867,7 @@ Perl_ck_fun(pTHX_ OP *o)
                {
                    OP * const newop = newHVREF(newGVOP(OP_GV, 0,
                        gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVHV) ));
-                   Perl_ck_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
+                   Perl_ck_warner(aTHX_ packWARN(WARN_DEPRECATED),
                                   "Hash %%%"SVf" missing the %% in argument %"IVdf" of %s()",
                                   SVfARG(((SVOP*)kid)->op_sv), (IV)numargs, PL_op_desc[type]);
 #ifdef PERL_MAD
@@ -7218,9 +7215,9 @@ Perl_ck_defined(pTHX_ OP *o)              /* 19990527 MJD */
            break;                      /* Globals via GV can be undef */
        case OP_PADAV:
        case OP_AASSIGN:                /* Is this a good idea? */
-           Perl_ck_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
+           Perl_ck_warner(aTHX_ packWARN(WARN_DEPRECATED),
                           "defined(@array) is deprecated");
-           Perl_ck_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
+           Perl_ck_warner(aTHX_ packWARN(WARN_DEPRECATED),
                           "\t(Maybe you should just omit the defined()?)\n");
        break;
        case OP_RV2HV:
@@ -7230,9 +7227,9 @@ Perl_ck_defined(pTHX_ OP *o)              /* 19990527 MJD */
               */
            break;                      /* Globals via GV can be undef */
        case OP_PADHV:
-           Perl_ck_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
+           Perl_ck_warner(aTHX_ packWARN(WARN_DEPRECATED),
                           "defined(%%hash) is deprecated");
-           Perl_ck_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
+           Perl_ck_warner(aTHX_ packWARN(WARN_DEPRECATED),
                           "\t(Maybe you should just omit the defined()?)\n");
            break;
        default:
@@ -8279,6 +8276,33 @@ Perl_ck_each(pTHX_ OP *o)
     return ck_fun(o);
 }
 
+/* caller is supposed to assign the return to the 
+   container of the rep_op var */
+OP *
+S_opt_scalarhv(pTHX_ OP *rep_op) {
+    UNOP *unop;
+
+    PERL_ARGS_ASSERT_OPT_SCALARHV;
+
+    NewOp(1101, unop, 1, UNOP);
+    unop->op_type = (OPCODE)OP_BOOLKEYS;
+    unop->op_ppaddr = PL_ppaddr[OP_BOOLKEYS];
+    unop->op_flags = (U8)(OPf_WANT_SCALAR | OPf_KIDS );
+    unop->op_private = (U8)(1 | ((OPf_WANT_SCALAR | OPf_KIDS) >> 8));
+    unop->op_first = rep_op;
+    unop->op_next = rep_op->op_next;
+    rep_op->op_next = (OP*)unop;
+    rep_op->op_flags|=(OPf_REF | OPf_MOD);
+    unop->op_sibling = rep_op->op_sibling;
+    rep_op->op_sibling = NULL;
+    /* unop->op_targ = pad_alloc(OP_BOOLKEYS, SVs_PADTMP); */
+    if (rep_op->op_type == OP_PADHV) { 
+        rep_op->op_flags &= ~OPf_WANT_SCALAR;
+        rep_op->op_flags |= OPf_WANT_LIST;
+    }
+    return (OP*)unop;
+}                        
+
 /* A peephole optimizer.  We visit the ops in the order they're to execute.
  * See the comments at the top of this file for more details about when
  * peep() is called */
@@ -8465,12 +8489,67 @@ Perl_peep(pTHX_ register OP *o)
            }
 
            break;
+        
+        {
+            OP *fop;
+            OP *sop;
+            
+        case OP_NOT:
+            fop = cUNOP->op_first;
+            sop = NULL;
+            goto stitch_keys;
+            break;
 
-       case OP_MAPWHILE:
-       case OP_GREPWHILE:
-       case OP_AND:
+        case OP_AND:
        case OP_OR:
        case OP_DOR:
+            fop = cLOGOP->op_first;
+            sop = fop->op_sibling;
+           while (cLOGOP->op_other->op_type == OP_NULL)
+               cLOGOP->op_other = cLOGOP->op_other->op_next;
+           peep(cLOGOP->op_other); /* Recursive calls are not replaced by fptr calls */
+          
+          stitch_keys:     
+           o->op_opt = 1;
+            if ((fop->op_type == OP_PADHV || fop->op_type == OP_RV2HV)
+                || ( sop && 
+                     (sop->op_type == OP_PADHV || sop->op_type == OP_RV2HV)
+                    )
+            ){ 
+                OP * nop = o;
+                OP * lop = o;
+                if (!(nop->op_flags && OPf_WANT_VOID)) {
+                    while (nop && nop->op_next) {
+                        switch (nop->op_next->op_type) {
+                            case OP_NOT:
+                            case OP_AND:
+                            case OP_OR:
+                            case OP_DOR:
+                                lop = nop = nop->op_next;
+                                break;
+                            case OP_NULL:
+                                nop = nop->op_next;
+                                break;
+                            default:
+                                nop = NULL;
+                                break;
+                        }
+                    }            
+                }
+                if (lop->op_flags && OPf_WANT_VOID) {
+                    if (fop->op_type == OP_PADHV || fop->op_type == OP_RV2HV) 
+                        cLOGOP->op_first = opt_scalarhv(fop);
+                    if (sop && (sop->op_type == OP_PADHV || sop->op_type == OP_RV2HV)) 
+                        cLOGOP->op_first->op_sibling = opt_scalarhv(sop);
+                }                                        
+            }                  
+            
+           
+           break;
+       }    
+       
+       case OP_MAPWHILE:
+       case OP_GREPWHILE:
        case OP_ANDASSIGN:
        case OP_ORASSIGN:
        case OP_DORASSIGN: