mktables: Escape literal "{" in regex

[perl5.git] / op.c

diff --git a/op.c b/op.c
index d78a46e..9d3d0fa 100644 (file)
--- a/op.c
+++ b/op.c
@@ -1620,9 +1620,6 @@ S_scalar_slice_warning(pTHX_ const OP *o)
     case OP_LOCALTIME:
     case OP_GMTIME:
     case OP_ENTEREVAL:
-    case OP_REACH:
-    case OP_RKEYS:
-    case OP_RVALUES:
        return;
     }
 
@@ -2998,7 +2995,6 @@ Perl_op_lvalue_flags(pTHX_ OP *o, I32 type, U32 flags)
        break;
 
     case OP_KEYS:
-    case OP_RKEYS:
        if (type != OP_SASSIGN && type != OP_LEAVESUBLV)
            goto nomod;
        goto lvalue_func;
@@ -3368,24 +3364,26 @@ S_dup_attrlist(pTHX_ OP *o)
 STATIC void
 S_apply_attrs(pTHX_ HV *stash, SV *target, OP *attrs)
 {
-    SV * const stashsv = stash ? newSVhek(HvNAME_HEK(stash)) : &PL_sv_no;
-
     PERL_ARGS_ASSERT_APPLY_ATTRS;
+    {
+        SV * const stashsv = newSVhek(HvNAME_HEK(stash));
 
-    /* fake up C<use attributes $pkg,$rv,@attrs> */
+        /* fake up C<use attributes $pkg,$rv,@attrs> */
 
 #define ATTRSMODULE "attributes"
 #define ATTRSMODULE_PM "attributes.pm"
 
-    Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
-                        newSVpvs(ATTRSMODULE),
-                        NULL,
-                        op_prepend_elem(OP_LIST,
-                                     newSVOP(OP_CONST, 0, stashsv),
-                                     op_prepend_elem(OP_LIST,
-                                                  newSVOP(OP_CONST, 0,
-                                                          newRV(target)),
-                                                  dup_attrlist(attrs))));
+        Perl_load_module(
+          aTHX_ PERL_LOADMOD_IMPORT_OPS,
+          newSVpvs(ATTRSMODULE),
+          NULL,
+          op_prepend_elem(OP_LIST,
+                          newSVOP(OP_CONST, 0, stashsv),
+                          op_prepend_elem(OP_LIST,
+                                          newSVOP(OP_CONST, 0,
+                                                  newRV(target)),
+                                          dup_attrlist(attrs))));
+    }
 }
 
 STATIC void
@@ -3416,7 +3414,7 @@ S_apply_attrs_my(pTHX_ HV *stash, OP *target, OP *attrs, OP **imopsp)
     pack = newSVOP(OP_CONST, 0, newSVpvs(ATTRSMODULE));
 
     /* Build up the real arg-list. */
-    stashsv = stash ? newSVhek(HvNAME_HEK(stash)) : &PL_sv_no;
+    stashsv = newSVhek(HvNAME_HEK(stash));
 
     arg = newOP(OP_PADSV, 0);
     arg->op_targ = target->op_targ;
@@ -9059,7 +9057,7 @@ Perl_newXS_deffile(pTHX_ const char *name, XSUBADDR_t subaddr)
 {
     PERL_ARGS_ASSERT_NEWXS_DEFFILE;
     return newXS_len_flags(
-       name, name ? strlen(name) : 0, subaddr, NULL, NULL, NULL, 0
+        name, strlen(name), subaddr, NULL, NULL, NULL, 0
     );
 }
 
@@ -9972,17 +9970,13 @@ Perl_ck_fun(pTHX_ OP *o)
                         || SvTYPE(SvRV(cSVOPx_sv(kid))) != SVt_PVAV  )
                        )
                    bad_type_pv(numargs, "array", o, kid);
-               /* Defer checks to run-time if we have a scalar arg */
-               if (kid->op_type == OP_RV2AV || kid->op_type == OP_PADAV)
-                   op_lvalue(kid, type);
-               else {
-                   scalar(kid);
-                   /* diag_listed_as: push on reference is experimental */
-                   Perl_ck_warner_d(aTHX_
-                                    packWARN(WARN_EXPERIMENTAL__AUTODEREF),
-                                   "%s on reference is experimental",
-                                    PL_op_desc[type]);
+               else if (kid->op_type != OP_RV2AV && kid->op_type != OP_PADAV) {
+                    yyerror_pv(Perl_form(aTHX_ "Experimental %s on scalar is now forbidden",
+                                         PL_op_desc[type]), 0);
                }
+                else {
+                    op_lvalue(kid, type);
+                }
                break;
            case OA_HVREF:
                if (kid->op_type != OP_RV2HV && kid->op_type != OP_PADHV)
@@ -11949,9 +11943,7 @@ Perl_ck_svconst(pTHX_ OP *o)
     SV * const sv = cSVOPo->op_sv;
     PERL_ARGS_ASSERT_CK_SVCONST;
     PERL_UNUSED_CONTEXT;
-#ifdef PERL_OLD_COPY_ON_WRITE
-    if (SvIsCOW(sv)) sv_force_normal(sv);
-#elif defined(PERL_NEW_COPY_ON_WRITE)
+#ifdef PERL_COPY_ON_WRITE
     /* Since the read-only flag may be used to protect a string buffer, we
        cannot do copy-on-write with existing read-only scalars that are not
        already copy-on-write scalars.  To allow $_ = "hello" to do COW with
@@ -12027,10 +12019,6 @@ Perl_ck_each(pTHX_ OP *o)
     dVAR;
     OP *kid = o->op_flags & OPf_KIDS ? cUNOPo->op_first : NULL;
     const unsigned orig_type  = o->op_type;
-    const unsigned array_type = orig_type == OP_EACH ? OP_AEACH
-                             : orig_type == OP_KEYS ? OP_AKEYS : OP_AVALUES;
-    const unsigned ref_type   = orig_type == OP_EACH ? OP_REACH
-                             : orig_type == OP_KEYS ? OP_RKEYS : OP_RVALUES;
 
     PERL_ARGS_ASSERT_CK_EACH;
 
@@ -12041,7 +12029,9 @@ Perl_ck_each(pTHX_ OP *o)
                break;
            case OP_PADAV:
            case OP_RV2AV:
-               OpTYPE_set(o, array_type);
+                OpTYPE_set(o, orig_type == OP_EACH ? OP_AEACH
+                            : orig_type == OP_KEYS ? OP_AKEYS
+                            :                        OP_AVALUES);
                break;
            case OP_CONST:
                if (kid->op_private == OPpCONST_BARE
@@ -12052,17 +12042,12 @@ Perl_ck_each(pTHX_ OP *o)
                    /* we let ck_fun handle it */
                    break;
            default:
-               OpTYPE_set(o, ref_type);
-               scalar(kid);
+                Perl_croak_nocontext(
+                    "Experimental %s on scalar is now forbidden",
+                    PL_op_desc[orig_type]);
+                break;
        }
     }
-    /* if treating as a reference, defer additional checks to runtime */
-    if (o->op_type == ref_type) {
-       /* diag_listed_as: keys on reference is experimental */
-       Perl_ck_warner_d(aTHX_ packWARN(WARN_EXPERIMENTAL__AUTODEREF),
-                             "%s is experimental", PL_op_desc[ref_type]);
-       return o;
-    }
     return ck_fun(o);
 }
 
@@ -14185,16 +14170,16 @@ Perl_core_prototype(pTHX_ SV *sv, const char *name, const int code,
     case KEY_x     : case KEY_xor    :
        if (!opnum) return NULL; nullret = TRUE; goto findopnum;
     case KEY_glob:    retsetpvs("_;", OP_GLOB);
-    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_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);
+       retsetpvs("\\@;$$@", OP_SPLICE);
     case KEY___FILE__: case KEY___LINE__: case KEY___PACKAGE__:
        retsetpvs("", 0);
     case KEY_evalbytes: