Adding the new test would be swell.

[p5sagit/p5-mst-13.2.git] / toke.c

diff --git a/toke.c b/toke.c
index 00fe0b5..0781a9a 100644 (file)
--- a/toke.c
+++ b/toke.c
@@ -187,7 +187,8 @@ S_tokereport(pTHX_ char *thing, char* s, I32 rv)
     SV *report;
     DEBUG_T({
         report = newSVpv(thing, 0);
-        Perl_sv_catpvf(aTHX_ report, ":line %i:%i:", CopLINE(PL_curcop), rv);
+        Perl_sv_catpvf(aTHX_ report, ":line %d:%"IVdf":", CopLINE(PL_curcop),
+               (IV)rv);
 
         if (s - PL_bufptr > 0)
             sv_catpvn(report, PL_bufptr, s - PL_bufptr);
@@ -2846,6 +2847,8 @@ Perl_yylex(pTHX)
                s++;
            if (s < d)
                s++;
+           else if (s > d) /* Found by Ilya: feed random input to Perl. */
+             Perl_croak(aTHX_ "panic: input overflow");
            incline(s);
            if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) {
                PL_bufptr = s;
@@ -3770,7 +3773,7 @@ Perl_yylex(pTHX)
                TERM(THING);
            }
            /* avoid v123abc() or $h{v1}, allow C<print v10;> */
-           else if (!isALPHA(*start) && (PL_expect == XTERM || PL_expect == XREF)) {
+           else if (!isALPHA(*start) && (PL_expect == XTERM || PL_expect == XREF || PL_expect == XSTATE)) {
                char c = *start;
                GV *gv;
                *start = '\0';
@@ -4181,6 +4184,12 @@ Perl_yylex(pTHX)
                        (void)PerlIO_seek(PL_rsfp, 0L, 0);
                    }
                    if (PerlLIO_setmode(PerlIO_fileno(PL_rsfp), O_TEXT) != -1) {
+#ifdef PERLIO_IS_STDIO /* really? */
+#  if defined(__BORLANDC__)
+                       /* XXX see note in do_binmode() */
+                       ((FILE*)PL_rsfp)->flags &= ~_F_BIN;
+#  endif
+#endif
                        if (loc > 0)
                            PerlIO_seek(PL_rsfp, loc, 0);
                    }
@@ -5620,7 +5629,7 @@ Perl_keyword(pTHX_ register char *d, I32 len)
            if (strEQ(d,"rindex"))              return -KEY_rindex;
            break;
        case 7:
-           if (strEQ(d,"require"))             return -KEY_require;
+           if (strEQ(d,"require"))             return KEY_require;
            if (strEQ(d,"reverse"))             return -KEY_reverse;
            if (strEQ(d,"readdir"))             return -KEY_readdir;
            break;
@@ -6869,11 +6878,11 @@ S_scan_str(pTHX_ char *start, int keep_quoted, int keep_delims)
 
   Read a number in any of the formats that Perl accepts:
 
-  0(x[0-7A-F]+)|([0-7]+)|(b[01])
-  [\d_]+(\.[\d_]*)?[Ee](\d+)
-
-  Underbars (_) are allowed in decimal numbers.  If -w is on,
-  underbars before a decimal point must be at three digit intervals.
+  \d(_?\d)*(\.(\d(_?\d)*)?)?[Ee][\+\-]?(\d(_?\d)*)     12 12.34 12.
+  \.\d(_?\d)*[Ee][\+\-]?(\d(_?\d)*)                    .34
+  0b[01](_?[01])*
+  0[0-7](_?[0-7])*
+  0x[0-9A-Fa-f](_?[0-9A-Fa-f])*
 
   Like most scan_ routines, it uses the PL_tokenbuf buffer to hold the
   thing it reads.
@@ -6943,8 +6952,17 @@ Perl_scan_num(pTHX_ char *start, YYSTYPE* lvalp)
            else if (s[1] == '.' || s[1] == 'e' || s[1] == 'E')
                goto decimal;
            /* so it must be octal */
-           else
+           else {
                shift = 3;
+               s++;
+           }
+
+           if (*s == '_') {
+              if (ckWARN(WARN_SYNTAX))
+                  Perl_warner(aTHX_ WARN_SYNTAX,
+                              "Misplaced _ in number");
+              lastub = s++;
+           }
 
            base = bases[shift];
            Base = Bases[shift];
@@ -6962,9 +6980,12 @@ Perl_scan_num(pTHX_ char *start, YYSTYPE* lvalp)
                default:
                    goto out;
 
-               /* _ are ignored */
+               /* _ are ignored -- but warned about if consecutive */
                case '_':
-                   s++;
+                   if (ckWARN(WARN_SYNTAX) && lastub && s == lastub + 1)
+                       Perl_warner(aTHX_ WARN_SYNTAX,
+                                   "Misplaced _ in number");
+                   lastub = s++;
                    break;
 
                /* 8 and 9 are not octal */
@@ -7031,6 +7052,13 @@ Perl_scan_num(pTHX_ char *start, YYSTYPE* lvalp)
             the number.
          */
          out:
+
+           /* final misplaced underbar check */
+           if (s[-1] == '_') {
+               if (ckWARN(WARN_SYNTAX))
+                   Perl_warner(aTHX_ WARN_SYNTAX, "Misplaced _ in number");
+           }
+
            sv = NEWSV(92,0);
            if (overflowed) {
                if (ckWARN(WARN_PORTABLE) && n > 4294967295.0)
@@ -7070,9 +7098,10 @@ Perl_scan_num(pTHX_ char *start, YYSTYPE* lvalp)
               if -w is on
            */
            if (*s == '_') {
-               if (ckWARN(WARN_SYNTAX) && lastub && s - lastub != 3)
-                   Perl_warner(aTHX_ WARN_SYNTAX, "Misplaced _ in number");
-               lastub = ++s;
+               if (ckWARN(WARN_SYNTAX) && lastub && s == lastub + 1)
+                   Perl_warner(aTHX_ WARN_SYNTAX,
+                               "Misplaced _ in number");
+               lastub = s++;
            }
            else {
                /* check for end of fixed-length buffer */
@@ -7084,7 +7113,7 @@ Perl_scan_num(pTHX_ char *start, YYSTYPE* lvalp)
        }
 
        /* final misplaced underbar check */
-       if (lastub && s - lastub != 3) {
+       if (lastub && s == lastub + 1) {
            if (ckWARN(WARN_SYNTAX))
                Perl_warner(aTHX_ WARN_SYNTAX, "Misplaced _ in number");
        }
@@ -7097,16 +7126,34 @@ Perl_scan_num(pTHX_ char *start, YYSTYPE* lvalp)
            floatit = TRUE;
            *d++ = *s++;
 
-           /* copy, ignoring underbars, until we run out of
-              digits.  Note: no misplaced underbar checks!
+           if (*s == '_') {
+               if (ckWARN(WARN_SYNTAX))
+                   Perl_warner(aTHX_ WARN_SYNTAX,
+                               "Misplaced _ in number");
+               lastub = s;
+           }
+
+           /* copy, ignoring underbars, until we run out of digits.
            */
            for (; isDIGIT(*s) || *s == '_'; s++) {
                /* fixed length buffer check */
                if (d >= e)
                    Perl_croak(aTHX_ number_too_long);
-               if (*s != '_')
+               if (*s == '_') {
+                  if (ckWARN(WARN_SYNTAX) && lastub && s == lastub + 1)
+                      Perl_warner(aTHX_ WARN_SYNTAX,
+                                  "Misplaced _ in number");
+                  lastub = s;
+               }
+               else
                    *d++ = *s;
            }
+           /* fractional part ending in underbar? */
+           if (s[-1] == '_') {
+               if (ckWARN(WARN_SYNTAX))
+                   Perl_warner(aTHX_ WARN_SYNTAX,
+                               "Misplaced _ in number");
+           }
            if (*s == '.' && isDIGIT(s[1])) {
                /* oops, it's really a v-string, but without the "v" */
                s = start - 1;
@@ -7115,22 +7162,48 @@ Perl_scan_num(pTHX_ char *start, YYSTYPE* lvalp)
        }
 
        /* read exponent part, if present */
-       if (*s && strchr("eE",*s) && strchr("+-0123456789",s[1])) {
+       if (*s && strchr("eE",*s) && strchr("+-0123456789_", s[1])) {
            floatit = TRUE;
            s++;
 
            /* regardless of whether user said 3E5 or 3e5, use lower 'e' */
            *d++ = 'e';         /* At least some Mach atof()s don't grok 'E' */
 
+           /* stray preinitial _ */
+           if (*s == '_') {
+               if (ckWARN(WARN_SYNTAX))
+                   Perl_warner(aTHX_ WARN_SYNTAX,
+                               "Misplaced _ in number");
+               lastub = s++;
+           }
+
            /* allow positive or negative exponent */
            if (*s == '+' || *s == '-')
                *d++ = *s++;
 
-           /* read digits of exponent (no underbars :-) */
-           while (isDIGIT(*s)) {
-               if (d >= e)
-                   Perl_croak(aTHX_ number_too_long);
-               *d++ = *s++;
+           /* stray initial _ */
+           if (*s == '_') {
+               if (ckWARN(WARN_SYNTAX))
+                   Perl_warner(aTHX_ WARN_SYNTAX,
+                               "Misplaced _ in number");
+               lastub = s++;
+           }
+
+           /* read digits of exponent */
+           while (isDIGIT(*s) || *s == '_') {
+               if (isDIGIT(*s)) {
+                   if (d >= e)
+                       Perl_croak(aTHX_ number_too_long);
+                   *d++ = *s++;
+               }
+               else {
+                  if (ckWARN(WARN_SYNTAX) &&
+                      ((lastub && s == lastub + 1) ||
+                       (!isDIGIT(s[1]) && s[1] != '_')))
+                      Perl_warner(aTHX_ WARN_SYNTAX,
+                                  "Misplaced _ in number");
+                  lastub = s++;
+               }
            }
        }