Upgrade to Test::Harness 3.14

[perl5.git] / toke.c

diff --git a/toke.c b/toke.c
index cb73104..b2ba362 100644 (file)
--- a/toke.c
+++ b/toke.c
@@ -368,6 +368,7 @@ static struct debug_tokens {
     { WHEN,            TOKENTYPE_IVAL,         "WHEN" },
     { WHILE,           TOKENTYPE_IVAL,         "WHILE" },
     { WORD,            TOKENTYPE_OPVAL,        "WORD" },
+    { YADAYADA,                TOKENTYPE_IVAL,         "YADAYADA" },
     { 0,               TOKENTYPE_NONE,         NULL }
 };
 
@@ -760,8 +761,8 @@ Perl_parser_free(pTHX_  const yy_parser *parser)
 
     if (parser->rsfp == PerlIO_stdin())
        PerlIO_clearerr(parser->rsfp);
-    else if (parser->rsfp && parser->old_parser
-                         && parser->rsfp != parser->old_parser->rsfp)
+    else if (parser->rsfp && (!parser->old_parser ||
+               (parser->old_parser && parser->rsfp != parser->old_parser->rsfp)))
        PerlIO_close(parser->rsfp);
     SvREFCNT_dec(parser->rsfp_filters);
 
@@ -1359,7 +1360,7 @@ S_force_next(pTHX_ I32 type)
 #ifdef DEBUGGING
     if (DEBUG_T_TEST) {
         PerlIO_printf(Perl_debug_log, "### forced token:\n");
-       tokereport(THING, &NEXTVAL_NEXTTOKE);
+       tokereport(type, &NEXTVAL_NEXTTOKE);
     }
 #endif
 #ifdef PERL_MAD
@@ -2172,8 +2173,13 @@ S_scan_const(pTHX_ char *start)
        else if (*s == '$') {
            if (!PL_lex_inpat)  /* not a regexp, so $ must be var */
                break;
-           if (s + 1 < send && !strchr("()| \r\n\t", s[1]))
+           if (s + 1 < send && !strchr("()| \r\n\t", s[1])) {
+               if (s[1] == '\\' && ckWARN(WARN_AMBIGUOUS)) {
+                   Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
+                               "Possible unintended interpolation of $\\ in regex");
+               }
                break;          /* in regexp, $ might be tail anchor */
+            }
        }
 
        /* End of else if chain - OP_TRANS rejoin rest */
@@ -3688,6 +3694,9 @@ Perl_yylex(pTHX)
                sv_free((SV*)PL_preambleav);
                PL_preambleav = NULL;
            }
+           if (PL_minus_E)
+               sv_catpvs(PL_linestr,
+                         "use feature ':5." STRINGIFY(PERL_VERSION) "';");
            if (PL_minus_n || PL_minus_p) {
                sv_catpvs(PL_linestr, "LINE: while (<>) {");
                if (PL_minus_l)
@@ -3719,9 +3728,6 @@ Perl_yylex(pTHX)
                        sv_catpvs(PL_linestr,"our @F=split(' ');");
                }
            }
-           if (PL_minus_E)
-               sv_catpvs(PL_linestr,
-                         "use feature ':5." STRINGIFY(PERL_VERSION) "';");
            sv_catpvs(PL_linestr, "\n");
            PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
            PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
@@ -4774,6 +4780,10 @@ Perl_yylex(pTHX)
        pl_yylval.ival = 0;
        OPERATOR(ASSIGNOP);
     case '!':
+       if (PL_expect == XSTATE && s[1] == '!' && s[2] == '!') {
+           s += 3;
+           LOP(OP_DIE,XTERM);
+       }
        s++;
        {
            const char tmp = *s++;
@@ -5025,10 +5035,14 @@ Perl_yylex(pTHX)
            AOPERATOR(DORDOR);
        }
      case '?':                 /* may either be conditional or pattern */
-        if(PL_expect == XOPERATOR) {
+       if (PL_expect == XSTATE && s[1] == '?' && s[2] == '?') {
+           s += 3;
+           LOP(OP_WARN,XTERM);
+       }
+       if (PL_expect == XOPERATOR) {
             char tmp = *s++;
             if(tmp == '?') {
-                 OPERATOR('?');
+               OPERATOR('?');
             }
              else {
                 tmp = *s++;
@@ -5067,6 +5081,10 @@ Perl_yylex(pTHX)
            PL_expect = XSTATE;
            goto rightbracket;
        }
+       if (PL_expect == XSTATE && s[1] == '.' && s[2] == '.') {
+           s += 3;
+           OPERATOR(YADAYADA);
+       }
        if (PL_expect == XOPERATOR || !isDIGIT(s[1])) {
            char tmp = *s++;
            if (*s == tmp) {
@@ -5654,10 +5672,10 @@ Perl_yylex(pTHX)
 
                /* Call it a bare word */
 
+               bareword:
                if (PL_hints & HINT_STRICT_SUBS)
                    pl_yylval.opval->op_private |= OPpCONST_STRICT;
                else {
-               bareword:
                    if (lastchar != '-') {
                        if (ckWARN(WARN_RESERVED)) {
                            d = PL_tokenbuf;
@@ -6670,7 +6688,7 @@ Perl_yylex(pTHX)
                    (*s == ':' && s[1] == ':'))
                {
 #ifdef PERL_MAD
-                   SV *nametoke;
+                   SV *nametoke = NULL;
 #endif
 
                    PL_expect = XBLOCK;
@@ -6731,6 +6749,12 @@ Perl_yylex(pTHX)
                if (*s == '(') {
                    char *p;
                    bool bad_proto = FALSE;
+                   bool in_brackets = FALSE;
+                   char greedy_proto = ' ';
+                   bool proto_after_greedy_proto = FALSE;
+                   bool must_be_last = FALSE;
+                   bool underscore = FALSE;
+                   bool seen_underscore = FALSE;
                    const bool warnsyntax = ckWARN(WARN_SYNTAX);
 
                    s = scan_str(s,!!PL_madskills,FALSE);
@@ -6742,14 +6766,47 @@ Perl_yylex(pTHX)
                    for (p = d; *p; ++p) {
                        if (!isSPACE(*p)) {
                            d[tmp++] = *p;
-                           if (warnsyntax && !strchr("$@%*;[]&\\_", *p))
-                               bad_proto = TRUE;
+
+                           if (warnsyntax) {
+                               if (must_be_last)
+                                   proto_after_greedy_proto = TRUE;
+                               if (!strchr("$@%*;[]&\\_", *p)) {
+                                   bad_proto = TRUE;
+                               }
+                               else {
+                                   if ( underscore ) {
+                                       if ( *p != ';' )
+                                           bad_proto = TRUE;
+                                       underscore = FALSE;
+                                   }
+                                   if ( *p == '[' ) {
+                                       in_brackets = TRUE;
+                                   }
+                                   else if ( *p == ']' ) {
+                                       in_brackets = FALSE;
+                                   }
+                                   else if ( (*p == '@' || *p == '%') &&
+                                        ( tmp < 2 || d[tmp-2] != '\\' ) &&
+                                        !in_brackets ) {
+                                       must_be_last = TRUE;
+                                       greedy_proto = *p;
+                                   }
+                                   else if ( *p == '_' ) {
+                                       underscore = seen_underscore = TRUE;
+                                   }
+                               }
+                           }
                        }
                    }
                    d[tmp] = '\0';
+                   if (proto_after_greedy_proto)
+                       Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
+                                   "Prototype after '%c' for %"SVf" : %s",
+                                   greedy_proto, SVfARG(PL_subname), d);
                    if (bad_proto)
                        Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
-                                   "Illegal character in prototype for %"SVf" : %s",
+                                   "Illegal character %sin prototype for %"SVf" : %s",
+                                   seen_underscore ? "after '_' " : "",
                                    SVfARG(PL_subname), d);
                    SvCUR_set(PL_lex_stuff, tmp);
                    have_proto = TRUE;
@@ -11074,9 +11131,9 @@ S_scan_trans(pTHX_ char *start)
     register char* s;
     OP *o;
     short *tbl;
-    I32 squash;
-    I32 del;
-    I32 complement;
+    U8 squash;
+    U8 del;
+    U8 complement;
 #ifdef PERL_MAD
     char *modstart;
 #endif
@@ -12372,8 +12429,8 @@ S_scan_formline(pTHX_ register char *s)
     bool eofmt = FALSE;
 #ifdef PERL_MAD
     char *tokenstart = s;
-    SV* savewhite;
-    
+    SV* savewhite = NULL;
+
     if (PL_madskills) {
        savewhite = PL_thiswhite;
        PL_thiswhite = 0;