This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
https://perl5.git.perl.org / perl5.git / blobdiff
? search:
summary | shortlog | log | commit | commitdiff | tree
raw | inline | side by side
Porting/todo.pod: Point out problem with readpipe(LIST)
[perl5.git] / op.c
diff --git a/op.c b/op.c
index 7014e61..6986610 100644 (file)
--- a/op.c
+++ b/op.c
@@ -1532,8 +1532,11 @@ S_scalarboolean(pTHX_ OP *o)
 {
     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);
 
@@ -2977,9 +2980,15 @@ Perl_op_lvalue_flags(pTHX_ OP *o, I32 type, U32 flags)
        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)
@@ -3223,6 +3232,12 @@ S_scalar_mod_type(const OP *o, I32 type)
     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:
@@ -3656,7 +3671,7 @@ S_my_kid(pTHX_ OP *o, OP *attrs, OP **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) {
@@ -4342,13 +4357,23 @@ S_fold_constants(pTHX_ OP *o)
        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;
        }
     }
@@ -6747,24 +6772,7 @@ S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp)
        || 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)
@@ -6865,6 +6873,25 @@ S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp)
     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));
@@ -8454,10 +8481,12 @@ Perl_newATTRSUB_x(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs,
            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);
@@ -11940,13 +11969,14 @@ Perl_ck_each(pTHX_ OP *o)
                 || (  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);
@@ -14593,13 +14623,7 @@ Perl_core_prototype(pTHX_ SV *sv, const char *name, const int code,
     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:
@@ -14679,6 +14703,12 @@ Perl_coresub_op(pTHX_ SV * const coreargssv, const int code,
                                  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(
Unnamed repository; edit this file 'description' to name the repository.