projects / p5sagit/p5-mst-13.2.git / blobdiff
? search:
summary | shortlog | log | commit | commitdiff | tree
raw
[perl #8262] //g loops infinitely on tainted data
[p5sagit/p5-mst-13.2.git] / toke.c
diff --git a/toke.c b/toke.c
index 0a4452e..1b07e56 100644 (file)
--- a/toke.c
+++ b/toke.c
@@ -219,6 +219,7 @@ static struct debug_tokens { const int token, type; const char *name; }
     { BITOROP,         TOKENTYPE_OPNUM,        "BITOROP" },
     { COLONATTR,       TOKENTYPE_NONE,         "COLONATTR" },
     { CONTINUE,                TOKENTYPE_NONE,         "CONTINUE" },
+    { DEFAULT,         TOKENTYPE_NONE,         "DEFAULT" },
     { DO,              TOKENTYPE_NONE,         "DO" },
     { DOLSHARP,                TOKENTYPE_NONE,         "DOLSHARP" },
     { DORDOR,          TOKENTYPE_NONE,         "DORDOR" },
@@ -234,6 +235,7 @@ static struct debug_tokens { const int token, type; const char *name; }
     { FUNC0SUB,                TOKENTYPE_OPVAL,        "FUNC0SUB" },
     { FUNC1,           TOKENTYPE_OPNUM,        "FUNC1" },
     { FUNCMETH,                TOKENTYPE_OPVAL,        "FUNCMETH" },
+    { GIVEN,           TOKENTYPE_IVAL,         "GIVEN" },
     { HASHBRACK,       TOKENTYPE_NONE,         "HASHBRACK" },
     { IF,              TOKENTYPE_IVAL,         "IF" },
     { LABEL,           TOKENTYPE_PVAL,         "LABEL" },
@@ -269,6 +271,7 @@ static struct debug_tokens { const int token, type; const char *name; }
     { UNLESS,          TOKENTYPE_IVAL,         "UNLESS" },
     { UNTIL,           TOKENTYPE_IVAL,         "UNTIL" },
     { USE,             TOKENTYPE_IVAL,         "USE" },
+    { WHEN,            TOKENTYPE_IVAL,         "WHEN" },
     { WHILE,           TOKENTYPE_IVAL,         "WHILE" },
     { WORD,            TOKENTYPE_OPVAL,        "WORD" },
     { 0,               TOKENTYPE_NONE,         0 }
@@ -454,6 +457,23 @@ S_missingterm(pTHX_ char *s)
     Perl_croak(aTHX_ "Can't find string terminator %c%s%c anywhere before EOF",q,s,q);
 }
 
+#define FEATURE_IS_ENABLED(name, namelen)                              \
+       ((0 != (PL_hints & HINT_LOCALIZE_HH))                           \
+       && feature_is_enabled(name, namelen))
+/*
+ * S_feature_is_enabled
+ * Check whether the named feature is enabled.
+ */
+STATIC bool
+S_feature_is_enabled(pTHX_ char *name, STRLEN namelen)
+{
+    HV * const hinthv = GvHV(PL_hintgv);
+    char he_name[32] = "feature_";
+    (void) strncpy(&he_name[8], name, 24);
+    
+    return (hinthv && hv_exists(hinthv, he_name, 8 + namelen));
+}
+
 /*
  * Perl_deprecate
  */
@@ -3195,6 +3215,13 @@ Perl_yylex(pTHX)
        PL_lex_brackets++;
        /* FALL THROUGH */
     case '~':
+       if (s[1] == '~'
+       && (PL_expect == XOPERATOR || PL_expect == XTERMORDORDOR)
+       && FEATURE_IS_ENABLED("~~", 2))
+       {
+           s += 2;
+           Eop(OP_SMARTMATCH);
+       }
     case ',':
        tmp = *s++;
        OPERATOR(tmp);
@@ -4552,11 +4579,31 @@ Perl_yylex(pTHX)
        case KEY_bless:
            LOP(OP_BLESS,XTERM);
 
+       case KEY_break:
+           FUN0(OP_BREAK);
+
        case KEY_chop:
            UNI(OP_CHOP);
 
        case KEY_continue:
+           /* When 'use switch' is in effect, continue has a dual
+              life as a control operator. */
+           {
+               if (!FEATURE_IS_ENABLED("switch", 6))
+                   PREBLOCK(CONTINUE);
+               else {
+                   /* We have to disambiguate the two senses of
+                     "continue". If the next token is a '{' then
+                     treat it as the start of a continue block;
+                     otherwise treat it as a control operator.
+                    */
+                   s = skipspace(s);
+                   if (*s == '{')
            PREBLOCK(CONTINUE);
+                   else
+                       FUN0(OP_CONTINUE);
+               }
+           }
 
        case KEY_chdir:
            (void)gv_fetchpv("ENV",TRUE, SVt_PVHV);     /* may use HOME */
@@ -4601,6 +4648,9 @@ Perl_yylex(pTHX)
        case KEY_chroot:
            UNI(OP_CHROOT);
 
+       case KEY_default:
+           PREBLOCK(DEFAULT);
+
        case KEY_do:
            s = skipspace(s);
            if (*s == '{')
@@ -4823,6 +4873,10 @@ Perl_yylex(pTHX)
        case KEY_getlogin:
            FUN0(OP_GETLOGIN);
 
+       case KEY_given:
+           yylval.ival = CopLINE(PL_curcop);
+           OPERATOR(GIVEN);
+
        case KEY_glob:
            set_csh();
            LOP(OP_GLOB,XTERM);
@@ -5180,6 +5234,10 @@ Perl_yylex(pTHX)
            else
                TOKEN(1);       /* force error */
 
+       case KEY_say:
+           checkcomma(s,PL_tokenbuf,"filehandle");
+           LOP(OP_SAY,XREF);
+
        case KEY_chomp:
            UNI(OP_CHOMP);
        
@@ -5495,6 +5553,10 @@ Perl_yylex(pTHX)
        case KEY_vec:
            LOP(OP_VEC,XTERM);
 
+       case KEY_when:
+           yylval.ival = CopLINE(PL_curcop);
+           OPERATOR(WHEN);
+
        case KEY_while:
            yylval.ival = CopLINE(PL_curcop);
            OPERATOR(WHILE);
@@ -5871,7 +5933,7 @@ Perl_keyword (pTHX_ const char *name, I32 len)
           goto unknown;
       }
 
-    case 3: /* 28 tokens of length 3 */
+    case 3: /* 29 tokens of length 3 */
       switch (name[0])
       {
         case 'E':
@@ -6096,6 +6158,14 @@ Perl_keyword (pTHX_ const char *name, I32 len)
         case 's':
           switch (name[1])
           {
+            case 'a':
+              if (name[2] == 'y')
+              {                                   /* say        */
+                return (FEATURE_IS_ENABLED("say", 3) ? -KEY_say : 0);
+              }
+
+              goto unknown;
+
             case 'i':
               if (name[2] == 'n')
               {                                   /* sin        */
@@ -6156,7 +6226,7 @@ Perl_keyword (pTHX_ const char *name, I32 len)
           goto unknown;
       }
 
-    case 4: /* 40 tokens of length 4 */
+    case 4: /* 41 tokens of length 4 */
       switch (name[0])
       {
         case 'C':
@@ -6586,8 +6656,9 @@ Perl_keyword (pTHX_ const char *name, I32 len)
           }
 
         case 'w':
-          if (name[1] == 'a')
+          switch (name[1])
           {
+            case 'a':
             switch (name[2])
             {
               case 'i':
@@ -6609,6 +6680,12 @@ Perl_keyword (pTHX_ const char *name, I32 len)
               default:
                 goto unknown;
             }
+
+            case 'h':
+              if (name[2] == 'e' &&
+                  name[3] == 'n')
+              {                                   /* when       */
+                return (FEATURE_IS_ENABLED("switch", 6) ? KEY_when : 0);
           }
 
           goto unknown;
@@ -6617,7 +6694,11 @@ Perl_keyword (pTHX_ const char *name, I32 len)
           goto unknown;
       }
 
-    case 5: /* 36 tokens of length 5 */
+        default:
+          goto unknown;
+      }
+
+    case 5: /* 38 tokens of length 5 */
       switch (name[0])
       {
         case 'B':
@@ -6670,8 +6751,10 @@ Perl_keyword (pTHX_ const char *name, I32 len)
           }
 
         case 'b':
-          if (name[1] == 'l' &&
-              name[2] == 'e' &&
+          switch (name[1])
+          {
+            case 'l':
+              if (name[2] == 'e' &&
               name[3] == 's' &&
               name[4] == 's')
           {                                       /* bless      */
@@ -6680,6 +6763,20 @@ Perl_keyword (pTHX_ const char *name, I32 len)
 
           goto unknown;
 
+            case 'r':
+              if (name[2] == 'e' &&
+                  name[3] == 'a' &&
+                  name[4] == 'k')
+              {                                   /* break      */
+                return (FEATURE_IS_ENABLED("switch", 6) ? -KEY_break : 0);
+              }
+
+              goto unknown;
+
+            default:
+              goto unknown;
+          }
+
         case 'c':
           switch (name[1])
           {
@@ -6793,6 +6890,17 @@ Perl_keyword (pTHX_ const char *name, I32 len)
               goto unknown;
           }
 
+        case 'g':
+          if (name[1] == 'i' &&
+              name[2] == 'v' &&
+              name[3] == 'e' &&
+              name[4] == 'n')
+          {                                       /* given      */
+            return (FEATURE_IS_ENABLED("switch", 6) ? KEY_given : 0);
+          }
+
+          goto unknown;
+
         case 'i':
           switch (name[1])
           {
@@ -7529,7 +7637,7 @@ Perl_keyword (pTHX_ const char *name, I32 len)
           goto unknown;
       }
 
-    case 7: /* 28 tokens of length 7 */
+    case 7: /* 29 tokens of length 7 */
       switch (name[0])
       {
         case 'D':
@@ -7600,9 +7708,22 @@ Perl_keyword (pTHX_ const char *name, I32 len)
               goto unknown;
 
             case 'e':
-              if (name[2] == 'f' &&
-                  name[3] == 'i' &&
-                  name[4] == 'n' &&
+              if (name[2] == 'f')
+              {
+                switch (name[3])
+                {
+                  case 'a':
+                    if (name[4] == 'u' &&
+                        name[5] == 'l' &&
+                        name[6] == 't')
+                    {                             /* default    */
+                      return (FEATURE_IS_ENABLED("switch", 6) ? KEY_default : 0);
+                    }
+
+                    goto unknown;
+
+                  case 'i':
+                    if (name[4] == 'n' &&
                   name[5] == 'e' &&
                   name[6] == 'd')
               {                                   /* defined    */
@@ -7614,6 +7735,13 @@ Perl_keyword (pTHX_ const char *name, I32 len)
             default:
               goto unknown;
           }
+              }
+
+              goto unknown;
+
+            default:
+              goto unknown;
+          }
 
         case 'f':
           if (name[1] == 'o' &&
@@ -9020,7 +9148,7 @@ S_checkcomma(pTHX_ register char *s, const char *name, const char *what)
        while (s < PL_bufend && isSPACE(*s))
            s++;
        if (*s == ',') {
-           int kw;
+           I32 kw;
            *s = '\0'; /* XXX If we didn't do this, we could const a lot of toke.c */
            kw = keyword(w, s - w) || get_cv(w, FALSE) != 0;
            *s = ',';
@@ -10829,7 +10957,7 @@ Perl_yyerror(pTHX_ const char *s)
             OutCopFILE(PL_curcop));
     }
     PL_in_my = 0;
-    PL_in_my_stash = Nullhv;
+    PL_in_my_stash = NULL;
     return 0;
 }
 #ifdef __SC__
Unnamed repository; edit this file to name it for gitweb.