Move bareword checking from the peephole optimizer to finalize_optree. Fixes [perl...
authorGerard Goossen <gerard@ggoossen.net>
Tue, 9 Aug 2011 18:35:06 +0000 (20:35 +0200)
committerFather Chrysostomos <sprout@cpan.org>
Thu, 11 Aug 2011 16:07:14 +0000 (09:07 -0700)
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.

embed.fnc
op.c
proto.h
t/lib/strict/subs
t/op/sigdispatch.t

index e230910..4da1d75 100644 (file)
--- 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 fabffe1..af2f3ca 100644 (file)
--- 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 1807b2f..b267253 100644 (file)
--- 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)
index 394c8d1..84bf874 100644 (file)
@@ -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;
index d36c357..e08e35f 100644 (file)
@@ -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';