Update INSTALL regarding binary compatibility

[perl5.git] / toke.c

diff --git a/toke.c b/toke.c
index a5d5429..544cd1a 100644 (file)
--- a/toke.c
+++ b/toke.c
@@ -714,8 +714,9 @@ Perl_lex_start(pTHX_ SV *line, PerlIO *rsfp, bool new_filter)
 
     if (!len) {
        parser->linestr = newSVpvs("\n;");
-    } else if (SvREADONLY(line) || s[len-1] != ';') {
-       parser->linestr = newSVsv(line);
+    } else if (SvREADONLY(line) || s[len-1] != ';' || !SvPOK(line)) {
+       /* avoid tie/overload weirdness */
+       parser->linestr = newSVpvn_flags(s, len, SvUTF8(line));
        if (s[len-1] != ';')
            sv_catpvs(parser->linestr, "\n;");
     } else {
@@ -2811,7 +2812,8 @@ S_scan_const(pTHX_ char *start)
 
            s++;
 
-           /* deprecate \1 in strings and substitution replacements */
+           /* warn on \1 - \9 in substitution replacements, but note that \11
+            * is an octal; and \19 is \1 followed by '9' */
            if (PL_lex_inwhat == OP_SUBST && !PL_lex_inpat &&
                isDIGIT(*s) && *s != '0' && !isDIGIT(s[1]))
            {
@@ -2866,7 +2868,7 @@ S_scan_const(pTHX_ char *start)
                    goto default_action;
                }
 
-           /* eg. \132 indicates the octal constant 0x132 */
+           /* eg. \132 indicates the octal constant 0132 */
            case '0': case '1': case '2': case '3':
            case '4': case '5': case '6': case '7':
                {
@@ -2877,6 +2879,21 @@ S_scan_const(pTHX_ char *start)
                }
                goto NUM_ESCAPE_INSERT;
 
+           /* eg. \o{24} indicates the octal constant \024 */
+           case 'o':
+               {
+                   STRLEN len;
+                   const char* error;
+
+                   bool valid = grok_bslash_o(s, &uv, &len, &error, 1);
+                   s += len;
+                   if (! valid) {
+                       yyerror(error);
+                       continue;
+                   }
+                   goto NUM_ESCAPE_INSERT;
+               }
+
            /* eg. \x24 indicates the hex constant 0x24 */
            case 'x':
                ++s;
@@ -3270,7 +3287,8 @@ S_scan_const(pTHX_ char *start)
                             * should the trailing NUL be missing that this
                             * print won't run off the end of the string */
                            Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
-                               "Deprecated character in \\N{...}; marked by <-- HERE  in \\N{%.*s<-- HERE %.*s", i - s + 1, s, e - i, i + 1);
+                                       "Deprecated character in \\N{...}; marked by <-- HERE  in \\N{%.*s<-- HERE %.*s",
+                                       (int)(i - s + 1), s, (int)(e - i), i + 1);
                        }
                    }
                } /* End \N{NAME} */
@@ -3755,8 +3773,6 @@ Perl_filter_del(pTHX_ filter_t funcp)
     /* if filter is on top of stack (usual case) just pop it off */
     datasv = FILTER_DATA(AvFILLp(PL_rsfp_filters));
     if (IoANY(datasv) == FPTR2DPTR(void *, funcp)) {
-       IoFLAGS(datasv) &= ~IOf_FAKE_DIRP;
-       IoANY(datasv) = (void *)NULL;
        sv_free(av_pop(PL_rsfp_filters));
 
         return;
@@ -6189,8 +6205,9 @@ Perl_yylex(pTHX)
                gvp = 0;
                if (hgv && tmp != KEY_x && tmp != KEY_CORE)     /* never ambiguous */
                    Perl_ck_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
-                                  "Ambiguous call resolved as CORE::%s(), %s",
-                                  GvENAME(hgv), "qualify as such or use &");
+                                  "Ambiguous call resolved as CORE::%s(), "
+                                  "qualify as such or use &",
+                                  GvENAME(hgv));
            }
        }
 
@@ -6478,10 +6495,27 @@ Perl_yylex(pTHX)
                        const char *proto = SvPV_const(MUTABLE_SV(cv), protolen);
                        if (!protolen)
                            TERM(FUNC0SUB);
-                       if ((*proto == '$' || *proto == '_') && proto[1] == '\0')
-                           OPERATOR(UNIOPSUB);
                        while (*proto == ';')
                            proto++;
+                       if (
+                           (
+                               (
+                                   *proto == '$' || *proto == '_'
+                                || *proto == '*'
+                               )
+                            && proto[1] == '\0'
+                           )
+                        || (
+                            *proto == '\\' && proto[1] && proto[2] == '\0'
+                           )
+                       )
+                           OPERATOR(UNIOPSUB);
+                       if (*proto == '\\' && proto[1] == '[') {
+                           const char *p = proto + 2;
+                           while(*p && *p != ']')
+                               ++p;
+                           if(*p == ']' && !p[1]) OPERATOR(UNIOPSUB);
+                       }
                        if (*proto == '&' && *s == '{') {
                            if (PL_curstash)
                                sv_setpvs(PL_subname, "__ANON__");
@@ -8500,7 +8534,7 @@ Perl_keyword (pTHX_ const char *name, I32 len, bool all_keywords)
           if (name[1] == 'i' &&
               name[2] == 'e')
           {                                       /* tie        */
-            return KEY_tie;
+            return -KEY_tie;
           }
 
           goto unknown;
@@ -8944,7 +8978,7 @@ Perl_keyword (pTHX_ const char *name, I32 len, bool all_keywords)
                 case 'e':
                   if (name[3] == 'd')
                   {                               /* tied       */
-                    return KEY_tied;
+                    return -KEY_tied;
                   }
 
                   goto unknown;
@@ -9439,7 +9473,7 @@ Perl_keyword (pTHX_ const char *name, I32 len, bool all_keywords)
                     {
                       case 'e':
                         {                         /* untie      */
-                          return KEY_untie;
+                          return -KEY_untie;
                         }
 
                       case 'l':
@@ -11886,6 +11920,12 @@ S_scan_pat(pTHX_ char *start, I32 type)
 #endif
     while (*s && strchr(valid_flags, *s))
        pm->op_pmflags = S_pmflag(pm->op_pmflags, *s++);
+
+    if (isALNUM(*s)) {
+       Perl_ck_warner_d(aTHX_ packWARN(WARN_SYNTAX),
+           "Having no space between pattern and following word is deprecated");
+
+    }
 #ifdef PERL_MAD
     if (PL_madskills && modstart != s) {
        SV* tmptoken = newSVpvn(modstart, s - modstart);
@@ -11966,8 +12006,14 @@ S_scan_subst(pTHX_ char *start)
        }
        else if (strchr(S_PAT_MODS, *s))
            pm->op_pmflags = S_pmflag(pm->op_pmflags, *s++);
-       else
+       else {
+           if (isALNUM(*s)) {
+               Perl_ck_warner_d(aTHX_ packWARN(WARN_SYNTAX),
+                   "Having no space between pattern and following word is deprecated");
+
+           }
            break;
+       }
     }
 
 #ifdef PERL_MAD
@@ -12965,11 +13011,11 @@ Perl_scan_num(pTHX_ const char *start, YYSTYPE* lvalp)
            const char *base, *Base, *max;
 
            /* check for hex */
-           if (s[1] == 'x') {
+           if (s[1] == 'x' || s[1] == 'X') {
                shift = 4;
                s += 2;
                just_zero = FALSE;
-           } else if (s[1] == 'b') {
+           } else if (s[1] == 'b' || s[1] == 'B') {
                shift = 1;
                s += 2;
                just_zero = FALSE;
@@ -13083,13 +13129,12 @@ Perl_scan_num(pTHX_ const char *start, YYSTYPE* lvalp)
                Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX), "Misplaced _ in number");
            }
 
-           sv = newSV(0);
            if (overflowed) {
                if (n > 4294967295.0)
                    Perl_ck_warner(aTHX_ packWARN(WARN_PORTABLE),
                                   "%s number > %s non-portable",
                                   Base, max);
-               sv_setnv(sv, n);
+               sv = newSVnv(n);
            }
            else {
 #if UVSIZE > 4
@@ -13098,7 +13143,7 @@ Perl_scan_num(pTHX_ const char *start, YYSTYPE* lvalp)
                                   "%s number > %s non-portable",
                                   Base, max);
 #endif
-               sv_setuv(sv, u);
+               sv = newSVuv(u);
            }
            if (just_zero && (PL_hints & HINT_NEW_INTEGER))
                sv = new_constant(start, s - start, "integer",
@@ -13229,9 +13274,6 @@ Perl_scan_num(pTHX_ const char *start, YYSTYPE* lvalp)
        }
 
 
-       /* make an sv from the string */
-       sv = newSV(0);
-
        /*
            We try to do an integer conversion first if no characters
            indicating "float" have been found.
@@ -13243,12 +13285,12 @@ Perl_scan_num(pTHX_ const char *start, YYSTYPE* lvalp)
 
             if (flags == IS_NUMBER_IN_UV) {
               if (uv <= IV_MAX)
-               sv_setiv(sv, uv); /* Prefer IVs over UVs. */
+               sv = newSViv(uv); /* Prefer IVs over UVs. */
               else
-               sv_setuv(sv, uv);
+               sv = newSVuv(uv);
             } else if (flags == (IS_NUMBER_IN_UV | IS_NUMBER_NEG)) {
               if (uv <= (UV) IV_MIN)
-                sv_setiv(sv, -(IV)uv);
+                sv = newSViv(-(IV)uv);
               else
                floatit = TRUE;
             } else
@@ -13258,7 +13300,7 @@ Perl_scan_num(pTHX_ const char *start, YYSTYPE* lvalp)
            /* terminate the string */
            *d = '\0';
            nv = Atof(PL_tokenbuf);
-           sv_setnv(sv, nv);
+           sv = newSVnv(nv);
        }
 
        if ( floatit