redo change#2061 and parts of change#1169 with code in the

parser; PL_last_proto hackery gone, strict 'subs' in now
implemented in the optimizer where specifying the exceptional
cases is much more robust; '*' (bareword) prototype now works
reliably when used in second and subsequent arguments

p4raw-link: @2061 on //depot/perl: bf8481137c02593eb36f8d0e234a2ec41a1c92e4
p4raw-link: @1169 on //depot/perl: 2a841d1398ee9bbf30a942905192cc2591b3e92a

p4raw-id: //depot/perl@3447

diff --git a/dump.c b/dump.c
index cb3a643..cc6682a 100644 (file)
--- a/dump.c
+++ b/dump.c
@@ -481,6 +481,8 @@ do_op_dump(I32 level, PerlIO *file, OP *o)
        else if (o->op_type == OP_CONST) {
            if (o->op_private & OPpCONST_BARE)
                sv_catpv(tmpsv, ",BARE");
+           if (o->op_private & OPpCONST_STRICT)
+               sv_catpv(tmpsv, ",STRICT");
        }
        else if (o->op_type == OP_FLIP) {
            if (o->op_private & OPpFLIP_LINENUM)

diff --git a/embed.h b/embed.h
index 8c2474a..e413efc 100644 (file)
--- a/embed.h
+++ b/embed.h
@@ -1452,6 +1452,7 @@
 #define nextargv               CPerlObj::Perl_nextargv
 #define nextchar               CPerlObj::Perl_nextchar
 #define ninstr                 CPerlObj::Perl_ninstr
+#define no_bareword_allowed    CPerlObj::Perl_no_bareword_allowed
 #define no_fh_allowed          CPerlObj::Perl_no_fh_allowed
 #define no_op                  CPerlObj::Perl_no_op
 #define not_a_number           CPerlObj::Perl_not_a_number

diff --git a/embed.pl b/embed.pl
index 2fde0dd..028e217 100755 (executable)
--- a/embed.pl
+++ b/embed.pl
@@ -313,6 +313,7 @@ my @staticfuncs = qw(
     bad_type
     modkids
     no_fh_allowed
+    no_bareword_allowed
     scalarboolean
     too_few_arguments
     too_many_arguments

diff --git a/objXSUB.h b/objXSUB.h
index f037d3a..a74e8ee 100644 (file)
--- a/objXSUB.h
+++ b/objXSUB.h
@@ -1765,6 +1765,8 @@
 #define nextchar               pPerl->Perl_nextchar
 #undef  ninstr
 #define ninstr                 pPerl->Perl_ninstr
+#undef  no_bareword_allowed
+#define no_bareword_allowed    pPerl->Perl_no_bareword_allowed
 #undef  no_fh_allowed
 #define no_fh_allowed          pPerl->Perl_no_fh_allowed
 #undef  no_op

diff --git a/op.c b/op.c
index 94c0b39..0697764 100644 (file)
--- a/op.c
+++ b/op.c
@@ -66,6 +66,7 @@ static I32 list_assignment _((OP *o));
 static void bad_type _((I32 n, char *t, char *name, OP *kid));
 static OP *modkids _((OP *o, I32 type));
 static OP *no_fh_allowed _((OP *o));
+static void no_bareword_allowed _((OP *o));
 static OP *scalarboolean _((OP *o));
 static OP *too_few_arguments _((OP *o, char* name));
 static OP *too_many_arguments _((OP *o, char* name));
@@ -116,6 +117,14 @@ bad_type(I32 n, char *t, char *name, OP *kid)
                 (int)n, name, t, PL_op_desc[kid->op_type]));
 }
 
+STATIC void
+no_bareword_allowed(OP *o)
+{
+    warn("Bareword \"%s\" not allowed while \"strict subs\" in use",
+         SvPV_nolen(cSVOPo->op_sv));
+    ++PL_error_count;
+}
+
 void
 assertref(OP *o)
 {
@@ -987,7 +996,9 @@ scalarvoid(OP *o)
 
     case OP_CONST:
        sv = cSVOPo->op_sv;
-       {
+       if (cSVOPo->op_private & OPpCONST_STRICT)
+           no_bareword_allowed(o);
+       else {
            dTHR;
            if (ckWARN(WARN_VOID)) {
                useless = "a constant";
@@ -1841,6 +1852,10 @@ fold_constants(register OP *o)
        goto nope;
 
     switch (type) {
+    case OP_NEGATE:
+       /* XXX might want a ck_negate() for this */
+       cUNOPo->op_first->op_private &= ~OPpCONST_STRICT;
+       break;
     case OP_SPRINTF:
     case OP_UCFIRST:
     case OP_LCFIRST:
@@ -1861,10 +1876,11 @@ fold_constants(register OP *o)
 
     for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
        if (curop->op_type != OP_CONST &&
-               curop->op_type != OP_LIST &&
-               curop->op_type != OP_SCALAR &&
-               curop->op_type != OP_NULL &&
-               curop->op_type != OP_PUSHMARK) {
+           curop->op_type != OP_LIST &&
+           curop->op_type != OP_SCALAR &&
+           curop->op_type != OP_NULL &&
+           curop->op_type != OP_PUSHMARK)
+       {
            goto nope;
        }
     }
@@ -5356,6 +5372,10 @@ ck_subr(OP *o)
            }
        }
     }
+    else if (cvop->op_type == OP_METHOD) {
+       if (o2->op_type == OP_CONST)
+           o2->op_private &= ~OPpCONST_STRICT;
+    }
     o->op_private |= (PL_hints & HINT_STRICT_REFS);
     if (PERLDB_SUB && PL_curstash != PL_debstash)
        o->op_private |= OPpENTERSUB_DB;
@@ -5390,6 +5410,8 @@ ck_subr(OP *o)
                arg++;
                if (o2->op_type == OP_RV2GV)
                    goto wrapref;       /* autoconvert GLOB -> GLOBref */
+               else if (o2->op_type == OP_CONST)
+                   o2->op_private &= ~OPpCONST_STRICT;
                scalar(o2);
                break;
            case '\\':
@@ -5502,8 +5524,11 @@ peep(register OP *o)
            o->op_seq = PL_op_seqmax++;
            break;
 
-       case OP_CONCAT:
        case OP_CONST:
+           if (cSVOPo->op_private & OPpCONST_STRICT)
+               no_bareword_allowed(o);
+           /* FALL THROUGH */
+       case OP_CONCAT:
        case OP_JOIN:
        case OP_UC:
        case OP_UCFIRST:

diff --git a/op.h b/op.h
index 67e636f..03ea2af 100644 (file)
--- a/op.h
+++ b/op.h
@@ -123,12 +123,14 @@ typedef U32 PADOFFSET;
 #define OPpDEREF_SV            (32|64) /*   Want ref to SV. */
   /* OP_ENTERSUB only */
 #define OPpENTERSUB_DB         16      /* Debug subroutine. */
+  /* OP_RV2CV only */
 #define OPpENTERSUB_AMPER      8       /* Used & form to call. */
   /* OP_?ELEM only */
 #define OPpLVAL_DEFER          16      /* Defer creation of array/hash elem */
   /* for OP_RV2?V, lower bits carry hints */
 
 /* Private for OP_CONST */
+#define        OPpCONST_STRICT         8       /* bearword subject to strict 'subs' */
 #define OPpCONST_ENTERED       16      /* Has been entered as symbol. */
 #define OPpCONST_ARYBASE       32      /* Was a $[ translated to constant. */
 #define OPpCONST_BARE          64      /* Was a bare word (filehandle?). */

diff --git a/proto.h b/proto.h
index ea364f1..6ec5b37 100644 (file)
--- a/proto.h
+++ b/proto.h
@@ -821,6 +821,7 @@ CV *get_db_sub _((SV **svp, CV *cv));
 I32 list_assignment _((OP *o));
 void bad_type _((I32 n, char *t, char *name, OP *kid));
 OP *modkids _((OP *o, I32 type));
+void no_bareword_allowed _((OP *o));
 OP *no_fh_allowed _((OP *o));
 OP *scalarboolean _((OP *o));
 OP *too_few_arguments _((OP *o, char* name));

diff --git a/toke.c b/toke.c
index 739c666..df45a56 100644 (file)
--- a/toke.c
+++ b/toke.c
@@ -3186,13 +3186,9 @@ int yylex(PERL_YYLEX_PARAM_DECL)
                s = skipspace(s);
                if (*s == '(') {
                    CLINE;
-                   PL_last_proto = Nullch;
                    if (gv && GvCVu(gv)) {
-                       CV *cv;
-                       if ((cv = GvCV(gv)) && SvPOK(cv))
-                           PL_last_proto = SvPV((SV*)cv, n_a);
                        for (d = s + 1; *d == ' ' || *d == '\t'; d++) ;
-                       if (*d == ')' && (sv = cv_const_sv(cv))) {
+                       if (*d == ')' && (sv = cv_const_sv(GvCV(gv)))) {
                            s = d + 1;
                            goto its_constant;
                        }
@@ -3201,7 +3197,6 @@ int yylex(PERL_YYLEX_PARAM_DECL)
                    PL_expect = XOPERATOR;
                    force_next(WORD);
                    yylval.ival = 0;
-                   PL_last_lop_op = OP_ENTERSUB;
                    TOKEN('&');
                }
 
@@ -3225,9 +3220,6 @@ int yylex(PERL_YYLEX_PARAM_DECL)
                    if (lastchar == '-')
                        warn("Ambiguous use of -%s resolved as -&%s()",
                                PL_tokenbuf, PL_tokenbuf);
-                   PL_last_lop = PL_oldbufptr;
-                   PL_last_lop_op = OP_ENTERSUB;
-                   PL_last_proto = Nullch;
                    /* Check for a constant sub */
                    cv = GvCV(gv);
                    if ((sv = cv_const_sv(cv))) {
@@ -3241,16 +3233,17 @@ int yylex(PERL_YYLEX_PARAM_DECL)
                    /* Resolve to GV now. */
                    op_free(yylval.opval);
                    yylval.opval = newCVREF(0, newGVOP(OP_GV, 0, gv));
+                   PL_last_lop = PL_oldbufptr;
                    PL_last_lop_op = OP_ENTERSUB;
                    /* Is there a prototype? */
                    if (SvPOK(cv)) {
                        STRLEN len;
-                       PL_last_proto = SvPV((SV*)cv, len);
+                       char *proto = SvPV((SV*)cv, len);
                        if (!len)
                            TERM(FUNC0SUB);
-                       if (strEQ(PL_last_proto, "$"))
+                       if (strEQ(proto, "$"))
                            OPERATOR(UNIOPSUB);
-                       if (*PL_last_proto == '&' && *s == '{') {
+                       if (*proto == '&' && *s == '{') {
                            sv_setpv(PL_subname,"__ANON__");
                            PREBLOCK(LSTOPSUB);
                        }
@@ -3261,27 +3254,8 @@ int yylex(PERL_YYLEX_PARAM_DECL)
                    TOKEN(NOAMP);
                }
 
-               /* It could be a prototypical bearword. */
-               if (PL_last_lop_op == OP_ENTERSUB && PL_last_proto &&
-                   PL_last_proto[PL_last_proto[0] == ';' ? 1 : 0] == '*')
-               {
-                   PL_last_proto = Nullch;
-                   TOKEN(WORD);
-               }
-
-               if (PL_hints & HINT_STRICT_SUBS &&
-                   lastchar != '-' &&
-                   strnNE(s,"->",2) &&
-                   PL_last_lop_op != OP_TRUNCATE &&  /* S/F prototype in opcode.pl */
-                   PL_last_lop_op != OP_ACCEPT &&
-                   PL_last_lop_op != OP_PIPE_OP &&
-                   PL_last_lop_op != OP_SOCKPAIR)
-               {
-                   warn(
-                    "Bareword \"%s\" not allowed while \"strict subs\" in use",
-                       PL_tokenbuf);
-                   ++PL_error_count;
-               }
+               if (PL_hints & HINT_STRICT_SUBS)
+                   yylval.opval->op_private |= OPpCONST_STRICT;
 
                /* Call it a bare word */