Move bareword checking from the peephole optimizer to finalize_optree. Fixes [perl #95998]

The bareword checking is moved from the peephole optimizer to finalize_optree.
newRANGE needs additional bareword checking because the constants may
be optimized away by 'gen_constant_list'.
The OPpCONST_STRICT flag is removed after giving an error about a
bareword to prevent giving multiple errors about the same bareword.

5 files changed, 17 insertions, 12 deletions

diff --git a/embed.fnc b/embed.fnc
index e2309108b4..4da1d75eec 100644
--- a/embed.fnc
+++ b/embed.fnc
@@ -1641,7 +1641,7 @@ s	|OP *	|dup_attrlist	|NN OP *o
 s	|void	|apply_attrs	|NN HV *stash|NN SV *target|NULLOK OP *attrs|bool for_my
 s	|void	|apply_attrs_my	|NN HV *stash|NN OP *target|NULLOK OP *attrs|NN OP **imopsp
 s	|void	|bad_type	|I32 n|NN const char *t|NN const char *name|NN const OP *kid
-s	|void	|no_bareword_allowed|NN const OP *o
+s	|void	|no_bareword_allowed|NN OP *o
 sR	|OP*	|no_fh_allowed|NN OP *o
 sR	|OP*	|too_few_arguments|NN OP *o|NN const char* name
 sR	|OP*	|too_many_arguments|NN OP *o|NN const char* name
diff --git a/op.c b/op.c
index fabffe10aa..af2f3cac57 100644
--- a/op.c
+++ b/op.c
@@ -365,7 +365,7 @@ S_bad_type(pTHX_ I32 n, const char *t, const char *name, const OP *kid)
 }
 
 STATIC void
-S_no_bareword_allowed(pTHX_ const OP *o)
+S_no_bareword_allowed(pTHX_ OP *o)
 {
     PERL_ARGS_ASSERT_NO_BAREWORD_ALLOWED;
 
@@ -374,6 +374,7 @@ S_no_bareword_allowed(pTHX_ const OP *o)
     qerror(Perl_mess(aTHX_
 		     "Bareword \"%"SVf"\" not allowed while \"strict subs\" in use",
 		     SVfARG(cSVOPo_sv)));
+    o->op_private &= ~OPpCONST_STRICT; /* prevent warning twice about the same OP */
 }
 
 /* "register" allocation */
@@ -1479,6 +1480,9 @@ S_finalize_op(pTHX_ OP* o)
 	break;
 
     case OP_CONST:
+	if (cSVOPo->op_private & OPpCONST_STRICT)
+	    no_bareword_allowed(o);
+	/* FALLTHROUGH */
 #ifdef USE_ITHREADS
     case OP_HINTSEVAL:
     case OP_METHOD_NAMED:
@@ -5565,6 +5569,12 @@ Perl_newRANGE(pTHX_ I32 flags, OP *left, OP *right)
     flip->op_private =  left->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
     flop->op_private = right->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
 
+    /* check barewords before they might be optimized aways */
+    if (flip->op_private && cSVOPx(left)->op_private & OPpCONST_STRICT)
+	no_bareword_allowed(left);
+    if (flop->op_private && cSVOPx(right)->op_private & OPpCONST_STRICT)
+	no_bareword_allowed(right);
+
     flip->op_next = o;
     if (!flip->op_private || !flop->op_private)
 	LINKLIST(o);		/* blow off optimizer unless constant */
@@ -9669,11 +9679,6 @@ Perl_rpeep(pTHX_ register OP *o)
 	    }
 	    break;
 
-	case OP_CONST:
-	    if (cSVOPo->op_private & OPpCONST_STRICT)
-		no_bareword_allowed(o);
-	    break;
-
 	case OP_CONCAT:
 	    if (o->op_next && o->op_next->op_type == OP_STRINGIFY) {
 		if (o->op_next->op_private & OPpTARGET_MY) {
diff --git a/proto.h b/proto.h
index 1807b2f4a6..b267253edd 100644
--- a/proto.h
+++ b/proto.h
@@ -5552,7 +5552,7 @@ STATIC OP*	S_new_logop(pTHX_ I32 type, I32 flags, OP **firstp, OP **otherp)
 #define PERL_ARGS_ASSERT_NEW_LOGOP	\
 	assert(firstp); assert(otherp)
 
-STATIC void	S_no_bareword_allowed(pTHX_ const OP *o)
+STATIC void	S_no_bareword_allowed(pTHX_ OP *o)
 			__attribute__nonnull__(pTHX_1);
 #define PERL_ARGS_ASSERT_NO_BAREWORD_ALLOWED	\
 	assert(o)
diff --git a/t/lib/strict/subs b/t/lib/strict/subs
index 394c8d1390..84bf874b25 100644
--- a/t/lib/strict/subs
+++ b/t/lib/strict/subs
@@ -433,7 +433,7 @@ foo:
 ret
 bar
 ########
-# TODO infinite loop breaks some strict checking
+# infinite loop breaks some strict checking
 use strict 'subs';
 sub foo {
     1 while 1;
diff --git a/t/op/sigdispatch.t b/t/op/sigdispatch.t
index d36c357fd2..e08e35f3af 100644
--- a/t/op/sigdispatch.t
+++ b/t/op/sigdispatch.t
@@ -50,7 +50,7 @@ SKIP: {
     
     my $gotit = 0;
     $SIG{USR1} = sub { $gotit++ };
-    kill SIGUSR1, $$;
+    kill 'SIGUSR1', $$;
     is $gotit, 0, 'Haven\'t received third signal yet';
     
     my $old = POSIX::SigSet->new();
@@ -58,7 +58,7 @@ SKIP: {
     is $gotit, 1, 'Received third signal';
     
 	{
-		kill SIGUSR1, $$;
+		kill 'SIGUSR1', $$;
 		local $SIG{USR1} = sub { die "FAIL\n" };
 		POSIX::sigprocmask(&POSIX::SIG_BLOCK, undef, $old);
 		ok $old->ismember(&POSIX::SIGUSR1), 'SIGUSR1 is blocked';
@@ -73,7 +73,7 @@ TODO:
 	}
 
     POSIX::sigprocmask(&POSIX::SIG_BLOCK, $new);
-    kill SIGUSR1, $$;
+    kill 'SIGUSR1', $$;
     is $gotit, 1, 'Haven\'t received fifth signal yet';
     POSIX::sigprocmask(&POSIX::SIG_UNBLOCK, $new, $old);
     ok $old->ismember(&POSIX::SIGUSR1), 'SIGUSR1 was still blocked';